Implement comparisons in preprocessor expressions.

This brings Tock's conditional compilation facilities up to par with occ21.

frontends/PreprocessOccam.hs

@@ -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 }
+    =   (lexeme $ do { ds <- many1 digit; return $ PreprocInt ds })
-    <|> do { char '"'; s <- manyTill anyChar $ char '"'; return $ PreprocString s }
+    <|> (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
+simpleExpression :: PreprocParser Bool
-operand
+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 simpleExpression (symbol "AND"); r <- simpleExpression; return $ l && r }
-    <|> do { l <- tryVX operand (symbol "OR"); r <- operand; return $ l || r }
+    <|> do { l <- tryVX simpleExpression (symbol "OR"); r <- simpleExpression; return $ l || r }
-    <|> operand
+    <|> do { (l, op) <- tryVV operand comparisonOp; r <- operand; applyComparison op l r }
-    <?> "preprocessor expression"
+    <|> simpleExpression
+    <?> "preprocessor complex expression"
 
 -- | Match a 'PreprocParser' production.
 runPreprocParser :: Meta -> PreprocParser a -> String -> PassM a

frontends/PreprocessOccamTest.hs

@@ -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 2600 [tp "#DEFINE FOO \"bar\"", eol, hh, ti "FOO"] [TokStringLiteral "bar"]
-  , testPP 2210 [tp "#DEFINE FOO 1234", eol, hh, ti "FOO"] [TokIntLiteral "1234"]
+  , testPP 2610 [tp "#DEFINE FOO 1234", eol, hh, ti "FOO"] [TokIntLiteral "1234"]
 
   -- Invalid definitions
   , testPPFail 2900 [tp "#DEFINE FOO", eol, tp "#DEFINE FOO", eol]