diff --git a/fco2/EvalConstants.hs b/fco2/EvalConstants.hs index 8e3886f..44f9f52 100644 --- a/fco2/EvalConstants.hs +++ b/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) diff --git a/fco2/EvalLiterals.hs b/fco2/EvalLiterals.hs new file mode 100644 index 0000000..693beb7 --- /dev/null +++ b/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" + diff --git a/fco2/Makefile b/fco2/Makefile index f53d133..d907ac1 100644 --- a/fco2/Makefile +++ b/fco2/Makefile @@ -6,6 +6,7 @@ sources = \ AST.hs \ Errors.hs \ EvalConstants.hs \ + EvalLiterals.hs \ GenerateC.hs \ Indentation.hs \ Main.hs \ diff --git a/fco2/Parse.hs b/fco2/Parse.hs index 45f7f7c..33f1238 100644 --- a/fco2/Parse.hs +++ b/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 diff --git a/fco2/TODO b/fco2/TODO index d2014b0..cb5e1d2 100644 --- a/fco2/TODO +++ b/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. diff --git a/fco2/Types.hs b/fco2/Types.hs index aa2bb4f..e0d739b 100644 --- a/fco2/Types.hs +++ b/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