From 74efa433893b90615e50ec82026a77fc707e7ede Mon Sep 17 00:00:00 2001 From: Adam Sampson Date: Wed, 11 Apr 2007 17:08:16 +0000 Subject: [PATCH] Work towards getting arrays working -- needs a cleanup, though --- fco2/AST.hs | 9 +- fco2/GenerateC.hs | 164 +++++++++++++++++++++++++++---------- fco2/Parse.hs | 32 +++++--- fco2/Types.hs | 21 +++-- fco2/testcases/actuals.occ | 10 +-- fco2/testcases/arrays.occ | 55 +++++++++++++ 6 files changed, 220 insertions(+), 71 deletions(-) create mode 100644 fco2/testcases/arrays.occ diff --git a/fco2/AST.hs b/fco2/AST.hs index 14d3013..c377ca6 100644 --- a/fco2/AST.hs +++ b/fco2/AST.hs @@ -33,8 +33,7 @@ data Type = | Byte | Int | Int16 | Int32 | Int64 | Real32 | Real64 - | Array Expression Type - | ArrayUnsized Type + | Array [Dimension] Type | UserDataType Name | UserProtocol Name | Chan Type @@ -44,6 +43,11 @@ data Type = | Port Type deriving (Show, Eq, Typeable, Data) +data Dimension = + Dimension Expression + | UnknownDimension + deriving (Show, Eq, Typeable, Data) + data ConversionMode = DefaultConversion | Round @@ -183,6 +187,7 @@ data SpecType = | Is Meta AbbrevMode Type Variable | IsExpr Meta AbbrevMode Type Expression | IsChannel Meta Type Channel + -- FIXME Can these be multidimensional? | IsChannelArray Meta Type [Channel] | DataType Meta Type | DataTypeRecord Meta Bool [(Type, Name)] diff --git a/fco2/GenerateC.hs b/fco2/GenerateC.hs index 66c1b9b..51e64f1 100644 --- a/fco2/GenerateC.hs +++ b/fco2/GenerateC.hs @@ -7,9 +7,6 @@ module GenerateC where -- FIXME: Checks should be done in the parser, not here -- for example, the -- expressionList production should take an argument with a list of types. --- FIXME: Arrays should support multiple dimensions (and never be nested). --- AST should have A.Array [Expression] Type. - -- FIXME: The show instance for types should produce occam-looking types. -- FIXME: Should have a "current type context" in the parser, so that @@ -20,6 +17,12 @@ module GenerateC where -- FIXME: Should have a pass that converts functions to procs, and calls to a -- call outside the enclosing process (which can be found by a generic pass -- over the tree). +-- Array constants need pulling up at the same time (might as well avoid +-- walking the tree twice!). +-- And slices. Subscripts generally? + +-- FIXME: The timer read mess can be cleaned up -- when you declare a timer, +-- that declares the temp variable... import Data.List import Data.Maybe @@ -87,14 +90,9 @@ scalarType A.Real64 = Just "double" scalarType _ = Nothing genType :: A.Type -> CGen () -genType (A.Array e t) +genType (A.Array _ t) = do genType t - tell ["["] - genExpression e - tell ["]"] -genType (A.ArrayUnsized t) - = do genType t - tell ["[]"] + tell ["*"] genType (A.UserDataType n) = genName n genType (A.Chan t) = tell ["Channel *"] genType t @@ -110,10 +108,6 @@ genDeclType am t A.ValAbbrev -> tell ["const "] _ -> return () genType t - case (am, t) of - (_, A.Chan _) -> return () - (A.Abbrev, _) -> tell ["*"] - _ -> return () genDecl :: A.AbbrevMode -> A.Type -> A.Name -> CGen () genDecl am t n @@ -179,12 +173,12 @@ convStringStar c = [c] --{{{ channels, variables {- -FIXME All this stuff will change once we do arrays properly... - Channel c; -> &c \ Original Channel c[10]; -> &c[i] / Channel *c; -> c \ Abbrev Channel **c; -> c[i] / + +But if I say genChannel on cs, then I want cs back either way, not &cs... -} genChannel :: A.Channel -> CGen () genChannel (A.Channel m n) @@ -200,19 +194,21 @@ genChannel (A.SubscriptedChannel m s c) = genSubscript s (genChannel c) int x; -> x \ Original, ValAbbrev int x[10]; -> x[i] / int *x; -> (*x) \ Abbrev -int **x; -> (*x)[i] / +int **x; -> x[i] / -} genVariable :: A.Variable -> CGen () genVariable (A.Variable m n) = do ps <- get am <- checkJust $ abbrevModeOfName ps n - case am of - A.Abbrev -> tell ["(*"] - _ -> return () - genName n - case am of - A.Abbrev -> tell [")"] - _ -> return () + t <- checkJust $ typeOfName ps n + let doName = genName n + case (am, t) of + (_, A.Array _ _) -> doName + (A.Abbrev, _) -> + do tell ["(*"] + doName + tell [")"] + _ -> doName genVariable (A.SubscriptedVariable m s v) = genSubscript s (genVariable v) --}}} @@ -257,8 +253,9 @@ genMonadic :: A.MonadicOp -> A.Expression -> CGen () genMonadic A.MonadicSubtr e = genSimpleMonadic "-" e genMonadic A.MonadicBitNot e = genSimpleMonadic "~" e genMonadic A.MonadicNot e = genSimpleMonadic "!" e ---genMonadic A.MonadicSize e -genMonadic op e = missing $ "genMonadic " ++ show op +genMonadic A.MonadicSize e + = do genExpression e + tell ["_sizes[0]"] genSimpleDyadic :: String -> A.Expression -> A.Expression -> CGen () genSimpleDyadic s e f @@ -406,26 +403,80 @@ introduceSpec (n, A.Declaration m t) tell ["ChanInit (&"] genName n tell [");\n"] + A.Array ds t -> + do genType t + tell [" "] + genName n + sequence_ $ map (\d -> case d of + A.Dimension e -> + do tell ["["] + genExpression e + tell ["]"] + A.UnknownDimension -> + missing "unknown dimension in declaration") ds + tell [";\n"] + tell ["const int "] + genName n + tell ["_sizes[] = { "] + sequence_ $ intersperse genComma [genExpression e | (A.Dimension e) <- ds] + tell [" };\n"] _ -> - do genDeclType A.Original t + do genType t tell [" "] genName n tell [";\n"] +{- + Original Abbrev +INT x IS y: int *x = &y; int *x = &(*y); +[]INT xs IS ys: int *xs = ys; int *xs = ys; + const int xs_sizes[] = ys_sizes; +-} introduceSpec (n, A.Is m am t v) - = do genDecl am t n - tell [" = &"] - genVariable v - tell [";\n"] + = case t of + A.Array _ _ -> + do genDecl am t n + tell [" = "] + let name = case v of A.Variable _ name -> name + genName name + tell [";\n"] + tell ["const int "] + genName n + tell ["_sizes[] = "] + genName name + tell ["_sizes;\n"] + _ -> + do genDecl am t n + tell [" = &"] + genVariable v + tell [";\n"] introduceSpec (n, A.IsExpr m am t e) = do genDecl am t n tell [" = "] genExpression e tell [";\n"] +{- +CHAN OF INT c IS d: Channel *c = d; +[]CHAN OF INT cs IS ds: Channel **cs = ds; + const int cs_sizes[] = ds_sizes; +-} introduceSpec (n, A.IsChannel m t c) - = do genDecl A.Abbrev t n - tell [" = "] - genChannel c - tell [";\n"] + = case t of + A.Array _ _ -> + do genDecl A.Abbrev t n + tell [" = "] + let name = case c of A.Channel _ name -> name + genName name + tell [";\n"] + tell ["const int "] + genName n + tell ["_sizes[] = "] + genName name + tell ["_sizes;\n"] + _ -> + do genDecl A.Abbrev t n + tell [" = "] + genChannel c + tell [";\n"] introduceSpec (n, A.IsChannelArray m t cs) = do genDecl A.Abbrev t n tell [" = {"] @@ -451,21 +502,48 @@ genActuals :: [A.Actual] -> CGen () genActuals as = sequence_ $ intersperse genComma (map genActual as) genActual :: A.Actual -> CGen () -genActual (A.ActualExpression e) = genExpression e -genActual (A.ActualChannel c) = genChannel c +-- FIXME Handle expressions that return arrays +genActual (A.ActualExpression e) + = do ps <- get + t <- checkJust $ typeOfExpression ps e + case t of + (A.Array _ t') -> missing "array expression actual" + _ -> genExpression e +genActual (A.ActualChannel c) + = do ps <- get + t <- checkJust $ typeOfChannel ps c + case t of + (A.Array _ t') -> + do genChannel c + tell [", "] + genChannel c + tell ["_sizes"] + _ -> genChannel c genActual (A.ActualVariable v) - = do tell ["&"] - genVariable v + = do ps <- get + t <- checkJust $ typeOfVariable ps v + case t of + (A.Array _ t') -> + do genVariable v + tell [", "] + genVariable v + tell ["_sizes"] + _ -> + do tell ["&"] + genVariable v genFormals :: [A.Formal] -> CGen () genFormals fs = sequence_ $ intersperse genComma (map genFormal fs) --- Arrays must be handled specially genFormal :: A.Formal -> CGen () genFormal (A.Formal am t n) - = do genDeclType am t - tell [" "] - genName n + = case t of + (A.Array _ t) -> + do genDecl am t n + tell ["[], const int "] + genName n + tell ["_sizes[]"] + _ -> genDecl am t n --}}} --{{{ par modes diff --git a/fco2/Parse.hs b/fco2/Parse.hs index f080521..c6b8366 100644 --- a/fco2/Parse.hs +++ b/fco2/Parse.hs @@ -294,15 +294,19 @@ tryTrail p q = try (do { v <- p; q; return v }) listType :: [A.Type] -> OccParser A.Type listType [] = fail "expected non-empty list" -listType [t] = return $ A.ArrayUnsized t +listType [t] = return $ makeArrayType A.UnknownDimension t listType (t1 : rest@(t2 : _)) = if t1 == t2 then listType rest else fail "multiple types in list" matchType :: A.Type -> A.Type -> OccParser () matchType et rt - = if rt == et then return () - else fail $ "type mismatch (got " ++ show rt ++ "; expected " ++ show et ++ ")" + = case (et, rt) of + ((A.Array ds t), (A.Array ds' t')) -> + if length ds == length ds' then return () else bad + _ -> if rt == et then return () else bad + where + bad = fail $ "type mismatch (got " ++ show rt ++ "; expected " ++ show et ++ ")" checkMaybe :: String -> Maybe a -> OccParser a checkMaybe msg op @@ -449,7 +453,7 @@ dataType <|> do { sINT64; return A.Int64 } <|> do { sREAL32; return A.Real32 } <|> do { sREAL64; return A.Real64 } - <|> try (do { sLeft; s <- expression; sRight; t <- dataType; return $ A.Array s t }) + <|> try (do { sLeft; s <- expression; sRight; t <- dataType; return $ makeArrayType (A.Dimension s) t }) <|> do { n <- dataTypeName; return $ A.UserDataType n } "dataType" @@ -457,19 +461,19 @@ dataType channelType :: OccParser A.Type channelType = do { sCHAN; sOF; p <- protocol; return $ A.Chan p } - <|> try (do { sLeft; s <- expression; sRight; t <- channelType; return $ A.Array s t }) + <|> try (do { sLeft; s <- expression; sRight; t <- channelType; return $ makeArrayType (A.Dimension s) t }) "channelType" timerType :: OccParser A.Type timerType = do { sTIMER; return $ A.Timer } - <|> try (do { sLeft; s <- expression; sRight; t <- timerType; return $ A.Array s t }) + <|> try (do { sLeft; s <- expression; sRight; t <- timerType; return $ makeArrayType (A.Dimension s) t }) "timerType" portType :: OccParser A.Type portType = do { sPORT; sOF; p <- dataType; return $ A.Port p } - <|> do { m <- md; try sLeft; s <- try expression; try sRight; t <- portType; return $ A.Array s t } + <|> do { m <- md; try sLeft; s <- try expression; try sRight; t <- portType; return $ makeArrayType (A.Dimension s) t } "portType" --}}} --{{{ literals @@ -525,10 +529,12 @@ table :: OccParser A.Literal table = maybeSubscripted "table" table' A.SubscriptedLiteral +-- FIXME This should put the sizes into the types, since it knows them and +-- we'll need them when generating code. table' :: OccParser A.Literal table' = try (do { m <- md; s <- stringLiteral; sLeftR; t <- dataType; sRightR; return $ A.Literal m t s }) - <|> try (do { m <- md; s <- stringLiteral; return $ A.Literal m (A.ArrayUnsized A.Byte) s }) + <|> try (do { m <- md; s <- stringLiteral; return $ A.Literal m (A.Array [A.UnknownDimension] A.Byte) s }) <|> do m <- md es <- tryTrail (do { sLeft; sepBy1 expression sComma }) sRight ps <- getState @@ -808,7 +814,7 @@ definition dataSpecifier :: OccParser A.Type dataSpecifier = try dataType - <|> try (do { sLeft; sRight; s <- dataSpecifier; return $ A.ArrayUnsized s }) + <|> try (do { sLeft; sRight; s <- dataSpecifier; return $ makeArrayType A.UnknownDimension s }) "dataSpecifier" specifier :: OccParser A.Type @@ -817,7 +823,7 @@ specifier <|> try channelType <|> try timerType <|> try portType - <|> try (do { sLeft; sRight; s <- specifier; return $ A.ArrayUnsized s }) + <|> try (do { sLeft; sRight; s <- specifier; return $ makeArrayType A.UnknownDimension s }) "specifier" --{{{ PROCs and FUNCTIONs @@ -1202,9 +1208,9 @@ actual :: A.Formal -> OccParser A.Actual actual (A.Formal am t n) = do case am of A.ValAbbrev -> do { e <- expression; et <- pTypeOfExpression e; matchType t et; return $ A.ActualExpression e } "actual expression for " ++ an - _ -> case t of - A.Chan _ -> do { c <- channel; ct <- pTypeOfChannel c; matchType t ct; return $ A.ActualChannel c } "actual channel for " ++ an - _ -> do { v <- variable; vt <- pTypeOfVariable v; matchType t vt; return $ A.ActualVariable v } "actual variable for " ++ an + _ -> if isChannelType t + then do { c <- channel; ct <- pTypeOfChannel c; matchType t ct; return $ A.ActualChannel c } "actual channel for " ++ an + else do { v <- variable; vt <- pTypeOfVariable v; matchType t vt; return $ A.ActualVariable v } "actual variable for " ++ an where an = A.nameName n --}}} diff --git a/fco2/Types.hs b/fco2/Types.hs index d16d1ed..b926676 100644 --- a/fco2/Types.hs +++ b/fco2/Types.hs @@ -36,15 +36,15 @@ typeOfName ps n Just (A.Is m am t v) -> typeOfVariable ps v Just (A.IsExpr m am t e) -> typeOfExpression ps e Just (A.IsChannel m t c) -> typeOfChannel ps c - Just (A.IsChannelArray m t (c:_)) -> typeOfChannel ps c `perhaps` A.ArrayUnsized + Just (A.IsChannelArray m t (c:_)) -> typeOfChannel ps c `perhaps` A.Array [A.UnknownDimension] Just (A.Retypes m am t v) -> Just t Just (A.RetypesExpr m am t e) -> Just t _ -> Nothing -- FIXME: This should fail if the subscript is invalid... subscriptType :: A.Type -> Maybe A.Type -subscriptType (A.Array e t) = Just t -subscriptType (A.ArrayUnsized t) = Just t +subscriptType (A.Array [_] t) = Just t +subscriptType (A.Array (_:ds) t) = Just $ A.Array ds t subscriptType _ = Nothing typeOfChannel :: ParseState -> A.Channel -> Maybe A.Type @@ -109,9 +109,14 @@ abbrevModeOfSpec s A.RetypesExpr _ am _ _ -> am _ -> A.Original -isArrayType :: ParseState -> A.Type -> Bool -isArrayType ps (A.Array _ _) = True -isArrayType ps (A.ArrayUnsized _) = True --- FIXME Should handle user data types -isArrayType _ _ = False +-- | 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 +makeArrayType d (A.Array ds t) = A.Array (d : ds) t +makeArrayType d t = A.Array [d] t + +isChannelType :: A.Type -> Bool +isChannelType (A.Array _ t) = isChannelType t +isChannelType (A.Chan _) = True +isChannelType _ = False diff --git a/fco2/testcases/actuals.occ b/fco2/testcases/actuals.occ index 360a90e..9082276 100644 --- a/fco2/testcases/actuals.occ +++ b/fco2/testcases/actuals.occ @@ -1,12 +1,12 @@ --- FIXME This should check arrays too. -PROC O (VAL INT val1, val2, INT abbr, CHAN OF INT channel) +PROC O (VAL INT val1, val2, VAL []INT varray, INT abbr, []INT array, CHAN OF INT channel) SKIP : -PROC P (VAL INT val1, val2, INT abbr, CHAN OF INT channel) - O (val1, val2, abbr, channel) +PROC P (VAL INT val1, val2, VAL []INT varray, INT abbr, []INT array, CHAN OF INT channel) + O (val1, val2, varray, abbr, array, channel) : PROC Q () INT x, y: + [10]INT xs, ys: CHAN OF INT c: - P (42, x, y, c) + P (42, x, xs, y, ys, c) : diff --git a/fco2/testcases/arrays.occ b/fco2/testcases/arrays.occ new file mode 100644 index 0000000..d619b26 --- /dev/null +++ b/fco2/testcases/arrays.occ @@ -0,0 +1,55 @@ +--** Test array abbreviations and parameters. + +PROC P () + SEQ + PROC Q1 ([]INT arg.arg) + SKIP + : + PROC Q ([]INT arg) + Q1 (arg) + : + PROC R1 (VAL []INT val.arg.arg) + SKIP + : + PROC R (VAL []INT val.arg) + R1 (val.arg) + : + [10]INT array: + SEQ + Q (array) + R (array) + []INT abbrev IS array: + SEQ + Q (abbrev) + R (abbrev) + []INT abbrev.abbrev IS abbrev: + SKIP + VAL []INT val.abbrev IS array: + SEQ + R (val.abbrev) + VAL []INT val.abbrev.abbrev IS val.abbrev: + SKIP + abbrev2 IS array: + SEQ + Q (abbrev2) + R (abbrev2) + VAL val.abbrev2 IS array: + R (val.abbrev2) + + PROC S1 ([]CHAN OF INT chan.arg.arg) + SKIP + : + PROC S ([]CHAN OF INT chan.arg) + S1 (chan.arg) + : + [10]CHAN OF INT chan.array: + SEQ + S (chan.array) + []CHAN OF INT chan.abbrev IS chan.array: + SEQ + S (chan.abbrev) + []CHAN OF INT chan.abbrev.abbrev IS chan.abbrev: + SKIP + chan.abbrev2 IS chan.array: + S (chan.abbrev2) +: