diff --git a/frontends/OccamPasses.hs b/frontends/OccamPasses.hs index 7269da1..bae4e6a 100644 --- a/frontends/OccamPasses.hs +++ b/frontends/OccamPasses.hs @@ -17,15 +17,19 @@ with this program. If not, see . -} -- | 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 diff --git a/frontends/OccamPassesTest.hs b/frontends/OccamPassesTest.hs index 1fad9a6..7ea5c0a 100644 --- a/frontends/OccamPassesTest.hs +++ b/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 ] diff --git a/frontends/ParseOccam.hs b/frontends/ParseOccam.hs index 582f9c3..e38c14c 100644 --- a/frontends/ParseOccam.hs +++ b/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 - -- becoming constants. - (es', _, _) <- liftM unzip3 $ sequence [constantFold e | e <- es] - ets <- mapM typeOfExpression 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 - -- way as constants elsewhere. - (e', _, _) <- constantFold e - return $ A.Specification m n $ A.IsExpr m A.ValAbbrev t 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 diff --git a/frontends/RainPasses.hs b/frontends/RainPasses.hs index 1e6ffd9..48fe343 100644 --- a/frontends/RainPasses.hs +++ b/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]) diff --git a/pass/Properties.hs b/pass/Properties.hs index 86e0a37..fa51c18 100644 --- a/pass/Properties.hs +++ b/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 diff --git a/testcases/_bad_arraysize.occ b/testcases/_bad_arraysize.occ new file mode 100644 index 0000000..40b4edc --- /dev/null +++ b/testcases/_bad_arraysize.occ @@ -0,0 +1,7 @@ +PROC p () + INT x: + SEQ + x := 42 + [x]INT blah: + SKIP +: diff --git a/testcases/_bad_option.occ b/testcases/_bad_option.occ new file mode 100644 index 0000000..5f44da9 --- /dev/null +++ b/testcases/_bad_option.occ @@ -0,0 +1,10 @@ +PROC p () + INT x, y: + SEQ + x, y := 42, 43 + CASE x + 12 + SKIP + y + SKIP +: