From 3f45d38f15142092c8bdb1f7135b84c4a91b53e4 Mon Sep 17 00:00:00 2001 From: Adam Sampson Date: Fri, 13 Apr 2007 01:35:09 +0000 Subject: [PATCH] Lots more stuff implemented -- tagged and count protocols, CASE, rep PAR --- fco2/AST.hs | 12 +- fco2/GenerateC.hs | 363 ++++++++++++++++++++++++++--------- fco2/Makefile | 3 +- fco2/Parse.hs | 20 +- fco2/Types.hs | 34 ++-- fco2/Unnest.hs | 2 +- fco2/testcases/ats1-q7.occ | 2 +- fco2/testcases/case.occ | 18 ++ fco2/testcases/protocols.occ | 45 +++++ fco2/testcases/records.occ | 39 ++++ 10 files changed, 423 insertions(+), 115 deletions(-) create mode 100644 fco2/testcases/case.occ create mode 100644 fco2/testcases/protocols.occ create mode 100644 fco2/testcases/records.occ diff --git a/fco2/AST.hs b/fco2/AST.hs index 8672e48..6102609 100644 --- a/fco2/AST.hs +++ b/fco2/AST.hs @@ -16,7 +16,13 @@ data Name = Name { nameType :: NameType, nameName :: String } - deriving (Show, Eq, Typeable, Data) + deriving (Typeable, Data) + +instance Show Name where + show n = show $ nameName n + +instance Eq Name where + (==) a b = nameName a == nameName b data NameDef = NameDef { ndMeta :: Meta, @@ -56,7 +62,7 @@ data ConversionMode = data Subscript = Subscript Meta Expression - | SubscriptTag Meta Name + | SubscriptField Meta Name | SubscriptFromFor Meta Expression Expression | SubscriptFrom Meta Expression | SubscriptFor Meta Expression @@ -184,7 +190,7 @@ data SpecType = -- FIXME Can these be multidimensional? | IsChannelArray Meta Type [Variable] | DataType Meta Type - | DataTypeRecord Meta Bool [(Type, Name)] + | DataTypeRecord Meta Bool [(Name, Type)] | Protocol Meta [Type] | ProtocolCase Meta [(Name, [Type])] | Proc Meta [Formal] Process diff --git a/fco2/GenerateC.hs b/fco2/GenerateC.hs index 1c77460..0086299 100644 --- a/fco2/GenerateC.hs +++ b/fco2/GenerateC.hs @@ -79,14 +79,14 @@ checkJust :: Monad m => Maybe t -> m t checkJust (Just v) = return v checkJust Nothing = fail "checkJust failed" -overArray :: A.Name -> A.Type -> (CGen () -> Maybe (CGen ())) -> CGen () -overArray n (A.Array ds _) func +overArray :: CGen () -> A.Type -> (CGen () -> Maybe (CGen ())) -> CGen () +overArray name (A.Array ds _) func = do indices <- mapM (\_ -> makeNonce "i") ds let arg = sequence_ [tell ["[", i, "]"] | i <- indices] case func arg of Just p -> do sequence_ [do tell ["for (int ", i, " = 0; ", i, " < "] - genName n + name tell ["_sizes[", show v, "]; ", i, "++) {\n"] | (v, i) <- zip [0..] indices] p @@ -117,11 +117,29 @@ genType (A.Array _ t) = do genType t tell ["*"] genType (A.UserDataType n) = genName n +-- UserProtocol -- not used genType (A.Chan t) = tell ["Channel *"] +-- Counted -- not used +-- Any -- not used +--genType A.Timer = +--genType (A.Port t) = genType t = case scalarType t of Just s -> tell [s] Nothing -> missing $ "genType " ++ show t + +genBytesInType :: A.Type -> CGen () +genBytesInType (A.Array ds t) = genBytesInDims ds >> genBytesInType t + where + genBytesInDims [] = return () + genBytesInDims ((A.Dimension e):ds) + = genBytesInDims ds >> genExpression e >> tell [" * "] + genBytesInDims _ = missing "genBytesInType with empty dimension" +--bytesInType (A.UserDataType n) +genBytesInType t + = case scalarType t of + Just s -> tell ["sizeof (", s, ")"] + Nothing -> missing $ "genBytesInType " ++ show t --}}} --{{{ declarations @@ -159,7 +177,7 @@ genSubscript (A.Subscript m e) p tell ["["] genExpression e tell ["]"] -genSubscript (A.SubscriptTag m n) p +genSubscript (A.SubscriptField m n) p = do p tell ["."] genName n @@ -254,7 +272,6 @@ genExpression (A.Dyadic m op e f) = genDyadic op e f genExpression (A.MostPos m t) = genTypeConstant "mostpos" t genExpression (A.MostNeg m t) = genTypeConstant "mostneg" t --genExpression (A.SizeType m t) --- FIXME This needs to cope with subscripts genExpression (A.SizeExpr m e) = do genExpression e tell ["_sizes[0]"] @@ -266,11 +283,7 @@ genExpression (A.False m) = tell ["false"] --genExpression (A.FunctionCall m n es) --genExpression (A.SubscriptedExpr m s e) --genExpression (A.BytesInExpr m e) --- FIXME This needs to do special stuff with arrays. -genExpression (A.BytesInType m t) - = do tell ["sizeof ("] - genType t - tell [")"] +genExpression (A.BytesInType m t) = genBytesInType t --genExpression (A.OffsetOf m t n) genExpression t = missing $ "genExpression " ++ show t @@ -336,44 +349,80 @@ genDyadic A.After e f = genFuncDyadic "occam_after" e f genInputItem :: A.Variable -> A.InputItem -> CGen () genInputItem c (A.InCounted m cv av) = do genInputItem c (A.InVariable m cv) - -- need to then input as much as appropriate - missing "genInputItem counted" + ps <- get + t <- checkJust $ typeOfVariable ps av + tell ["ChanIn ("] + genVariable c + tell [", "] + let (rhs, rhsS) = abbrevVariable A.Abbrev t av + rhs + tell [", "] + let subT = fromJust $ subscriptType ps (A.Subscript m $ makeConstant m 0) t + genVariable cv + tell [" * "] + genBytesInType subT + tell [");\n"] genInputItem c (A.InVariable m v) = do ps <- get t <- checkJust $ typeOfVariable ps v + let (rhs, rhsS) = abbrevVariable A.Abbrev t v case t of A.Int -> do tell ["ChanInInt ("] genVariable c - tell [", &"] - genVariable v + tell [", "] + rhs tell [");\n"] _ -> do tell ["ChanIn ("] genVariable c - tell [", &"] - genVariable v - tell [", sizeof ("] - genType t - tell ["));\n"] + tell [", "] + rhs + tell [", "] + genBytesInType t + tell [");\n"] genOutputItem :: A.Variable -> A.OutputItem -> CGen () genOutputItem c (A.OutCounted m ce ae) = do genOutputItem c (A.OutExpression m ce) - missing "genOutputItem counted" -genOutputItem c (A.OutExpression m e) - = do n <- makeNonce "output_item" ps <- get + t <- checkJust $ typeOfExpression ps ae + case ae of + A.ExprVariable m v -> + do tell ["ChanOut ("] + genVariable c + tell [", "] + let (rhs, rhsS) = abbrevVariable A.Abbrev t v + rhs + tell [", "] + let subT = fromJust $ subscriptType ps (A.Subscript m $ makeConstant m 0) t + genExpression ce + tell [" * "] + genBytesInType subT + tell [");\n"] +genOutputItem c (A.OutExpression m e) + = do ps <- get t <- checkJust $ typeOfExpression ps e - case t of - A.Int -> + case (t, e) of + (A.Int, _) -> do tell ["ChanOutInt ("] genVariable c tell [", "] genExpression e tell [");\n"] + (_, A.ExprVariable _ v) -> + do tell ["ChanOut ("] + genVariable c + tell [", "] + let (rhs, rhsS) = abbrevVariable A.Abbrev t v + rhs + tell [", "] + genBytesInType t + tell [");\n"] + -- FIXME It would be cleaner to do this with a pullup, + -- which would reduce it to the previous case. _ -> - do tell ["{\n"] + do n <- makeNonce "output_item" tell ["const "] genType t tell [" ", n, " = "] @@ -381,10 +430,9 @@ genOutputItem c (A.OutExpression m e) tell [";\n"] tell ["ChanOut ("] genVariable c - tell [", &", n, ", sizeof ("] - genType t - tell ["));\n"] - tell ["}\n"] + tell [", &", n, ", "] + genBytesInType t + tell [");\n"] --}}} --{{{ replicators @@ -410,6 +458,9 @@ genReplicatorLoop (A.For m n base count) tell ["; ", counter, " > 0; ", counter, "--, "] genName n tell ["++"] + +genReplicatorSize :: A.Replicator -> CGen () +genReplicatorSize (A.For m n base count) = genExpression count --}}} --{{{ choice/alternatives/options/variants @@ -463,6 +514,43 @@ declareType :: A.Type -> CGen () declareType (A.Chan _) = tell ["Channel *"] declareType t = genType t +genDimensions :: [A.Dimension] -> CGen () +genDimensions ds + = sequence_ $ [case d of + A.Dimension e -> + do tell ["["] + genExpression e + tell ["]"] + A.UnknownDimension -> + missing "unknown dimension in declaration" + | d <- ds] + +genDeclaration :: A.Type -> A.Name -> CGen () +genDeclaration A.Timer n = return () +genDeclaration (A.Chan _) n + = do tell ["Channel "] + genName n + tell [";\n"] +genDeclaration (A.Array ds t) n + = do declareType t + tell [" "] + genName n + genDimensions ds + tell [";\n"] +genDeclaration t n + = do declareType t + tell [" "] + genName n + tell [";\n"] + +declareArraySizes :: [A.Dimension] -> CGen () -> CGen () +declareArraySizes ds name + = do tell ["const int "] + name + tell ["_sizes[] = { "] + sequence_ $ intersperse genComma [genExpression e | (A.Dimension e) <- ds] + tell [" };\n"] + -- | Initialise an item being declared. declareInit :: A.Type -> CGen () -> CGen () -> Maybe (CGen ()) declareInit (A.Chan _) name index @@ -470,6 +558,21 @@ declareInit (A.Chan _) name index name index tell [");\n"] +declareInit t@(A.Array ds t') name _ -- index ignored because arrays can't nest + = Just $ do init <- case t' of + A.Chan _ -> + do store <- makeNonce "storage" + tell ["Channel ", store] + genDimensions ds + tell [";\n"] + return (\index -> Just $ do fromJust $ declareInit t' (tell [store]) index + name + index + tell [" = &", store] + index + tell [";\n"]) + _ -> return $ declareInit t' name + overArray name t init declareInit _ _ _ = Nothing -- | Free a declared item that's going out of scope. @@ -493,56 +596,13 @@ CHAN OF INT c IS d: Channel *c = d; -} introduceSpec :: A.Specification -> CGen () introduceSpec (n, A.Declaration m t) - = case t of - A.Timer -> return () - A.Chan _ -> - do tell ["Channel "] - genName n - tell [";\n"] - tell ["ChanInit (&"] - genName n - tell [");\n"] - A.Array ds t' -> - do declareType t' - tell [" "] - genName n - let dim = sequence_ $ [case d of - A.Dimension e -> - do tell ["["] - genExpression e - tell ["]"] - A.UnknownDimension -> - missing "unknown dimension in declaration" - | d <- ds] - dim - tell [";\n"] - init <- case t' of - A.Chan _ -> - do store <- makeNonce "storage" - tell ["Channel ", store] - dim - tell [";\n"] - return (\index -> Just $ do fromJust $ declareInit t' (tell [store]) index - genName n - index - tell [" = &", store] - index - tell [";\n"]) - _ -> return $ declareInit t' (genName n) - tell ["const int "] - genName n - tell ["_sizes[] = { "] - sequence_ $ intersperse genComma [genExpression e | (A.Dimension e) <- ds] - tell [" };\n"] - overArray n t init - _ -> - do declareType t - tell [" "] - genName n - tell [";\n"] - case declareInit t (genName n) (return ()) of - Just p -> p - Nothing -> return () + = do genDeclaration t n + case t of + A.Array ds _ -> declareArraySizes ds (genName n) + _ -> return () + case declareInit t (genName n) (return ()) of + Just p -> p + Nothing -> return () introduceSpec (n, A.Is m am t v) = do let (rhs, rhsSizes) = abbrevVariable am t v genDecl am t n @@ -576,6 +636,28 @@ introduceSpec (n, A.IsChannelArray m t cs) tell [" = {"] sequence_ $ intersperse genComma (map genVariable cs) tell ["};\n"] +--introduceSpec (n, A.DataType m t) +introduceSpec (n, A.DataTypeRecord _ b fs) + = do when b $ missing "packed record" + tell ["typedef struct {\n"] + sequence_ [case t of + _ -> + do declareType t + tell [" "] + genName n + tell [";"] + | (n, t) <- fs] + tell ["} "] + genName n + tell [";\n"] +introduceSpec (n, A.Protocol _ _) = return () +introduceSpec (n, A.ProtocolCase _ ts) + = do tell ["typedef enum {\n"] + sequence_ $ intersperse genComma [genName tag | (tag, _) <- ts] + tell ["\n"] + tell ["} "] + genName n + tell [";\n"] introduceSpec (n, A.Proc m fs p) = do tell ["void "] genName n @@ -584,13 +666,15 @@ introduceSpec (n, A.Proc m fs p) tell [") {\n"] genProcess p tell ["}\n"] --- CASE protocol should generate an enum for the tags +introduceSpec (n, A.Function _ _ _ _) = missing "introduceSpec function" +--introduceSpec (n, A.Retypes m am t v) +--introduceSpec (n, A.RetypesExpr m am t e) introduceSpec (n, t) = missing $ "introduceSpec " ++ show t removeSpec :: A.Specification -> CGen () removeSpec (n, A.Declaration m t) = case t of - A.Array _ t' -> overArray n t (declareFree t' (genName n)) + A.Array _ t' -> overArray (genName n) t (declareFree t' (genName n)) _ -> do case declareFree t (genName n) (return ()) of Just p -> p @@ -654,17 +738,17 @@ genProcess p = case p of A.Assign m vs es -> genAssign vs es A.Input m c im -> genInput c im A.Output m c ois -> genOutput c ois - --A.OutputCase m c t ois + A.OutputCase m c t ois -> genOutputCase c t ois A.Skip m -> tell ["/* skip */\n"] A.Stop m -> genStop A.Main m -> tell ["/* main */\n"] A.Seq m ps -> sequence_ $ map genProcess ps A.SeqRep m r p -> genReplicator r (genProcess p) A.If m s -> genIf s - --A.Case m e s + A.Case m e s -> genCase e s A.While m e p -> genWhile e p A.Par m pm ps -> genPar pm ps - --A.ParRep m pm r p + A.ParRep m pm r p -> genParRep pm r p --A.Processor m e p --A.Alt m b s A.ProcCall m n as -> genProcCall n as @@ -705,8 +789,43 @@ genInput c im A.InputAfter m e -> genTimerWait e _ -> case im of A.InputSimple m is -> sequence_ $ map (genInputItem c) is + A.InputCase m s -> genInputCase c s _ -> missing $ "genInput " ++ show im +genInputCase :: A.Variable -> A.Structured -> CGen () +genInputCase c s + = do ps <- get + t <- checkJust $ typeOfVariable ps c + let proto = case t of A.Chan (A.UserProtocol n) -> n + tag <- makeNonce "case_tag" + genName proto + tell [" ", tag, ";\n"] + tell ["ChanInInt ("] + genVariable c + tell [", &", tag, ");\n"] + tell ["switch (", tag, ") {\n"] + genInputCaseBody c (return ()) s + tell ["default:\n"] + genStop + tell ["}\n"] + +-- This handles specs in a slightly odd way, because we can't insert specs into +-- the body of a switch. +genInputCaseBody :: A.Variable -> CGen () -> A.Structured -> CGen () +genInputCaseBody c coll (A.Spec _ spec s) + = genInputCaseBody c (genSpec spec coll) s +genInputCaseBody c coll (A.OnlyV _ (A.Variant _ n iis p)) + = do tell ["case "] + genName n + tell [": {\n"] + coll + sequence_ $ map (genInputItem c) iis + genProcess p + tell ["break;\n"] + tell ["}\n"] +genInputCaseBody c coll (A.Several _ ss) + = sequence_ $ map (genInputCaseBody c coll) ss + genTimerRead :: A.Variable -> CGen () genTimerRead v = do n <- makeNonce "time" @@ -726,11 +845,21 @@ genTimerWait e genOutput :: A.Variable -> [A.OutputItem] -> CGen () genOutput c ois = sequence_ $ map (genOutputItem c) ois +genOutputCase :: A.Variable -> A.Name -> [A.OutputItem] -> CGen () +genOutputCase c t ois + = do tell ["ChanOutInt ("] + genVariable c + tell [", "] + genName t + tell [");\n"] + genOutput c ois + genStop :: CGen () genStop = tell ["SetErr ();\n"] -- FIXME: This could be special-cased to generate if ... else if ... for bits -- that aren't replicated and don't have specs. +-- FIXME: As with CASE, this could use a flag to detect whether to generate the STOP. genIf :: A.Structured -> CGen () genIf s = do label <- makeNonce "if_end" @@ -738,7 +867,6 @@ genIf s genStop tell [label, ":\n;\n"] --- FIXME: This should be generic for any Structured type. genIfBody :: String -> A.Structured -> CGen () genIfBody label (A.Rep m rep s) = genReplicator rep (genIfBody label s) genIfBody label (A.Spec m spec s) = genSpec spec (genIfBody label s) @@ -751,6 +879,38 @@ genIfBody label (A.OnlyC m (A.Choice m' e p)) tell ["}\n"] genIfBody label (A.Several m ss) = sequence_ $ map (genIfBody label) ss +genCase :: A.Expression -> A.Structured -> CGen () +genCase e s + = do tell ["switch ("] + genExpression e + tell [") {\n"] + seenDefault <- genCaseBody (return ()) s + when (not seenDefault) $ tell ["default:\n"] >> genStop + tell ["}\n"] + +-- FIXME -- can this be made common with genInputCaseBody above? +genCaseBody :: CGen () -> A.Structured -> CGen Bool +genCaseBody coll (A.Spec _ spec s) + = genCaseBody (genSpec spec coll) s +genCaseBody coll (A.OnlyO _ (A.Option _ es p)) + = do sequence_ [tell ["case "] >> genExpression e >> tell [":\n"] | e <- es] + tell ["{\n"] + coll + genProcess p + tell ["break;\n"] + tell ["}\n"] + return False +genCaseBody coll (A.OnlyO _ (A.Else _ p)) + = do tell ["default:\n"] + tell ["{\n"] + coll + genProcess p + tell ["}\n"] + return True +genCaseBody coll (A.Several _ ss) + = do seens <- mapM (genCaseBody coll) ss + return $ or seens + genWhile :: A.Expression -> A.Process -> CGen () genWhile e p = do tell ["while ("] @@ -762,7 +922,10 @@ genWhile e p genPar :: A.ParMode -> [A.Process] -> CGen () genPar pm ps = do pids <- mapM (\_ -> makeNonce "pid") ps - sequence_ $ map genProcAlloc (zip pids ps) + sequence_ $ [do tell ["Process *", pid, " = "] + genProcAlloc p + tell [";\n"] + | (pid, p) <- (zip pids ps)] case pm of A.PlainPar -> do tell ["ProcPar ("] @@ -771,9 +934,29 @@ genPar pm ps _ -> missing $ "genPar " ++ show pm sequence_ $ [tell ["ProcAllocClean (", pid, ");\n"] | pid <- pids] -genProcAlloc :: (String, A.Process) -> CGen () -genProcAlloc (pid, A.ProcCall m n as) - = do tell ["Process *", pid, " = ProcAlloc ("] +-- FIXME -- This'll require a C99 dynamic array for a dynamic PAR count, +-- which may turn out to be a bad idea for very large counts (since I assume +-- it'll allocate off the stack). We should probably do a malloc if it's +-- not determinable at compile time. +genParRep :: A.ParMode -> A.Replicator -> A.Process -> CGen () +genParRep pm rep p + = do pids <- makeNonce "pids" + index <- makeNonce "i" + tell ["Process *", pids, "["] + genReplicatorSize rep + tell [" + 1];\n"] + tell ["int ", index, " = 0;\n"] + genReplicator rep $ do tell [pids, "[", index, "++] = "] + genProcAlloc p + tell [";\n"] + tell [pids, "[", index, "] = NULL;\n"] + tell ["ProcParList (", pids, ");\n"] + tell [index, " = 0;\n"] + genReplicator rep $ tell ["ProcAllocClean (", pids, "[", index, "++]);\n"] + +genProcAlloc :: A.Process -> CGen () +genProcAlloc (A.ProcCall m n as) + = do tell ["ProcAlloc ("] genName n ps <- get let fs = case fromJust $ specTypeOfName ps n of A.Proc _ fs _ -> fs @@ -781,7 +964,7 @@ genProcAlloc (pid, A.ProcCall m n as) let stackSize = 4096 tell [", ", show stackSize, ", ", show $ numCArgs fs] genActuals (zip as fs) - tell [");\n"] + tell [")"] genProcCall :: A.Name -> [A.Actual] -> CGen () genProcCall n as diff --git a/fco2/Makefile b/fco2/Makefile index 71ab4d9..df317b8 100644 --- a/fco2/Makefile +++ b/fco2/Makefile @@ -23,7 +23,8 @@ $(targets): $(sources) CFLAGS = -g -std=gnu99 -Wall `kroc --cflags` `kroc --ccincpath` %.fco.c: %.occ fco - ./fco $< | indent -kr -pcs >$@ + ./fco $< >$@ || ( rm -f $@; exit 1 ) + indent -kr -pcs $@ %.fco: %.fco.o kroc-wrapper-c.o kroc-wrapper.occ kroc -o $@ kroc-wrapper.occ $< kroc-wrapper-c.o -lcif diff --git a/fco2/Parse.hs b/fco2/Parse.hs index e9c9d9f..c765f18 100644 --- a/fco2/Parse.hs +++ b/fco2/Parse.hs @@ -244,10 +244,18 @@ maybeSubscripted :: String -> OccParser a -> (Meta -> A.Subscript -> a -> a) -> maybeSubscripted prodName inner subscripter = do m <- md v <- inner - es <- many (do { m' <- md; sLeft; e <- expression; sRight; return (m', e) }) - return $ foldl (\e (m', s) -> subscripter m' (A.Subscript m' s) e) v es + subs <- many postSubscript + return $ foldl (\var sub -> subscripter m sub var) v subs prodName +postSubscript :: OccParser A.Subscript +postSubscript + = do m <- md + sLeft + --(do { f <- tryTrail fieldName sRight; return $ A.SubscriptField m f } + -- <|> + do { e <- expression; sRight; return $ A.Subscript m e } --) + maybeSliced :: OccParser a -> (Meta -> A.Subscript -> a -> a) -> OccParser a maybeSliced inner subscripter = do m <- md @@ -326,10 +334,6 @@ pTypeOf f item pTypeOfVariable = pTypeOf typeOfVariable pTypeOfExpression = pTypeOf typeOfExpression pSpecTypeOfName = pTypeOf specTypeOfName - --- | Generate a constant expression from an integer -- for array sizes and the like. -makeConstant :: Meta -> Int -> A.Expression -makeConstant m n = A.ExprLiteral m $ A.Literal m A.Int $ A.IntLiteral m (show n) --}}} --{{{ name scoping @@ -887,9 +891,9 @@ recordKeyword <|> do { sRECORD; return False } "recordKeyword" -structuredTypeField :: OccParser [(A.Type, A.Name)] +structuredTypeField :: OccParser [(A.Name, A.Type)] structuredTypeField - = do { t <- dataType; fs <- many1 newFieldName; sColon; eol; return [(t, f) | f <- fs] } + = do { t <- dataType; fs <- many1 newFieldName; sColon; eol; return [(f, t) | f <- fs] } "structuredTypeField" --}}} --}}} diff --git a/fco2/Types.hs b/fco2/Types.hs index 0805a15..c61cf82 100644 --- a/fco2/Types.hs +++ b/fco2/Types.hs @@ -10,13 +10,11 @@ import Control.Monad import qualified AST as A import ParseState +import Metadata perhaps :: Maybe a -> (a -> b) -> Maybe b perhaps m f = m >>= (Just . f) -sameName :: A.Name -> A.Name -> Bool -sameName a b = A.nameName a == A.nameName b - specTypeOfName :: ParseState -> A.Name -> Maybe A.SpecType specTypeOfName ps n = (psLookupName ps n) `perhaps` A.ndType @@ -36,16 +34,27 @@ typeOfName ps n 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 [_] t) = Just t -subscriptType (A.Array (_:ds) t) = Just $ A.Array ds t -subscriptType _ = Nothing +typeOfRecordField :: ParseState -> A.Type -> A.Name -> Maybe A.Type +typeOfRecordField ps (A.UserDataType rec) field + = do st <- specTypeOfName ps rec + case st of + A.DataTypeRecord _ _ fs -> lookup field fs + _ -> Nothing +typeOfRecordField _ _ _ = Nothing + +subscriptType :: ParseState -> A.Subscript -> A.Type -> Maybe A.Type +subscriptType _ (A.SubscriptFromFor _ _ _) t = Just t +subscriptType _ (A.SubscriptFrom _ _) t = Just t +subscriptType _ (A.SubscriptFor _ _) t = Just t +subscriptType ps (A.SubscriptField _ tag) t = typeOfRecordField ps t tag +subscriptType _ (A.Subscript _ _) (A.Array [_] t) = Just t +subscriptType _ (A.Subscript _ _) (A.Array (_:ds) t) = Just $ A.Array ds t +subscriptType _ _ _ = Nothing typeOfVariable :: ParseState -> A.Variable -> Maybe A.Type typeOfVariable ps (A.Variable m n) = typeOfName ps n typeOfVariable ps (A.SubscriptedVariable m s v) - = typeOfVariable ps v >>= subscriptType + = typeOfVariable ps v >>= subscriptType ps s abbrevModeOfVariable :: ParseState -> A.Variable -> Maybe A.AbbrevMode abbrevModeOfVariable ps (A.Variable _ n) = abbrevModeOfName ps n @@ -81,7 +90,7 @@ typeOfExpression ps e Just [t] -> Just t _ -> Nothing A.SubscriptedExpr m s e -> - typeOfExpression ps e >>= subscriptType + typeOfExpression ps e >>= subscriptType ps s A.BytesInExpr m e -> Just A.Int A.BytesInType m t -> Just A.Int A.OffsetOf m t n -> Just A.Int @@ -89,7 +98,7 @@ typeOfExpression ps e typeOfLiteral :: ParseState -> A.Literal -> Maybe A.Type typeOfLiteral ps (A.Literal m t lr) = Just t typeOfLiteral ps (A.SubscriptedLiteral m s l) - = typeOfLiteral ps l >>= subscriptType + = typeOfLiteral ps l >>= subscriptType ps s returnTypesOfFunction :: ParseState -> A.Name -> Maybe [A.Type] returnTypesOfFunction ps n @@ -129,3 +138,6 @@ stripArrayType :: A.Type -> A.Type stripArrayType (A.Array _ t) = stripArrayType t stripArrayType t = t +-- | Generate a constant expression from an integer -- for array sizes and the like. +makeConstant :: Meta -> Int -> A.Expression +makeConstant m n = A.ExprLiteral m $ A.Literal m A.Int $ A.IntLiteral m (show n) diff --git a/fco2/Unnest.hs b/fco2/Unnest.hs index 5de2348..b2c752f 100644 --- a/fco2/Unnest.hs +++ b/fco2/Unnest.hs @@ -124,7 +124,7 @@ removeFreeNames = doGeneric `extM` doProcess `extM` doStructured `extM` doValueP where atcProc :: A.Process -> A.Process atcProc p@(A.ProcCall m n as) - = if sameName n matchN then A.ProcCall m n (as ++ newAs) else p + = if n == matchN then A.ProcCall m n (as ++ newAs) else p atcProc p = p doSpec :: Data t => Meta -> A.Specification -> t -> PassM (A.Specification, t) diff --git a/fco2/testcases/ats1-q7.occ b/fco2/testcases/ats1-q7.occ index b04ec06..6e5c5ff 100644 --- a/fco2/testcases/ats1-q7.occ +++ b/fco2/testcases/ats1-q7.occ @@ -12,7 +12,7 @@ PROC out.int (VAL INT n, w, CHAN OF BYTE out) STOP : INT, INT FUNCTION random (VAL INT range, seed) IS 0, 0: -PROC copy.string ([]BYTE dest, VAL []BYTE src) +PROC copy.string (VAL []BYTE src, []BYTE dest) STOP : PROC make.string ([]BYTE dest, VAL INT len) diff --git a/fco2/testcases/case.occ b/fco2/testcases/case.occ new file mode 100644 index 0000000..228d236 --- /dev/null +++ b/fco2/testcases/case.occ @@ -0,0 +1,18 @@ +PROC P () + INT n: + SEQ + CASE n -- with ELSE + 1, 2 + SKIP + 3 + SKIP + 4, 5, 6, 7, 8 + SKIP + ELSE + SKIP + CASE n -- without ELSE + 1 + SKIP + 2 + SKIP +: diff --git a/fco2/testcases/protocols.occ b/fco2/testcases/protocols.occ new file mode 100644 index 0000000..97eced9 --- /dev/null +++ b/fco2/testcases/protocols.occ @@ -0,0 +1,45 @@ +PROTOCOL SIMPLE IS INT; BOOL; BYTE: +PROTOCOL COMPLEX + CASE + three.args; INT; BOOL; BYTE + one.arg; INT + no.args +: +PROTOCOL ARRAY IS [10]BYTE: +PROTOCOL COUNTED IS INT::[]BYTE: +PROC P () + CHAN OF SIMPLE simple: + CHAN OF COMPLEX complex: + CHAN OF ARRAY array: + CHAN OF COUNTED counted: + INT i: + BOOL b: + BYTE y: + [10]BYTE is: + PAR + SEQ + simple ! 42; TRUE; 42 + complex ! three.args; 42; TRUE; 42 + complex ! one.arg; 42 + complex ! no.args + complex ! one.arg; 24 + array ! "abcdefghij" + counted ! 5::"abcde" + SEQ + simple ? i; b; y + complex ? CASE three.args; i; b; y + complex ? CASE one.arg; i + complex ? CASE no.args + complex ? CASE + INT ii: + BOOL bb: + three.args; ii; bb; y + STOP + INT ii: + one.arg; ii + SKIP + no.args + STOP + array ? is + counted ? i::is +: diff --git a/fco2/testcases/records.occ b/fco2/testcases/records.occ new file mode 100644 index 0000000..fdb24cc --- /dev/null +++ b/fco2/testcases/records.occ @@ -0,0 +1,39 @@ +DATA TYPE PLAIN.REC + RECORD + INT i: + BOOL b: +: +DATA TYPE PACKED.REC + PACKED RECORD + INT i: + BOOL b: +: +PROC Q (INT i, BOOL b) + SKIP +: +PROC R (VAL INT i, VAL BOOL b) + SKIP +: +PROC S (PLAIN.REC rec) + SEQ + Q (rec[i], rec[b]) + R (rec[i], rec[b]) +: +PROC T (VAL PLAIN.REC rec) + R (rec[i], rec[b]) +: +PROC P () + PLAIN.REC plain: + PACKED.REC packed: + SEQ + plain[i] := 42 + plain[b] := FALSE + Q (plain[i], plain[b]) + R (plain[i], plain[b]) + packed[i] := 42 + packed[b] := FALSE + Q (packed[i], packed[b]) + R (packed[i], packed[b]) + S (plain) + T (plain) +: