Split the literal evaluator into a new module, and make type subscripting smarter

fco2/EvalConstants.hs

@@ -1,5 +1,5 @@
 -- | Evaluate constant expressions.
-module EvalConstants (constantFold, isConstantName, evalIntExpression) where
+module EvalConstants (constantFold, isConstantName) where
 
 import Control.Monad.Error
 import Control.Monad.Identity
@@ -12,6 +12,7 @@ import Numeric
 
 import qualified AST as A
 import Errors
+import EvalLiterals
 import Metadata
 import ParseState
 import Pass
@@ -27,20 +28,6 @@ constantFold e
                             Right val -> (val, "already folded")
           return (e', isConstant e', msg)
 
--- | Is an expression a constant literal?
-isConstant :: A.Expression -> Bool
-isConstant (A.ExprLiteral _ (A.Literal _ _ (A.ArrayLiteral _ aes)))
-    = and $ map isConstantArray aes
-isConstant (A.ExprLiteral _ _) = True
-isConstant (A.True _) = True
-isConstant (A.False _) = True
-isConstant _ = False
-
--- | Is an array literal element constant?
-isConstantArray :: A.ArrayElem -> Bool
-isConstantArray (A.ArrayElemArray aes) = and $ map isConstantArray aes
-isConstantArray (A.ArrayElemExpr e) = isConstant e
-
 -- | Is a name defined as a constant expression? If so, return its definition.
 getConstantName :: (PSM m, Die m) => A.Name -> m (Maybe A.Expression)
 getConstantName n
@@ -59,53 +46,19 @@ isConstantName n
                      Just _ -> True
                      Nothing -> False
 
--- | Evaluate a constant integer expression.
-evalIntExpression :: (PSM m, Die m) => A.Expression -> m Int
-evalIntExpression e
-    =  do ps <- get
-          case runEvaluator ps e of
-            Left err -> die $ "cannot evaluate expression: " ++ err
-            Right (OccInt val) -> return $ fromIntegral val
-            Right _ -> die "expression is not of INT type"
-
 -- | Attempt to simplify an expression as far as possible by precomputing
 -- constant bits.
 simplifyExpression :: ParseState -> A.Expression -> Either String A.Expression
 simplifyExpression ps e
-    = case runEvaluator ps e of
+    = case runEvaluator ps (evalExpression e) of
         Left err -> Left err
         Right val -> Right $ snd $ renderValue (metaOfExpression e) val
 
--- | Run the expression evaluator.
-runEvaluator :: ParseState -> A.Expression -> Either String OccValue
-runEvaluator ps e
-    = runIdentity (evalStateT (runErrorT (evalExpression e)) ps)
-
 --{{{  expression evaluator
-type EvalM = ErrorT String (StateT ParseState Identity)
-
-instance Die EvalM where
-  die = throwError
-
--- | Occam values of various types.
-data OccValue =
-  OccBool Bool
-  | OccInt Int32
-  | OccArray [OccValue]
-  deriving (Show, Eq, Typeable, Data)
-
--- | Turn the result of one of the read* functions into an OccValue,
--- or throw an error if it didn't parse.
-fromRead :: (t -> OccValue) -> [(t, String)] -> EvalM OccValue
-fromRead cons [(v, "")] = return $ cons v
-fromRead _ _ = throwError "cannot parse literal"
-
 evalLiteral :: A.Literal -> EvalM OccValue
-evalLiteral (A.Literal _ A.Int (A.IntLiteral _ s)) = fromRead OccInt $ readDec s
-evalLiteral (A.Literal _ A.Int (A.HexLiteral _ s)) = fromRead OccInt $ readHex s
 evalLiteral (A.Literal _ _ (A.ArrayLiteral _ aes))
     = liftM OccArray (mapM evalLiteralArray aes)
-evalLiteral _ = throwError "bad literal"
+evalLiteral l = evalSimpleLiteral l
 
 evalLiteralArray :: A.ArrayElem -> EvalM OccValue
 evalLiteralArray (A.ArrayElemArray aes) = liftM OccArray (mapM evalLiteralArray aes)

fco2/EvalLiterals.hs

@@ -0,0 +1,73 @@
+-- | Evaluate simple literal expressions.
+module EvalLiterals where
+
+import Control.Monad.Error
+import Control.Monad.Identity
+import Control.Monad.State
+import Data.Bits
+import Data.Generics
+import Data.Int
+import Data.Maybe
+import Numeric
+
+import qualified AST as A
+import Errors
+import ParseState
+
+type EvalM = ErrorT String (StateT ParseState Identity)
+
+instance Die EvalM where
+  die = throwError
+
+-- | Occam values of various types.
+data OccValue =
+  OccBool Bool
+  | OccInt Int32
+  | OccArray [OccValue]
+  deriving (Show, Eq, Typeable, Data)
+
+-- | Is an expression a constant literal?
+isConstant :: A.Expression -> Bool
+isConstant (A.ExprLiteral _ (A.Literal _ _ (A.ArrayLiteral _ aes)))
+    = and $ map isConstantArray aes
+isConstant (A.ExprLiteral _ _) = True
+isConstant (A.True _) = True
+isConstant (A.False _) = True
+isConstant _ = False
+
+-- | Is an array literal element constant?
+isConstantArray :: A.ArrayElem -> Bool
+isConstantArray (A.ArrayElemArray aes) = and $ map isConstantArray aes
+isConstantArray (A.ArrayElemExpr e) = isConstant e
+
+-- | Evaluate a constant integer expression.
+evalIntExpression :: (PSM m, Die m) => A.Expression -> m Int
+evalIntExpression e
+    =  do ps <- get
+          case runEvaluator ps (evalSimpleExpression e) of
+            Left err -> die $ "cannot evaluate expression: " ++ err
+            Right (OccInt val) -> return $ fromIntegral val
+            Right _ -> die "expression is not of INT type"
+
+-- | Run an evaluator operation.
+runEvaluator :: ParseState -> EvalM OccValue -> Either String OccValue
+runEvaluator ps func
+    = runIdentity (evalStateT (runErrorT func) ps)
+
+-- | Evaluate a simple literal expression.
+evalSimpleExpression :: A.Expression -> EvalM OccValue
+evalSimpleExpression (A.ExprLiteral _ l) = evalSimpleLiteral l
+evalSimpleExpression _ = throwError "not a literal"
+
+-- | Turn the result of one of the read* functions into an OccValue,
+-- or throw an error if it didn't parse.
+fromRead :: (t -> OccValue) -> [(t, String)] -> EvalM OccValue
+fromRead cons [(v, "")] = return $ cons v
+fromRead _ _ = throwError "cannot parse literal"
+
+-- | Evaluate a simple (non-array) literal.
+evalSimpleLiteral :: A.Literal -> EvalM OccValue
+evalSimpleLiteral (A.Literal _ A.Int (A.IntLiteral _ s)) = fromRead OccInt $ readDec s
+evalSimpleLiteral (A.Literal _ A.Int (A.HexLiteral _ s)) = fromRead OccInt $ readHex s
+evalSimpleLiteral _ = throwError "bad literal"
+

fco2/Makefile

@@ -6,6 +6,7 @@ sources = \
 	AST.hs \
 	Errors.hs \
 	EvalConstants.hs \
+	EvalLiterals.hs \
 	GenerateC.hs \
 	Indentation.hs \
 	Main.hs \

fco2/Parse.hs

@@ -16,6 +16,7 @@ import Text.Regex
 import qualified AST as A
 import Errors
 import EvalConstants
+import EvalLiterals
 import Indentation
 import Metadata
 import ParseState

fco2/TODO

@@ -45,6 +45,7 @@ Pulling up won't work correctly for things like:
 This will require some thought (and probably some AST changes to insert an
 artifical place to pull up to -- perhaps just a more flexible Specification
 type).
+How about having a slot for "process, then" in Structured?
 
 Before code generation, have a pass that resolves all the DATA TYPE .. IS
 directives to their real types.

fco2/Types.hs

@@ -10,6 +10,7 @@ import Data.Maybe
 
 import qualified AST as A
 import Errors
+import EvalLiterals
 import ParseState
 import Metadata
 
@@ -34,6 +35,28 @@ typeOfName n
             _ -> die $ "cannot type name " ++ show st
 
 --{{{  identifying types
+-- | Apply a slice to a type.
+sliceType :: (PSM m, Die m) => A.Expression -> A.Expression -> A.Type -> m A.Type
+sliceType base count (A.Array (d:ds) t)
+    = case (isConstant base, isConstant count) of
+        (True, True) ->
+          do b <- evalIntExpression base
+             c <- evalIntExpression count
+             case d of
+               A.Dimension size ->
+                 if (size - b) < c
+                   then die "invalid slice"
+                   else return $ A.Array (A.Dimension c : ds) t
+               A.UnknownDimension ->
+                 return $ A.Array (A.Dimension c : ds) t
+        (True, False) -> return $ A.Array (A.UnknownDimension : ds) t
+        (False, True) ->
+          do c <- evalIntExpression count
+             return $ A.Array (A.Dimension c : ds) t
+        (False, False) -> return $ A.Array (A.UnknownDimension : ds) t
+sliceType _ _ _ = die "slice of non-array type"
+
+-- | Get the type of a record field.
 typeOfRecordField :: (PSM m, Die m) => A.Type -> A.Name -> m A.Type
 typeOfRecordField (A.UserDataType rec) field
     =  do st <- specTypeOfName rec
@@ -42,16 +65,39 @@ typeOfRecordField (A.UserDataType rec) field
             _ -> die "not record type"
 typeOfRecordField _ _ = die "not record type"
 
+-- | Apply a plain subscript to a type.
+plainSubscriptType :: (PSM m, Die m) => A.Expression -> A.Type -> m A.Type
+plainSubscriptType sub (A.Array (d:ds) t)
+    = case (isConstant sub, d) of
+        (True, A.Dimension size) ->
+          do i <- evalIntExpression sub
+             if (i < 0) || (i >= size)
+               then die "invalid subscript"
+               else return ok
+        _ -> return ok
+  where
+    ok = case ds of
+           [] -> t
+           _ -> A.Array ds t
+plainSubscriptType _ _ = die "subscript of non-array type"
+
 -- | Apply a subscript to a type, and return what the type is after it's been
 -- subscripted.
--- FIXME This needs to replace the first dimension in array types.
 subscriptType :: (PSM m, Die m) => A.Subscript -> A.Type -> m A.Type
-subscriptType (A.SubscriptFromFor _ _ _) t = return t
-subscriptType (A.SubscriptFrom _ _) t = return t
-subscriptType (A.SubscriptFor _ _) t = return t
+subscriptType (A.SubscriptFromFor _ base count) t
+    = sliceType base count t
+subscriptType (A.SubscriptFrom _ base) (A.Array (d:ds) t)
+    = case (isConstant base, d) of
+        (True, A.Dimension size) ->
+          do b <- evalIntExpression base
+             if (size - b) < 0
+               then die "invalid slice"
+               else return $ A.Array (A.Dimension (size - b) : ds) t
+        _ -> return $ A.Array (A.UnknownDimension : ds) t
+subscriptType (A.SubscriptFor _ count) t
+    = sliceType (makeConstant emptyMeta 0) count t
 subscriptType (A.SubscriptField _ tag) t = typeOfRecordField t tag
-subscriptType (A.Subscript _ _) (A.Array [_] t) = return t
-subscriptType (A.Subscript _ _) (A.Array (_:ds) t) = return $ A.Array ds t
+subscriptType (A.Subscript _ sub) t = plainSubscriptType sub t
 subscriptType _ _ = die "unsubscriptable type"
 
 typeOfVariable :: (PSM m, Die m) => A.Variable -> m A.Type