Move constant checking from the occam parser into a pass.

The parser now doesn't do any constant folding or checking.

frontends/OccamPasses.hs

@@ -17,15 +17,19 @@ with this program.  If not, see <http://www.gnu.org/licenses/>.
 -}
 
 -- | The occam-specific frontend passes.
-module OccamPasses (occamPasses, foldConstants) where
+module OccamPasses (occamPasses, foldConstants, checkConstants) where
 
+import Control.Monad
 import Data.Generics
 
 import qualified AST as A
 import CompState
 import EvalConstants
+import EvalLiterals
+import Metadata
 import Pass
 import qualified Properties as Prop
+import ShowCode
 
 -- | Occam-specific frontend passes.
 occamPasses :: [Pass]
@@ -33,6 +37,9 @@ occamPasses = makePassesDep' ((== FrontendOccam) . csFrontend)
     [ ("Fold constants", foldConstants,
        [],
        [Prop.constantsFolded])
+    , ("Check mandatory constants", checkConstants,
+       [Prop.constantsFolded],
+       [Prop.constantsChecked])
     , ("Dummy occam pass", dummyOccamPass,
        [],
        Prop.agg_namesDone ++ [Prop.expressionTypesChecked,
@@ -66,6 +73,30 @@ foldConstants = doGeneric `extM` doSpecification `extM` doExpression
               (e'', _, _) <- constantFold e'
               return e''
 
+-- | Check that things that must be constant are.
+checkConstants :: Data t => t -> PassM t
+checkConstants = doGeneric `extM` doDimension `extM` doOption
+  where
+    doGeneric :: Data t => t -> PassM t
+    doGeneric = makeGeneric checkConstants
+
+    -- Check array dimensions are constant.
+    doDimension :: A.Dimension -> PassM A.Dimension
+    doDimension d@(A.Dimension e)
+        =  do when (not $ isConstant e) $
+                diePC (findMeta e) $ formatCode "Array dimension must be constant: %" e
+              doGeneric d
+    doDimension d = doGeneric d
+
+    -- Check case options are constant.
+    doOption :: A.Option -> PassM A.Option
+    doOption o@(A.Option _ es _)
+        =  do sequence_ [when (not $ isConstant e) $
+                           diePC (findMeta e) $ formatCode "Case option must be constant: %" e
+                         | e <- es]
+              doGeneric o
+    doOption o = doGeneric o
+
 -- | A dummy pass for things that haven't been separated out into passes yet.
 dummyOccamPass :: Data t => t -> PassM t
 dummyOccamPass = return

frontends/OccamPassesTest.hs

@@ -108,7 +108,58 @@ testFoldConstants = TestList
     four = intLiteral 4
     six = intLiteral 6
 
+-- | Test 'OccamPasses.checkConstants'.
+testCheckConstants :: Test
+testCheckConstants = TestList
+    [
+    -- Valid dimensions in array types
+      testOK 0 (A.Int)
+    , testOK 1 (A.Array [dim10] A.Int)
+    , testOK 2 (A.Array [dimU] A.Int)
+    , testOK 3 (A.Array [dim10, dim10] A.Int)
+    , testOK 4 (A.Array [dim10, dimU] A.Int)
+
+    -- Invalid dimensions in array types
+    , testFail 10 (A.Array [dimVar] A.Int)
+    , testFail 11 (A.Array [dimVar, dimVar] A.Int)
+    , testFail 12 (A.Array [dim10, dimVar] A.Int)
+    , testFail 13 (A.Array [dimU, dimVar] A.Int)
+    , testFail 14 (A.Array [dim10, dim10, dimU, dimU, dimVar] A.Int)
+
+    -- Valid Case options
+    , testOK 20 (A.Option m [lit10] skip)
+    , testOK 21 (A.Option m [lit10, lit10] skip)
+    , testOK 22 (A.Option m [lit10, lit10, lit10] skip)
+
+    -- Invalid Case options
+    , testFail 30 (A.Option m [var] skip)
+    , testFail 31 (A.Option m [lit10, var] skip)
+    , testFail 32 (A.Option m [var, lit10] skip)
+    , testFail 33 (A.Option m [lit10, lit10, lit10, var] skip)
+    ]
+  where
+    testOK :: (Show a, Data a) => Int -> a -> Test
+    testOK n orig
+        = TestCase $ testPass ("testCheckConstants" ++ show n)
+                              orig (OccamPasses.checkConstants orig)
+                              (return ())
+
+    testFail :: (Show a, Data a) => Int -> a -> Test
+    testFail n orig
+        = TestCase $ testPassShouldFail ("testCheckConstants" ++ show n)
+                                        (OccamPasses.checkConstants orig)
+                                        (return ())
+
+    dim10 = A.Dimension $ intLiteral 10
+    dimU = A.UnknownDimension
+    dimVar = A.Dimension $ exprVariable "var"
+
+    lit10 = intLiteral 10
+    var = exprVariable "var"
+    skip = A.Skip m
+
 tests :: Test
 tests = TestLabel "OccamPassesTest" $ TestList
     [ testFoldConstants
+    , testCheckConstants
     ]

frontends/ParseOccam.hs

@@ -29,7 +29,6 @@ import Text.ParserCombinators.Parsec
 import qualified AST as A
 import CompState
 import Errors
-import EvalConstants
 import EvalLiterals
 import Intrinsics
 import LexOccam
@@ -596,7 +595,7 @@ newTagName = unscopedName A.TagName
 -- | A sized array of a production.
 arrayType :: OccParser A.Type -> OccParser A.Type
 arrayType element
-    =  do (s, t) <- tryXVXV sLeft constIntExpr sRight element
+    =  do (s, t) <- tryXVXV sLeft intExpr sRight element
           return $ addDimensions [A.Dimension s] t
 
 -- | Either a sized or unsized array of a production.
@@ -832,12 +831,9 @@ tableElems
            return (lr, A.Array [dim] A.Byte)
     <|> do m <- md
            es <- tryXVX sLeft (noTypeContext $ sepBy1 expression sComma) sRight
-           -- Constant fold early, so that tables have a better chance of
+           ets <- mapM typeOfExpression es
-           -- becoming constants.
-           (es', _, _) <- liftM unzip3 $ sequence [constantFold e | e <- es]
-           ets <- mapM typeOfExpression es'
            defT <- tableType m ets
-           return (A.ArrayLiteral m (map A.ArrayElemExpr es'), defT)
+           return (A.ArrayLiteral m (map A.ArrayElemExpr es), defT)
     <?> "table elements"
 
 stringLiteral :: OccParser (A.LiteralRepr, A.Dimension)
@@ -978,17 +974,6 @@ intExpr = expressionOfType A.Int <?> "integer expression"
 booleanExpr :: OccParser A.Expression
 booleanExpr = expressionOfType A.Bool <?> "boolean expression"
 
-constExprOfType :: A.Type -> OccParser A.Expression
-constExprOfType wantT
-    =  do e <- expressionOfType wantT
-          (e', isConst, (m,msg)) <- constantFold e
-          when (not isConst) $
-            dieReport (m,"expression is not constant (" ++ msg ++ ")")
-          return e'
-
-constIntExpr :: OccParser A.Expression
-constIntExpr = constExprOfType A.Int <?> "constant integer expression"
-
 operandOfType :: A.Type -> OccParser A.Expression
 operandOfType wantT
     =  do o <- inTypeContext (Just wantT) operand
@@ -1328,10 +1313,7 @@ valIsAbbrev
     =  do m <- md
           (n, t, e) <- do { n <- tryXVX sVAL newVariableName sIS; e <- expression; sColon; eol; t <- typeOfExpression e; return (n, t, e) }
                        <|> do { (s, n) <- tryXVVX sVAL dataSpecifier newVariableName sIS; e <- expressionOfType s; sColon; eol; return (n, s, e) }
-          -- Do constant folding early, so that we can use names defined this
+          return $ A.Specification m n $ A.IsExpr m A.ValAbbrev t e
-          -- way as constants elsewhere.
-          (e', _, _) <- constantFold e
-          return $ A.Specification m n $ A.IsExpr m A.ValAbbrev t e'
     <?> "VAL IS abbreviation"
 
 initialIsAbbrev :: OccParser A.Specification
@@ -1857,7 +1839,7 @@ caseProcess
 caseOption :: A.Type -> OccParser (A.Structured A.Option)
 caseOption t
     =   do m <- md
-           ces <- tryVX (sepBy (constExprOfType t) sComma) eol
+           ces <- tryVX (sepBy (expressionOfType t) sComma) eol
            indent
            p <- process
            outdent

frontends/RainPasses.hs

@@ -45,7 +45,7 @@ rainPasses = makePassesDep' ((== FrontendRain) . csFrontend)
        ,("Uniquify variable declarations, record declared types and resolve variable names",
            uniquifyAndResolveVars, [Prop.noInt], namesDone)
             
-       ,("Fold all constant expressions", constantFoldPass, [Prop.noInt] ++ namesDone, [Prop.constantsFolded])
+       ,("Fold all constant expressions", constantFoldPass, [Prop.noInt] ++ namesDone, [Prop.constantsFolded, Prop.constantsChecked])
        ,("Annotate integer literal types", annnotateIntLiteralTypes, [Prop.noInt] ++ namesDone, [Prop.intLiteralsInBounds])
        
        ,("Record inferred name types in dictionary", recordInfNameTypes, namesDone ++ [Prop.intLiteralsInBounds], [Prop.inferredTypesRecorded])

pass/Properties.hs

@@ -26,6 +26,7 @@ module Properties
   , arraySizesDeclared
   , assignFlattened
   , assignParRemoved
+  , constantsChecked
   , constantsFolded
   , declarationsUnique
   , declarationTypesRecorded
@@ -80,7 +81,7 @@ agg_namesDone :: [Property]
 agg_namesDone = [declarationsUnique, declarationTypesRecorded, inferredTypesRecorded, declaredNamesResolved]
 
 agg_typesDone :: [Property]
-agg_typesDone = [expressionTypesChecked, inferredTypesRecorded, processTypesChecked, typesResolvedInAST, typesResolvedInState, constantsFolded]
+agg_typesDone = [expressionTypesChecked, inferredTypesRecorded, processTypesChecked, typesResolvedInAST, typesResolvedInState, constantsFolded, constantsChecked]
 
 agg_functionsGone :: [Property]
 agg_functionsGone = [functionCallsRemoved, functionsRemoved]
@@ -140,6 +141,9 @@ declarationsUnique = Property "declarationsUnique" $
              dieP (A.nameMeta n) $ "Duplicate definition of name (names not uniquified successfully?) " ++ show (A.nameName n) ++ " with: " ++ show (A.nameMeta n')
            checkDupes (n':ns)
 
+constantsChecked :: Property
+constantsChecked = Property "constantsChecked" checkTODO
+
 constantsFolded :: Property
 constantsFolded = Property "constantsFolded" checkTODO
 

testcases/_bad_arraysize.occ

@@ -0,0 +1,7 @@
+PROC p ()
+  INT x:
+  SEQ
+    x := 42
+    [x]INT blah:
+    SKIP
+:

testcases/_bad_option.occ

@@ -0,0 +1,10 @@
+PROC p ()
+  INT x, y:
+  SEQ
+    x, y := 42, 43
+    CASE x
+      12
+        SKIP
+      y
+        SKIP
+: