Implement user datatypes

fco2/GenerateC.hs

@@ -828,7 +828,11 @@ abbrevExpression am t@(A.Array _ _) e
 
     genTypeSize :: A.Type -> (A.Name -> CGen ())
     genTypeSize (A.Array ds _)
-        = genArraySize False $ sequence_ $ intersperse genComma [tell [show n] | A.Dimension n <- ds]
+        = genArraySize False $ sequence_ $ intersperse genComma dims
+      where dims = [case d of
+                      A.Dimension n -> tell [show n]
+                      _ -> die "unknown dimension in literal array type"
+                    | d <- ds]
 abbrevExpression am _ e
     = (genExpression e, noSize)
 --}}}
@@ -962,7 +966,7 @@ introduceSpec (A.Specification _ n (A.IsChannelArray _ t cs))
           sequence_ $ intersperse genComma (map genVariable cs)
           tell ["};\n"]
           declareArraySizes [A.Dimension $ length cs] (genName n)
---introduceSpec (A.Specification m n (A.DataType m t))
+introduceSpec (A.Specification _ _ (A.DataType _ _)) = return ()
 introduceSpec (A.Specification _ n (A.RecordType _ b fs))
     =  do tell ["typedef struct {\n"]
           sequence_ [case t of

fco2/Main.hs

@@ -17,11 +17,13 @@ import Pass
 import PrettyShow
 import SimplifyExprs
 import SimplifyProcs
+import SimplifyTypes
 import Unnest
 
 passes :: [(String, Pass)]
 passes =
-  [ ("Simplify expressions", simplifyExprs)
+  [ ("Simplify types", simplifyTypes)
+  , ("Simplify expressions", simplifyExprs)
   , ("Simplify processes", simplifyProcs)
   , ("Flatten nested declarations", unnest)
   ]

fco2/Makefile

@@ -18,6 +18,7 @@ sources = \
 	PrettyShow.hs \
 	SimplifyExprs.hs \
 	SimplifyProcs.hs \
+	SimplifyTypes.hs \
 	TLP.hs \
 	Types.hs \
 	Unnest.hs \

fco2/Parse.hs

@@ -445,12 +445,26 @@ listType m l = listType' m (length l) l
         = if t1 == t2 then listType' m len rest
                       else fail $ "multiple types in list: " ++ show t1 ++ " and " ++ show t2
 
+-- | Check that the second second of dimensions can be used in a context where
+-- the first is expected.
+areValidDimensions :: [A.Dimension] -> [A.Dimension] -> Bool
+areValidDimensions [] [] = True
+areValidDimensions (A.UnknownDimension:ds1) (A.UnknownDimension:ds2)
+    = areValidDimensions ds1 ds2
+areValidDimensions (A.UnknownDimension:ds1) (A.Dimension _:ds2)
+    = areValidDimensions ds1 ds2
+areValidDimensions (A.Dimension n1:ds1) (A.Dimension n2:ds2)
+    =  if n1 /= n2 then False else areValidDimensions ds1 ds2
+areValidDimensions _ _ = False
+
 -- | Check that a type we've inferred matches the type we expected.
 matchType :: A.Type -> A.Type -> OccParser ()
 matchType et rt
     = case (et, rt) of
         ((A.Array ds t), (A.Array ds' t')) ->
-          if length ds == length ds' then return () else bad
+          if areValidDimensions ds ds'
+            then matchType t t'
+            else bad
         _ -> if rt == et then return () else bad
   where
     bad = fail $ "type mismatch (got " ++ show rt ++ "; expected " ++ show et ++ ")"
@@ -653,12 +667,42 @@ portType
     <?> "port type"
 --}}}
 --{{{ literals
-isValidLiteralType :: A.Type -> A.Type -> Bool
-isValidLiteralType defT t
-    = case defT of
-        A.Real32 -> isRealType t
-        A.Int -> isIntegerType t
-        A.Byte -> isIntegerType t
+--{{{ type utilities for literals
+-- | Can a literal of type defT be used for a value type t?
+isValidLiteralType :: A.Type -> A.Type -> OccParser Bool
+isValidLiteralType defT' realT'
+    =  do realT <- underlyingType realT'
+          defT <- underlyingType defT'
+          case (defT, realT) of
+            (A.Real32, _) -> return $ isRealType realT
+            (A.Int, _) -> return $ isIntegerType realT
+            (A.Byte, _) -> return $ isIntegerType realT
+            (A.Array ds1 t1, A.Array ds2 t2) ->
+              if areValidDimensions ds2 ds1
+                then isValidLiteralType t1 t2
+                else return False
+            (a, b) -> return $ a == b
+
+checkValidLiteralType :: A.Type -> A.Type -> OccParser ()
+checkValidLiteralType defT t
+    =  do isValid <- isValidLiteralType defT t
+          when (not isValid) $
+            fail $ "type given/inferred for literal (" ++ show t ++ ") is not valid for this sort of literal (" ++ show defT ++ ")"
+
+-- | Apply dimensions from one type to another as far as possible.
+-- This should only be used when you know the two types are compatible first
+-- (i.e. they've passed isValidLiteralType).
+applyDimensions :: A.Type -> A.Type -> A.Type
+applyDimensions (A.Array ods _) (A.Array tds t) = A.Array (dims ods tds) t
+  where
+    dims :: [A.Dimension] -> [A.Dimension] -> [A.Dimension]
+    dims (d@(A.Dimension _):ods) (A.UnknownDimension:tds)
+        = d : dims ods tds
+    dims (_:ods) (d:tds)
+        = d : dims ods tds
+    dims _ ds = ds
+applyDimensions _ t = t
+--}}}
 
 literal :: OccParser A.Expression
 literal
@@ -666,8 +710,7 @@ literal
           (defT, lr) <- untypedLiteral
           t <- do { try sLeftR; t <- dataType; sRightR; return t }
                <|> (getTypeContext defT)
-          when (not $ isValidLiteralType defT t) $
-            fail $ "type given/inferred for literal (" ++ show t ++ ") is not valid for this sort of literal (" ++ show defT ++ ")"
+          checkValidLiteralType defT t
           return $ A.Literal m t lr
     <?> "literal"
 
@@ -727,16 +770,31 @@ table'
     =   do m <- md
            (s, dim) <- stringLiteral
            let defT = A.Array [dim] A.Byte
-           do { sLeftR; t <- dataType; sRightR; matchType defT t; return $ A.Literal m t s }
-             <|> (return $ A.Literal m defT s)
+           t <- do sLeftR
+                   t <- dataType
+                   sRightR
+                   return t
+                 <|> getTypeContext defT
+           checkValidLiteralType defT t
+           return $ A.Literal m t s
     <|> do m <- md
            pushSubscriptTypeContext
            es <- tryXVX sLeft (sepBy1 expression sComma) sRight
            popTypeContext
+
            ets <- mapM typeOfExpression es
-           t <- listType m ets
-           aes <- mapM collapseArrayElem es
-           return $ A.Literal m t (A.ArrayLiteral m aes)
+           defT <- listType m ets
+
+           array <- liftM (A.ArrayLiteral m) $ mapM collapseArrayElem es
+
+           t <- do sLeftR
+                   t <- dataType
+                   sRightR
+                   return t
+                 <|> getTypeContext defT
+           checkValidLiteralType defT t
+           let t' = applyDimensions defT t
+           return $ A.Literal m t' array
     <|> maybeSliced table A.SubscriptedExpr typeOfExpression
     <?> "table'"
 

fco2/SimplifyTypes.hs

@@ -0,0 +1,37 @@
+-- | Simplify types in the AST.
+module SimplifyTypes (simplifyTypes) where
+
+import Control.Monad.State
+import Data.Generics
+
+import qualified AST as A
+import Pass
+import Types
+
+simplifyTypes :: A.Process -> PassM A.Process
+simplifyTypes = runPasses passes
+  where
+    passes =
+      [ ("Resolve types in AST", resolveNamedTypes)
+      , ("Resolve types in state", rntState)
+      ]
+
+-- | Turn named data types into their underlying types.
+resolveNamedTypes :: Data t => t -> PassM t
+resolveNamedTypes = doGeneric `extM` doType
+  where
+    doGeneric :: Data t => t -> PassM t
+    doGeneric = makeGeneric resolveNamedTypes
+
+    doType :: A.Type -> PassM A.Type
+    doType t@(A.UserDataType _) = underlyingType t
+    doType t = doGeneric t
+
+-- | Resolve named types in ParseState.
+rntState :: A.Process -> PassM A.Process
+rntState p
+    =  do st <- get
+          st' <- resolveNamedTypes st
+          put st'
+          return p
+

fco2/TODO

@@ -33,9 +33,6 @@ names in it replaced appropriately.
 
 ## Passes
 
-There should be a mkGeneric which produces a version of doGeneric that prunes
-out things we don't need to recurse into -- like Strings.
-
 Come up with an approach to combining simple passes to avoid multiple tree
 walks (for example, giving passes a "next thing to try" parameter).
 
@@ -48,9 +45,6 @@ We should generally try to reduce the number of unnecessary pullups we do:
 - plain subscripts that result in a non-array shouldn't pull up (e.g. x[i][j])
 - expressions that are already a variable should just be turned into the variable
 
-Before code generation, have a pass that resolves all the DATA TYPE .. IS
-directives to their real types.
-
 Pass to turn complicated conversions into simpler ones (currently done in
 GenerateC).
 

fco2/Types.hs

@@ -202,6 +202,16 @@ abbrevModeOfSpec s
         A.RetypesExpr _ am _ _ -> am
         _ -> A.Original
 
+-- | Resolve a datatype into its underlying type -- i.e. if it's a named data
+-- type, then return the underlying real type.
+underlyingType :: (PSM m, Die m) => A.Type -> m A.Type
+underlyingType (A.UserDataType n)
+    =  do st <- specTypeOfName n
+          case st of
+            A.DataType _ t -> underlyingType t
+            _ -> die $ "not a type name " ++ show n
+underlyingType t = return t
+
 -- | Add an array dimension to a type; if it's already an array it'll just add
 -- a new dimension to the existing array.
 makeArrayType :: A.Dimension -> A.Type -> A.Type

fco2/testcases/_bad_datatype.occ

@@ -0,0 +1,8 @@
+DATA TYPE ANGLE IS INT:
+DATA TYPE LENGTH IS INT:
+VAL ANGLE a IS 45:
+VAL LENGTH b IS 10:
+VAL LENGTH c IS a + b:
+PROC P ()
+  SKIP
+:

fco2/testcases/datatype.occ

@@ -0,0 +1,38 @@
+-- Test basic stuff with named datatypes.
+
+DATA TYPE NUM IS INT:
+PROC P ()
+  DATA TYPE CHAR IS BYTE:
+
+  NUM n:
+  CHAR c:
+
+  [10]NUM ns:
+  [10]CHAR cs:
+
+  SEQ
+    n := 42
+    c := 42
+
+    n := 42 (NUM)
+    c := 42 (CHAR)
+
+    n := NUM (42 (INT))
+    c := CHAR (42 (BYTE))
+
+    n := NUM c
+    c := CHAR n
+
+    SEQ i = 0 FOR 10
+      SEQ
+        ns[i] := n
+        cs[i] := c
+        n := ns[i]
+        c := cs[i]
+
+    n := ns[2] + ns[4]
+    c := cs[2] + cs[4]
+
+    ASSERT (n = 84)
+    ASSERT (c = 84)
+:

fco2/testcases/datatype2.occ

@@ -0,0 +1,27 @@
+-- Test tables of user datatypes, and user datatypes that are arrays.
+
+PROC P ()
+  DATA TYPE CHAR IS BYTE:
+  DATA TYPE CHARS IS [5]BYTE:
+  CHAR ch:
+  VAL CHARS s2 IS "hello" (CHARS):
+  VAL CHARS s IS "hello":
+
+  DATA TYPE ONE IS INT:
+  DATA TYPE FOUR IS [4]INT:
+  VAL ONE o IS 42:
+  VAL FOUR g IS [1, 2, 3, 4] (FOUR):
+  VAL FOUR f IS [1, 2, 3, 4]:
+
+  VAL []INT is IS [1, 2, 3, 4]:
+  VAL []ONE os IS [1, 2, 3, 4]:
+  VAL []ONE os2 IS [1 (ONE), 2, 3, 4]:
+  -- I don't see why this shouldn't work, but occ21 doesn't like it.
+  --VAL []CHAR cs IS "hello":
+
+  SEQ
+    ASSERT (o = 42)
+    ASSERT (f[2] = 3)
+    ASSERT (g[2] = 3)
+    ASSERT (os[1] = 2)
+: