Implement comparisons in preprocessor expressions.
This brings Tock's conditional compilation facilities up to par with occ21.
This commit is contained in:
Adam Sampson
parent
a5fd73130a
commit
c8b6be34e1
|
|
@ -24,6 +24,7 @@ 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)
|
||||
|
|
@ -236,10 +237,14 @@ handleIf m [condition]
|
|||
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
|
||||
|
|
@ -256,15 +261,21 @@ 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
|
||||
= do { ds <- lexeme $ many1 digit; return $ PreprocInt ds }
|
||||
<|> do { char '"'; s <- manyTill anyChar $ char '"'; return $ PreprocString s }
|
||||
= (lexeme $ do { ds <- many1 digit; return $ PreprocInt ds })
|
||||
<|> (lexeme $ do { char '"'; s <- manyTill anyChar $ char '"'; return $ PreprocString s })
|
||||
<?> "preprocessor literal"
|
||||
|
||||
defineDirective :: PreprocParser (String, PreprocDef)
|
||||
|
|
@ -279,25 +290,68 @@ defineDirective
|
|||
defined :: PreprocParser Bool
|
||||
defined
|
||||
= do symbol "DEFINED"
|
||||
i <- parens identifier
|
||||
var <- parens identifier
|
||||
definitions <- getState
|
||||
return $ Map.member i definitions
|
||||
return $ Map.member var definitions
|
||||
|
||||
operand :: PreprocParser Bool
|
||||
operand
|
||||
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 operand (symbol "AND"); r <- operand; return $ l && r }
|
||||
<|> do { l <- tryVX operand (symbol "OR"); r <- operand; return $ l || r }
|
||||
<|> operand
|
||||
<?> "preprocessor 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
|
||||
|
|
|
|||
|
|
@ -113,6 +113,19 @@ testIf = TestLabel "testIf" $ TestList
|
|||
, 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
|
||||
, testPPCond 1310 "3 < 4" True
|
||||
, testPPCond 1320 "3 > 4" False
|
||||
, testPPCond 1330 "3 <> 4" True
|
||||
, testPPCond 1340 "3 = 4" False
|
||||
, testPPCond 1350 "4 <= 4" True
|
||||
, testPPCond 1360 "3 <= 4" True
|
||||
, testPPCond 1370 "4 >= 4" True
|
||||
, testPPCond 1380 "5 >= 4" True
|
||||
, testPPCond 1390 "\"foo\" = \"foo\"" True
|
||||
, testPPCond 1400 "\"foo\" <> \"foo\"" False
|
||||
, testPPCond 1410 "\"foo\" = \"bar\"" False
|
||||
, testPPCond 1420 "\"foo\" <> \"bar\"" True
|
||||
, testPPCond 1430 "((3 > 4) OR (42 = 24)) AND (1 <= 2)" False
|
||||
|
||||
-- Invalid conditionals
|
||||
, testPPFail 1900 [tp "#IF you can keep your head when all about you...", eol]
|
||||
|
|
@ -122,6 +135,8 @@ testIf = TestLabel "testIf" $ TestList
|
|||
, testPPFail 1940 [tp "#IF (TRUE", eol, tp "#ENDIF", eol]
|
||||
, testPPFail 1950 [tp "#ELSE", eol]
|
||||
, testPPFail 1960 [tp "#ENDIF", eol]
|
||||
, testPPFail 1970 [tp "#IF 3 = \"foo\"", eol, tp "#ENDIF", eol]
|
||||
, testPPFail 1980 [tp "#IF \"foo\" > \"bar\"", eol, tp "#ENDIF", eol]
|
||||
]
|
||||
where
|
||||
ti = TokIdentifier
|
||||
|
|
@ -148,9 +163,15 @@ testDefine = TestLabel "testDefine" $ TestList
|
|||
, testPPCond 2140 "DEFINED (COMPILER.TOCK)" True
|
||||
, testPPCond 2150 "NOT DEFINED (COMPILER.TOCK)" False
|
||||
|
||||
-- Conditions involving macros
|
||||
, testPPCondAfter 2200 [tp "#DEFINE FOO 42", eol] "FOO = 42" True
|
||||
, testPPCondAfter 2210 [tp "#DEFINE FOO 42", eol] "FOO <> 42" False
|
||||
, testPPCondAfter 2220 [tp "#DEFINE FOO \"bar\"", eol] "FOO = \"bar\"" True
|
||||
, testPPCondAfter 2230 [tp "#DEFINE FOO \"baz\"", eol] "FOO = \"bar\"" 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"]
|
||||
, testPP 2600 [tp "#DEFINE FOO \"bar\"", eol, hh, ti "FOO"] [TokStringLiteral "bar"]
|
||||
, testPP 2610 [tp "#DEFINE FOO 1234", eol, hh, ti "FOO"] [TokIntLiteral "1234"]
|
||||
|
||||
-- Invalid definitions
|
||||
, testPPFail 2900 [tp "#DEFINE FOO", eol, tp "#DEFINE FOO", eol]
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user