suzanne.soy/tock-mirror
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Initial implementation of the occam-pi preprocessor.

Browse Source 
This implements #DEFINE, #UNDEF, #IF, #ELSE and #ENDIF, macro expansion with
##, and TRUE, FALSE, AND, OR, NOT and DEFINED within #IF expressions, with the
same semantics as occ21.

The macro COMPILER.TOCK is always defined by default, so you can now say things
like "#IF NOT DEFINED (COMPILER.TOCK) ... #ENDIF".
This commit is contained in:
Adam Sampson 2008-02-28 20:27:30 +00:00
parent 62b9c9b105
commit 8f2575819b
7 changed files with 354 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
Makefile.am
View File

@ -152,6 +152,7 @@ tocktest_SOURCES += common/TestHarness.hs
tocktest_SOURCES += common/TestUtils.hs
tocktest_SOURCES += flow/FlowGraphTest.hs
tocktest_SOURCES += frontends/ParseRainTest.hs
tocktest_SOURCES += frontends/PreprocessOccamTest.hs
tocktest_SOURCES += frontends/RainPassesTest.hs
tocktest_SOURCES += frontends/RainTypesTest.hs
tocktest_SOURCES += transformations/PassTest.hs

2
TestMain.hs
View File

@ -52,6 +52,7 @@ import qualified FlowGraphTest (qcTests)
import qualified GenerateCTest (tests)
import qualified ParseRainTest (tests)
import qualified PassTest (tests)
import qualified PreprocessOccamTest (tests)
import qualified RainPassesTest (tests)
import qualified RainTypesTest (tests)
import qualified UsageCheckTest (tests)
@ -127,6 +128,7 @@ main = do (opts, nonOpts, errs) <- getArgs >>* getOpt RequireOrder options
,noqc GenerateCTest.tests
,noqc ParseRainTest.tests
,noqc PassTest.tests
,noqc PreprocessOccamTest.tests
,noqc RainPassesTest.tests
,noqc RainTypesTest.tests
,noqc UsageCheckTest.tests

1
common/PrettyShow.hs
View File

@ -137,6 +137,7 @@ doPattern p@(Match c ps) =
doAny :: (forall a. Data a => (a -> Doc) -> (a -> Doc)) -> GenericQ Doc
doAny extFunc = extFunc (
(doGeneral anyFunc) `ext1Q` (doList anyFunc) `extQ` doString `extQ` doMeta `extQ` doPattern
`extQ` (doMap anyFunc :: Map.Map String PreprocDef -> Doc)
`extQ` (doMap anyFunc :: Map.Map String String -> Doc)
`extQ` (doMap anyFunc :: Map.Map String A.NameDef -> Doc)
`extQ` (doMap anyFunc :: Map.Map String [A.Type] -> Doc)

14
data/CompState.hs
View File

@ -46,6 +46,16 @@ data CompBackend = BackendC | BackendCPPCSP | BackendDumpAST
data CompFrontend = FrontendOccam | FrontendRain
deriving (Show, Data, Typeable, Eq)
-- | Preprocessor definitions.
data PreprocDef =
PreprocNothing
| PreprocInt String
| PreprocString String
deriving (Show, Data, Typeable, Eq)
-- | An item that has been pulled up.
type PulledItem = (Meta, Either A.Specification A.Process) -- Either Spec or ProcThen
-- | State necessary for compilation.
data CompState = CompState {
-- This structure needs to be printable with pshow.
@ -66,6 +76,7 @@ data CompState = CompState {
-- Set by preprocessor
csCurrentFile :: String,
csUsedFiles :: Set String,
csDefinitions :: Map String PreprocDef,
-- Set by Parse
csLocalNames :: [(String, A.Name)],
@ -84,8 +95,6 @@ data CompState = CompState {
}
deriving (Data, Typeable)
type PulledItem = (Meta, Either A.Specification A.Process) -- Either Spec or ProcThen
emptyState :: CompState
emptyState = CompState {
csMode = ModeFull,
@ -99,6 +108,7 @@ emptyState = CompState {
csCurrentFile = "none",
csUsedFiles = Set.empty,
csDefinitions = Map.insert "COMPILER.TOCK" PreprocNothing Map.empty,
csLocalNames = [],
csMainLocals = [],

1
frontends/LexOccam.x
View File

@ -49,6 +49,7 @@ $vertSpace = [\r\n]
| ">=" | "<="
| "<" | ">"
| "~"
| "##"
| "AFTER" | "ALT" | "AND" | "ANY" | "AT"
| "BITAND" | "BITNOT" | "BITOR" | "BOOL" | "BYTE" | "BYTESIN"
| "CASE" | "CHAN"

173
frontends/PreprocessOccam.hs
View File

@ -1,6 +1,7 @@
{-
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
@ -17,12 +18,16 @@ with this program. If not, see <http://www.gnu.org/licenses/>.
-}
-- | Preprocess occam code.
module PreprocessOccam (preprocessOccamProgram, preprocessOccamSource) where
module PreprocessOccam (preprocessOccamProgram, preprocessOccamSource, preprocessOccam) where
import Control.Monad.State
import Data.List
import qualified Data.Map as Map
import qualified Data.Set as Set
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
@ -85,9 +90,9 @@ preprocessSource m realFilename s
preprocessOccam :: [Token] -> PassM [Token]
preprocessOccam [] = return []
preprocessOccam ((m, TokPreprocessor s):(_, EndOfLine):ts)
= do func <- handleDirective m (stripPrefix s)
rest <- preprocessOccam ts
return $ func rest
= do (beforeRest, afterRest) <- handleDirective m (stripPrefix s)
rest <- beforeRest ts >>= preprocessOccam
return $ afterRest rest
where
stripPrefix :: String -> String
stripPrefix (' ':cs) = stripPrefix cs
@ -97,15 +102,28 @@ preprocessOccam ((m, TokPreprocessor s):(_, EndOfLine):ts)
-- Check the above case didn't miss something.
preprocessOccam ((_, TokPreprocessor _):_)
= error "bad TokPreprocessor token"
preprocessOccam ((_, TokReserved "##") : (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 $ (m, tt) : rest
preprocessOccam ((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] -> [Token])
type DirectiveFunc = Meta -> [String] -> PassM ([Token] -> PassM [Token], [Token] -> [Token])
-- | Call the handler for a preprocessor directive.
handleDirective :: Meta -> String -> PassM ([Token] -> [Token])
handleDirective :: Meta -> String -> PassM ([Token] -> PassM [Token], [Token] -> [Token])
handleDirective m s = lookup s directives
where
-- FIXME: This should really be an error rather than a warning, but
@ -113,7 +131,7 @@ handleDirective m s = lookup s directives
-- useful.
lookup s []
= do addWarning m "Unknown preprocessor directive ignored"
return id
return (return, id)
lookup s ((re, func):ds)
= case matchRegex re s of
Just fields -> func m fields
@ -124,16 +142,30 @@ handleDirective m s = lookup s directives
-- that matches, then uses the corresponding function.
directives :: [(Regex, DirectiveFunc)]
directives =
[ (mkRegex "^INCLUDE \"(.*)\"$", handleInclude)
, (mkRegex "^USE \"(.*)\"$", handleUse)
, (mkRegex "^COMMENT .*$", (\_ _ -> return id))
[ (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, id)
-- | 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]
= do toks <- preprocessFile m incName
return (\ts -> toks ++ ts)
return (return, \ts -> toks ++ ts)
-- | Handle the @#USE@ directive.
-- This is a bit of a hack at the moment, since it just includes the file
@ -144,7 +176,7 @@ handleUse m [modName]
cs <- get
put $ cs { csUsedFiles = Set.insert incName (csUsedFiles cs) }
if Set.member incName (csUsedFiles cs)
then return id
then return (return, id)
else handleInclude m [incName]
where
-- | If a module name doesn't already have a suffix, add one.
@ -153,6 +185,123 @@ handleUse m [modName]
= if ".occ" `isSuffixOf` mod || ".inc" `isSuffixOf` mod
then mod
else mod ++ ".occ"
-- | Handle the @#DEFINE@ directive.
handleDefine :: DirectiveFunc
handleDefine m [definition]
= do (var, value) <- lookup definition definitionTypes
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, id)
where
definitionTypes :: [(Regex, [String] -> (String, PreprocDef))]
definitionTypes =
[ (mkRegex "^([^ ]+)$", (\[name] -> (name, PreprocNothing)))
, (mkRegex "^([^ ]+) +([0-9]+)$", (\[name, num] -> (name, PreprocInt num)))
, (mkRegex "^([^ ]+) \"(.*)\"$", (\[name, str] -> (name, PreprocString str)))
]
lookup s [] = dieP m "Invalid definition syntax"
lookup s ((re, func):ds)
= case matchRegex re s of
Just fields -> return $ func fields
Nothing -> lookup s ds
-- | Handle the @#UNDEF@ directive.
handleUndef :: DirectiveFunc
handleUndef m [var]
= do modify $ \st -> st { csDefinitions = Map.delete var $ csDefinitions st }
return (return, id)
-- | Handle the @#IF@ directive.
handleIf :: DirectiveFunc
handleIf m [condition]
= do b <- evalExpression m condition
return (skipCondition b 0, id)
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 (t1@(_, TokPreprocessor pp) : t2@(_, EndOfLine) : ts)
| "#IF" `isPrefixOf` pp = skipCondition b 1 ts >>* (\ts -> t1 : t2 : ts)
| "#ELSE" `isPrefixOf` pp = skipCondition (not b) 0 ts
| "#ENDIF" `isPrefixOf` pp = return ts
| otherwise = copyThrough b 0 ((t1 :) . (t2 :)) ts
-- At higher levels, we just count up and down on IF and ENDIF.
skipCondition b n (t1@(_, TokPreprocessor pp) : t2@(_, EndOfLine) : ts)
| "#IF" `isPrefixOf` pp = skipCondition b (n + 1) ts >>* (\ts -> t1 : t2 : ts)
| "#ENDIF" `isPrefixOf` pp = skipCondition b (n - 1) ts >>* (\ts -> t1 : t2 : ts)
| otherwise = copyThrough b n ((t1 :) . (t2 :)) 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]) -> [Token] -> PassM [Token]
copyThrough True n f ts = skipCondition True n ts >>* f
copyThrough False n _ ts = skipCondition False n ts
--}}}
--{{{ parser for preprocessor expressions
type PreprocParser = GenParser Char (Map.Map String PreprocDef)
--{{{ lexer
ppLexer :: P.TokenParser (Map.Map String PreprocDef)
ppLexer = P.makeTokenParser (haskellDef
{ P.identStart = letter <|> digit
, P.identLetter = letter <|> digit <|> char '.'
})
parens :: PreprocParser a -> PreprocParser a
parens = P.parens ppLexer
symbol :: String -> PreprocParser String
symbol = P.symbol ppLexer
--}}}
tryVX :: PreprocParser a -> PreprocParser b -> PreprocParser a
tryVX a b = try (do { av <- a; b; return av })
defined :: PreprocParser Bool
defined
= do symbol "DEFINED"
i <- parens $ P.identifier ppLexer
definitions <- getState
return $ Map.member i definitions
operand :: PreprocParser Bool
operand
= 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 operand"
expression :: PreprocParser Bool
expression
= do { l <- tryVX operand (symbol "AND"); r <- operand; return $ l && r }
<|> do { l <- tryVX operand (symbol "OR"); r <- operand; return $ l || r }
<|> operand
<?> "preprocessor expression"
fullExpression :: PreprocParser Bool
fullExpression
= do P.whiteSpace ppLexer
e <- expression
eof
return e
-- | Evaluate a preprocessor expression.
evalExpression :: Meta -> String -> PassM Bool
evalExpression m s
= do st <- get
case runParser fullExpression (csDefinitions st) (show m) s of
Left err -> dieP m $ "Error parsing expression: " ++ show err
Right b -> return b
--}}}
-- | Load and preprocess an occam program.

176
frontends/PreprocessOccamTest.hs Normal file
View File

@ -0,0 +1,176 @@
{-
Tock: a compiler for parallel languages
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/>.
-}
-- | Tests for the occam preprocessor.
module PreprocessOccamTest (tests) where
import Test.HUnit
import LexOccam
import Metadata
import PreprocessOccam
import TestUtils
-- | Test 'preprocessOccam' when we're expecting it to succeed.
testPP :: Int -> [TokenType] -> [TokenType] -> Test
testPP n itts etts = TestCase $ testPass ("testPP " ++ show n) (makeTokens etts) pass (return ())
where
makeTokens = zip (repeat emptyMeta)
pass = preprocessOccam (makeTokens itts)
-- | Test a preprocessor condition string after a series of tokens.
testPPCondAfter :: Int -> [TokenType] -> String -> Bool -> Test
testPPCondAfter n tts condition exp
= testPP n (tts ++ [TokPreprocessor $ "#IF " ++ condition, EndOfLine,
TokIdentifier "abc",
TokPreprocessor $ "#ENDIF", EndOfLine])
(if exp then [TokIdentifier "abc"] else [])
-- | Test a preprocessor condition string.
testPPCond :: Int -> String -> Bool -> Test
testPPCond n = testPPCondAfter n []
-- | Test 'preprocessOccam' when we're expecting it to fail.
testPPFail :: Int -> [TokenType] -> Test
testPPFail n itts = TestCase $ testPassShouldFail ("testPPFail " ++ show n) pass (return ())
where
makeTokens = zip (repeat emptyMeta)
pass = preprocessOccam (makeTokens itts)
--{{{ 0xxx simple stuff
testSimple :: Test
testSimple = TestLabel "testSimple" $ TestList
[ testPP 0 [] []
, testPP 10 [tp "#COMMENT blah", eol] []
, testPP 20 arbitrary arbitrary
, testPPFail 900 [tp "#INCLUDE \"this-should-not-exist.inc\"", eol]
]
where
tp = TokPreprocessor
eol = EndOfLine
arbitrary = [Indent, Outdent, EndOfLine, TokReserved "blah", TokIdentifier "bleh"]
--}}}
--{{{ 1xxx #IF/#ELSE/#ENDIF
testIf :: Test
testIf = TestLabel "testIf" $ TestList
-- Simple conditionals
[ testPP 1000 [tp "#IF TRUE", eol, ti "abc", tp "#ENDIF", eol] [ti "abc"]
, testPP 1010 [tp "#IF FALSE", eol, ti "abc", tp "#ENDIF", eol] []
, testPP 1020 [tp "#IF TRUE", eol, ti "abc", tp "#ELSE", eol, ti "def", tp "#ENDIF", eol] [ti "abc"]
, testPP 1030 [tp "#IF FALSE", eol, ti "abc", tp "#ELSE", eol, ti "def", tp "#ENDIF", eol] [ti "def"]
, testPP 1040 [tp "#IF FALSE", eol, tp "#INCLUDE \"does-not-exist.inc\"", eol, tp "#ENDIF", eol] []
-- Nested conditionals
, testPP 1100 [tp "#IF FALSE", eol, tp "#IF FALSE", eol, ti "abc", tp "#ENDIF", eol, tp "#ENDIF", eol] []
, testPP 1110 [tp "#IF FALSE", eol, tp "#IF TRUE", eol, ti "abc", tp "#ENDIF", eol, tp "#ENDIF", eol] []
, testPP 1120 [tp "#IF TRUE", eol, tp "#IF FALSE", eol, ti "abc", tp "#ENDIF", eol, tp "#ENDIF", eol] []
, testPP 1130 [tp "#IF TRUE", eol, tp "#IF TRUE", eol, ti "abc", tp "#ENDIF", eol, tp "#ENDIF", eol] [ti "abc"]
, testPP 1140 [tp "#IF FALSE", eol,
tp "#IF FALSE", eol, ti "abc", tp "#ELSE", eol, ti "def", tp "#ENDIF", eol,
tp "#ELSE", eol,
ti "ghi",
tp "#ENDIF", eol] [ti "ghi"]
, testPP 1150 [tp "#IF FALSE", eol,
tp "#IF TRUE", eol, ti "abc", tp "#ELSE", eol, ti "def", tp "#ENDIF", eol,
tp "#ELSE", eol,
ti "ghi",
tp "#ENDIF", eol] [ti "ghi"]
, testPP 1160 [tp "#IF TRUE", eol,
tp "#IF FALSE", eol, ti "abc", tp "#ELSE", eol, ti "def", tp "#ENDIF", eol,
tp "#ELSE", eol,
ti "ghi",
tp "#ENDIF", eol] [ti "def"]
, testPP 1170 [tp "#IF TRUE", eol,
tp "#IF TRUE", eol, ti "abc", tp "#ELSE", eol, ti "def", tp "#ENDIF", eol,
tp "#ELSE", eol,
ti "ghi",
tp "#ENDIF", eol] [ti "abc"]
-- Expressions
, testPPCond 1200 "FALSE AND FALSE" False
, testPPCond 1210 "FALSE AND TRUE" False
, testPPCond 1220 "TRUE AND FALSE" False
, testPPCond 1230 "TRUE AND TRUE" True
, testPPCond 1240 "FALSE OR FALSE" False
, testPPCond 1250 "FALSE OR TRUE" True
, testPPCond 1260 "NOT FALSE" True
, testPPCond 1270 "NOT TRUE" False
, testPPCond 1280 "(TRUE AND FALSE) OR (FALSE AND TRUE)" False
, testPPCond 1290 "(TRUE OR FALSE) AND (FALSE OR TRUE)" True
, testPPCond 1300 "NOT (FALSE AND TRUE)" True
-- Invalid conditionals
, testPPFail 1900 [tp "#IF you can keep your head when all about you...", eol]
, testPPFail 1910 [tp "#IF TRUE", eol]
, testPPFail 1920 [tp "#IF TRUE love comes but once in a lifetime...", eol]
, testPPFail 1930 [tp "#IF TRUE", eol, tp "#IF FALSE", eol, tp "#ENDIF", eol]
, testPPFail 1940 [tp "#IF (TRUE", eol, tp "#ENDIF", eol]
, testPPFail 1950 [tp "#ELSE", eol]
, testPPFail 1960 [tp "#ENDIF", eol]
]
where
ti = TokIdentifier
tp = TokPreprocessor
eol = EndOfLine
--}}}
--{{{ 2xxx #DEFINE/#UNDEF/##
testDefine :: Test
testDefine = TestLabel "testDefine" $ TestList
-- Basic defining
[ testPP 2000 [tp "#DEFINE FOO", eol] []
, testPP 2010 [tp "#DEFINE FOO \"bar\"", eol] []
, testPP 2020 [tp "#DEFINE FOO 42", eol] []
, testPP 2030 [tp "#UNDEF BAR", eol] []
, testPP 2040 [tp "#DEFINE FOO", eol, tp "#UNDEF FOO", eol] []
-- DEFINED
, testPPCondAfter 2100 [tp "#DEFINE FOO", eol] "DEFINED (FOO)" True
, testPPCondAfter 2110 [tp "#UNDEF FOO", eol] "DEFINED (FOO)" False
, testPPCondAfter 2120 [tp "#DEFINE FOO", eol, tp "#UNDEF FOO", eol]
"DEFINED (FOO)" False
, testPPCondAfter 2130 [tp "#UNDEF FOO", eol, tp "#DEFINE FOO", eol]
"DEFINED (FOO)" True
, testPPCond 2140 "DEFINED (COMPILER.TOCK)" True
, testPPCond 2150 "NOT DEFINED (COMPILER.TOCK)" False
-- Expansion
, testPP 2200 [tp "#DEFINE FOO \"bar\"", eol, hh, ti "FOO"] [TokStringLiteral "bar"]
, testPP 2210 [tp "#DEFINE FOO 1234", eol, hh, ti "FOO"] [TokIntLiteral "1234"]
-- Invalid definitions
, testPPFail 2900 [tp "#DEFINE FOO", eol, tp "#DEFINE FOO", eol]
, testPPFail 2910 [tp "#DEFINE FOO !!*!%*!", eol]
-- Invalid expansions
, testPPFail 2950 [tp "#DEFINE FOO", eol, hh, ti "FOO"]
, testPPFail 2960 [hh, ti "FOO"]
, testPPFail 2970 [hh, hh]
]
where
tp = TokPreprocessor
ti = TokIdentifier
hh = TokReserved "##"
eol = EndOfLine
--}}}
tests :: Test
tests = TestLabel "PreprocessOccamTest" $ TestList
[ testSimple
, testIf
, testDefine
]