ab416326ad
Previously it was a tuple, which meant it couldn't have sensible custom instances. Token and TokenType now have Show instances, so we get more useful output when parsing fails.
392 lines
14 KiB
Haskell
392 lines
14 KiB
Haskell
{-
|
|
Tock: a compiler for parallel languages
|
|
Copyright (C) 2007 University of Kent
|
|
Copyright (C) 2008 Adam Sampson <ats@offog.org>
|
|
|
|
This program is free software; you can redistribute it and/or modify it
|
|
under the terms of the GNU General Public License as published by the
|
|
Free Software Foundation, either version 2 of the License, or (at your
|
|
option) any later version.
|
|
|
|
This program is distributed in the hope that it will be useful, but
|
|
WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
General Public License for more details.
|
|
|
|
You should have received a copy of the GNU General Public License along
|
|
with this program. If not, see <http://www.gnu.org/licenses/>.
|
|
-}
|
|
|
|
-- | Preprocess occam code.
|
|
module PreprocessOccam (preprocessOccamProgram, preprocessOccamSource,
|
|
preprocessOccam, expandIncludes) where
|
|
|
|
import Control.Monad.State
|
|
import Data.List
|
|
import qualified Data.Map as Map
|
|
import qualified Data.Set as Set
|
|
import Numeric
|
|
import System.IO
|
|
import Text.ParserCombinators.Parsec
|
|
import Text.ParserCombinators.Parsec.Language (haskellDef)
|
|
import qualified Text.ParserCombinators.Parsec.Token as P
|
|
import Text.Regex
|
|
|
|
import CompState
|
|
import Errors
|
|
import LexOccam
|
|
import Metadata
|
|
import Pass
|
|
import PrettyShow
|
|
import StructureOccam
|
|
import Utils
|
|
|
|
-- | Open an included file, looking for it in the search path.
|
|
-- Return the open filehandle and the location of the file.
|
|
-- FIXME: This doesn't actually look at the search path yet.
|
|
searchFile :: Meta -> String -> PassM (Handle, String)
|
|
searchFile m filename
|
|
= do cs <- get
|
|
let currentFile = csCurrentFile cs
|
|
let possibilities = [joinPath currentFile filename]
|
|
openOneOf possibilities
|
|
where
|
|
openOneOf :: [String] -> PassM (Handle, String)
|
|
openOneOf [] = dieP m $ "Unable to find " ++ filename
|
|
openOneOf (fn:fns)
|
|
= do r <- liftIO $ maybeIO $ openFile fn ReadMode
|
|
case r of
|
|
Just h -> return (h, fn)
|
|
Nothing -> openOneOf fns
|
|
|
|
-- | Preprocess a file and return its tokenised form ready for parsing.
|
|
preprocessFile :: Meta -> String -> PassM [Token]
|
|
preprocessFile m filename
|
|
= do (handle, realFilename) <- searchFile m filename
|
|
progress $ "Loading source file " ++ realFilename
|
|
origCS <- get
|
|
modify (\cs -> cs { csCurrentFile = realFilename })
|
|
s <- liftIO $ hGetContents handle
|
|
toks <- preprocessSource m realFilename s
|
|
modify (\cs -> cs { csCurrentFile = csCurrentFile origCS })
|
|
return toks
|
|
|
|
-- | Preprocesses source directly and returns its tokenised form ready for parsing.
|
|
preprocessSource :: Meta -> String -> String -> PassM [Token]
|
|
preprocessSource m realFilename s
|
|
= do toks <- runLexer realFilename s
|
|
veryDebug $ "{{{ lexer tokens"
|
|
veryDebug $ pshow toks
|
|
veryDebug $ "}}}"
|
|
toks' <- preprocessOccam toks
|
|
veryDebug $ "{{{ preprocessed tokens"
|
|
veryDebug $ pshow toks'
|
|
veryDebug $ "}}}"
|
|
toks'' <- structureOccam toks'
|
|
veryDebug $ "{{{ structured tokens"
|
|
veryDebug $ pshow toks''
|
|
veryDebug $ "}}}"
|
|
expandIncludes toks''
|
|
|
|
-- | Expand 'IncludeFile' markers in a token stream.
|
|
expandIncludes :: [Token] -> PassM [Token]
|
|
expandIncludes [] = return []
|
|
expandIncludes (Token m (IncludeFile filename) : Token _ EndOfLine : ts)
|
|
= do contents <- preprocessFile m filename
|
|
rest <- expandIncludes ts
|
|
return $ contents ++ rest
|
|
expandIncludes (Token m (IncludeFile _) : _)
|
|
= error "IncludeFile token should be followed by EndOfLine"
|
|
expandIncludes (t:ts) = expandIncludes ts >>* (t :)
|
|
|
|
-- | Preprocess a token stream.
|
|
preprocessOccam :: [Token] -> PassM [Token]
|
|
preprocessOccam [] = return []
|
|
preprocessOccam (Token m (TokPreprocessor s) : ts)
|
|
= handleDirective m (stripPrefix s) ts >>= preprocessOccam
|
|
where
|
|
stripPrefix :: String -> String
|
|
stripPrefix (' ':cs) = stripPrefix cs
|
|
stripPrefix ('\t':cs) = stripPrefix cs
|
|
stripPrefix ('#':cs) = cs
|
|
stripPrefix _ = error "bad TokPreprocessor prefix"
|
|
preprocessOccam (Token _ (TokReserved "##") : Token m (TokIdentifier var) : ts)
|
|
= do st <- get
|
|
case Map.lookup var (csDefinitions st) of
|
|
Just (PreprocInt num) -> toToken $ TokIntLiteral num
|
|
Just (PreprocString str) -> toToken $ TokStringLiteral str
|
|
Just (PreprocNothing) -> dieP m $ var ++ " is defined, but has no value"
|
|
Nothing -> dieP m $ var ++ " is not defined"
|
|
where
|
|
toToken tt
|
|
= do rest <- preprocessOccam ts
|
|
return $ Token m tt : rest
|
|
preprocessOccam (Token m (TokReserved "##") : _)
|
|
= dieP m "Invalid macro expansion syntax"
|
|
preprocessOccam (t:ts)
|
|
= do rest <- preprocessOccam ts
|
|
return $ t : rest
|
|
|
|
--{{{ preprocessor directive handlers
|
|
type DirectiveFunc = Meta -> [String] -> PassM ([Token] -> PassM [Token])
|
|
|
|
-- | Call the handler for a preprocessor directive.
|
|
handleDirective :: Meta -> String -> [Token] -> PassM [Token]
|
|
handleDirective m s x
|
|
= do f <- lookup s directives
|
|
f x
|
|
where
|
|
lookup :: String -> [(Regex, DirectiveFunc)] -> PassM ([Token] -> PassM [Token])
|
|
-- FIXME: This should really be an error rather than a warning, but
|
|
-- currently we support so few preprocessor directives that this is more
|
|
-- useful.
|
|
lookup s []
|
|
= do addWarning m "Unknown preprocessor directive ignored"
|
|
return return
|
|
lookup s ((re, func):ds)
|
|
= case matchRegex re s of
|
|
Just fields -> func m fields
|
|
Nothing -> lookup s ds
|
|
|
|
-- | List of handlers for preprocessor directives.
|
|
-- `handleDirective` walks down the regexps in this list until it finds one
|
|
-- that matches, then uses the corresponding function.
|
|
directives :: [(Regex, DirectiveFunc)]
|
|
directives =
|
|
[ (mkRegex "^INCLUDE +\"(.*)\"$", handleInclude)
|
|
, (mkRegex "^USE +\"(.*)\"$", handleUse)
|
|
, (mkRegex "^COMMENT +.*$", handleIgnorable)
|
|
, (mkRegex "^DEFINE +(.*)$", handleDefine)
|
|
, (mkRegex "^UNDEF +([^ ]+)$", handleUndef)
|
|
, (mkRegex "^IF +(.*)$", handleIf)
|
|
, (mkRegex "^ELSE", handleUnmatched)
|
|
, (mkRegex "^ENDIF", handleUnmatched)
|
|
]
|
|
|
|
-- | Handle a directive that can be ignored.
|
|
handleIgnorable :: DirectiveFunc
|
|
handleIgnorable _ _ = return return
|
|
|
|
-- | Handle a directive that should have been removed as part of handling an
|
|
-- earlier directive.
|
|
handleUnmatched :: DirectiveFunc
|
|
handleUnmatched m _ = dieP m "Unmatched #ELSE/#ENDIF"
|
|
|
|
-- | Handle the @#INCLUDE@ directive.
|
|
handleInclude :: DirectiveFunc
|
|
handleInclude m [incName]
|
|
= return (\ts -> return $ Token m (IncludeFile incName) : ts)
|
|
|
|
-- | Handle the @#USE@ directive.
|
|
-- This is a bit of a hack at the moment, since it just includes the file
|
|
-- textually.
|
|
handleUse :: DirectiveFunc
|
|
handleUse m [modName]
|
|
= do let incName = mangleModName modName
|
|
cs <- get
|
|
put $ cs { csUsedFiles = Set.insert incName (csUsedFiles cs) }
|
|
if Set.member incName (csUsedFiles cs)
|
|
then return return
|
|
else handleInclude m [incName]
|
|
where
|
|
-- | If a module name doesn't already have a suffix, add one.
|
|
mangleModName :: String -> String
|
|
mangleModName mod
|
|
= if ".occ" `isSuffixOf` mod || ".inc" `isSuffixOf` mod
|
|
then mod
|
|
else mod ++ ".occ"
|
|
|
|
-- | Handle the @#DEFINE@ directive.
|
|
handleDefine :: DirectiveFunc
|
|
handleDefine m [definition]
|
|
= do (var, value) <- runPreprocParser m defineDirective definition
|
|
st <- get
|
|
when (Map.member var $ csDefinitions st) $
|
|
dieP m $ "Preprocessor symbol is already defined: " ++ var
|
|
put $ st { csDefinitions = Map.insert var value $ csDefinitions st }
|
|
return return
|
|
|
|
-- | Handle the @#UNDEF@ directive.
|
|
handleUndef :: DirectiveFunc
|
|
handleUndef m [var]
|
|
= do modify $ \st -> st { csDefinitions = Map.delete var $ csDefinitions st }
|
|
return return
|
|
|
|
-- | Handle the @#IF@ directive.
|
|
handleIf :: DirectiveFunc
|
|
handleIf m [condition]
|
|
= do b <- runPreprocParser m expression condition
|
|
return $ skipCondition b 0
|
|
where
|
|
skipCondition :: Bool -> Int -> [Token] -> PassM [Token]
|
|
skipCondition _ _ [] = dieP m "Couldn't find a matching #ENDIF"
|
|
|
|
-- At level 0, we flip state on ELSE and finish on ENDIF.
|
|
skipCondition b 0 (t@(Token _ (TokPreprocessor pp)) : ts)
|
|
| "#IF" `isPrefixOf` pp = skipCondition b 1 ts >>* (t :)
|
|
| "#ELSE" `isPrefixOf` pp = skipCondition (not b) 0 ts
|
|
| "#ENDIF" `isPrefixOf` pp = return ts
|
|
| otherwise = copyThrough b 0 t ts
|
|
|
|
-- At higher levels, we just count up and down on IF and ENDIF.
|
|
skipCondition b n (t@(Token _ (TokPreprocessor pp)) : ts)
|
|
| "#IF" `isPrefixOf` pp = skipCondition b (n + 1) ts >>* (t :)
|
|
| "#ENDIF" `isPrefixOf` pp = skipCondition b (n - 1) ts >>* (t :)
|
|
| otherwise = copyThrough b n t ts
|
|
|
|
-- And otherwise we copy through tokens if the condition's true.
|
|
skipCondition b n (t:ts) = copyThrough b n t ts
|
|
|
|
copyThrough :: Bool -> Int -> Token -> [Token] -> PassM [Token]
|
|
copyThrough True n t ts = skipCondition True n ts >>* (t :)
|
|
copyThrough False n _ ts = skipCondition False n ts
|
|
--}}}
|
|
|
|
--{{{ parser for preprocessor expressions
|
|
type PreprocParser = GenParser Char (Map.Map String PreprocDef)
|
|
|
|
--{{{ lexer
|
|
reservedOps :: [String]
|
|
reservedOps = ["=", "<>", "<", "<=", ">", ">="]
|
|
|
|
ppLexer :: P.TokenParser (Map.Map String PreprocDef)
|
|
ppLexer = P.makeTokenParser (haskellDef
|
|
{ P.identStart = letter <|> digit
|
|
, P.identLetter = letter <|> digit <|> char '.'
|
|
, P.reservedOpNames = reservedOps
|
|
})
|
|
|
|
lexeme :: PreprocParser a -> PreprocParser a
|
|
lexeme = P.lexeme ppLexer
|
|
|
|
whiteSpace :: PreprocParser ()
|
|
whiteSpace = P.whiteSpace ppLexer
|
|
|
|
identifier :: PreprocParser String
|
|
identifier = P.identifier ppLexer
|
|
|
|
parens :: PreprocParser a -> PreprocParser a
|
|
parens = P.parens ppLexer
|
|
|
|
symbol :: String -> PreprocParser String
|
|
symbol = P.symbol ppLexer
|
|
|
|
reservedOp :: String -> PreprocParser ()
|
|
reservedOp = P.reservedOp ppLexer
|
|
--}}}
|
|
|
|
tryVX :: PreprocParser a -> PreprocParser b -> PreprocParser a
|
|
tryVX a b = try (do { av <- a; b; return av })
|
|
|
|
tryVV :: PreprocParser a -> PreprocParser b -> PreprocParser (a, b)
|
|
tryVV a b = try (do { av <- a; bv <- b; return (av, bv) })
|
|
|
|
literal :: PreprocParser PreprocDef
|
|
literal
|
|
= (lexeme $ do { ds <- many1 digit; return $ PreprocInt ds })
|
|
<|> (lexeme $ do { char '"'; s <- manyTill anyChar $ char '"'; return $ PreprocString s })
|
|
<?> "preprocessor literal"
|
|
|
|
defineDirective :: PreprocParser (String, PreprocDef)
|
|
defineDirective
|
|
= do whiteSpace
|
|
var <- identifier
|
|
value <- option PreprocNothing literal
|
|
eof
|
|
return (var, value)
|
|
<?> "preprocessor definition"
|
|
|
|
defined :: PreprocParser Bool
|
|
defined
|
|
= do symbol "DEFINED"
|
|
var <- parens identifier
|
|
definitions <- getState
|
|
return $ Map.member var definitions
|
|
|
|
simpleExpression :: PreprocParser Bool
|
|
simpleExpression
|
|
= do { try $ symbol "NOT"; e <- expression; return $ not e }
|
|
<|> do { try $ symbol "TRUE"; return True }
|
|
<|> do { try $ symbol "FALSE"; return False }
|
|
<|> defined
|
|
<|> parens expression
|
|
<?> "preprocessor simple expression"
|
|
|
|
operand :: PreprocParser PreprocDef
|
|
operand
|
|
= literal
|
|
<|> do var <- identifier
|
|
definitions <- getState
|
|
case Map.lookup var definitions of
|
|
Nothing -> fail $ var ++ " is not defined"
|
|
Just PreprocNothing -> fail $ var ++ " is defined, but has no value"
|
|
Just value -> return value
|
|
<?> "preprocessor operand"
|
|
|
|
comparisonOp :: PreprocParser String
|
|
comparisonOp
|
|
= choice [do { try $ reservedOp op; return op } | op <- reservedOps]
|
|
<?> "preprocessor comparison operator"
|
|
|
|
-- | Apply a comparison operator to two values, checking the types are
|
|
-- appropriate.
|
|
applyComparison :: String -> PreprocDef -> PreprocDef -> PreprocParser Bool
|
|
applyComparison op (PreprocString l) (PreprocString r)
|
|
= case op of
|
|
"=" -> return $ l == r
|
|
"<>" -> return $ l /= r
|
|
_ -> fail "Invalid operator for string comparison"
|
|
applyComparison op (PreprocInt l) (PreprocInt r)
|
|
= do lv <- getInt l
|
|
rv <- getInt r
|
|
case op of
|
|
"=" -> return $ lv == rv
|
|
"<>" -> return $ lv /= rv
|
|
"<" -> return $ lv < rv
|
|
"<=" -> return $ lv <= rv
|
|
">" -> return $ lv > rv
|
|
">=" -> return $ lv >= rv
|
|
where
|
|
getInt :: String -> PreprocParser Int
|
|
getInt s
|
|
= case readDec s of
|
|
[(v, "")] -> return v
|
|
_ -> fail $ "Bad integer literal: " ++ s
|
|
applyComparison _ _ _ = fail "Invalid types for comparison"
|
|
|
|
expression :: PreprocParser Bool
|
|
expression
|
|
= do { l <- tryVX simpleExpression (symbol "AND"); r <- simpleExpression; return $ l && r }
|
|
<|> do { l <- tryVX simpleExpression (symbol "OR"); r <- simpleExpression; return $ l || r }
|
|
<|> do { (l, op) <- tryVV operand comparisonOp; r <- operand; applyComparison op l r }
|
|
<|> simpleExpression
|
|
<?> "preprocessor complex expression"
|
|
|
|
-- | Match a 'PreprocParser' production.
|
|
runPreprocParser :: Meta -> PreprocParser a -> String -> PassM a
|
|
runPreprocParser m prod s
|
|
= do st <- get
|
|
case runParser wrappedProd (csDefinitions st) (show m) s of
|
|
Left err -> dieP m $ "Error parsing preprocessor instruction: " ++ show err
|
|
Right b -> return b
|
|
where
|
|
wrappedProd
|
|
= do whiteSpace
|
|
v <- prod
|
|
eof
|
|
return v
|
|
--}}}
|
|
|
|
-- | Load and preprocess an occam program.
|
|
preprocessOccamProgram :: String -> PassM [Token]
|
|
preprocessOccamProgram filename
|
|
= do toks <- preprocessFile emptyMeta filename
|
|
veryDebug $ "{{{ tokenised source"
|
|
veryDebug $ pshow toks
|
|
veryDebug $ "}}}"
|
|
return toks
|
|
|
|
-- | Preprocesses occam source direct from the given String
|
|
preprocessOccamSource :: String -> PassM [Token]
|
|
preprocessOccamSource source = preprocessSource emptyMeta "<unknown>" source
|