diff --git a/fco2/AST.hs b/fco2/AST.hs index 681b161..166e240 100644 --- a/fco2/AST.hs +++ b/fco2/AST.hs @@ -181,7 +181,10 @@ data AbbrevMode = | ValAbbrev deriving (Show, Eq, Typeable, Data) -type Specification = (Name, SpecType) +data Specification = + Specification Name SpecType + deriving (Show, Eq, Typeable, Data) + data SpecType = Place Meta Expression | Declaration Meta Type diff --git a/fco2/GenerateC.hs b/fco2/GenerateC.hs index 268167f..21540f7 100644 --- a/fco2/GenerateC.hs +++ b/fco2/GenerateC.hs @@ -685,7 +685,7 @@ CHAN OF INT c IS d: Channel *c = d; const int *ds_sizes = cs_sizes; -} introduceSpec :: A.Specification -> CGen () -introduceSpec (n, A.Declaration m t) +introduceSpec (A.Specification n (A.Declaration m t)) = do genDeclaration t n case t of A.Array ds _ -> declareArraySizes ds (genName n) @@ -693,27 +693,27 @@ introduceSpec (n, A.Declaration m t) case declareInit t (genName n) (return ()) of Just p -> p Nothing -> return () -introduceSpec (n, A.Is m am t v) +introduceSpec (A.Specification n (A.Is m am t v)) = do let (rhs, rhsSizes) = abbrevVariable am t v genDecl am t n tell [" = "] rhs tell [";\n"] rhsSizes n -introduceSpec (n, A.IsExpr m am t e) +introduceSpec (A.Specification n (A.IsExpr m am t e)) = do let (rhs, rhsSizes) = abbrevExpression am t e genDecl am t n tell [" = "] rhs tell [";\n"] rhsSizes n -introduceSpec (n, A.IsChannelArray m t cs) +introduceSpec (A.Specification n (A.IsChannelArray m t cs)) = do genDecl A.Abbrev t n tell [" = {"] sequence_ $ intersperse genComma (map genVariable cs) tell ["};\n"] ---introduceSpec (n, A.DataType m t) -introduceSpec (n, A.DataTypeRecord _ b fs) +--introduceSpec (A.Specification n (A.DataType m t)) +introduceSpec (A.Specification n (A.DataTypeRecord _ b fs)) = do tell ["typedef struct {\n"] sequence_ [case t of _ -> @@ -726,8 +726,8 @@ introduceSpec (n, A.DataTypeRecord _ b fs) when b $ tell ["occam_struct_packed "] genName n tell [";\n"] -introduceSpec (n, A.Protocol _ _) = return () -introduceSpec (n, A.ProtocolCase _ ts) +introduceSpec (A.Specification n (A.Protocol _ _)) = return () +introduceSpec (A.Specification n (A.ProtocolCase _ ts)) = do tell ["typedef enum {\n"] sequence_ $ intersperse genComma [genName tag >> tell ["_"] >> genName n | (tag, _) <- ts] @@ -735,7 +735,7 @@ introduceSpec (n, A.ProtocolCase _ ts) tell ["} "] genName n tell [";\n"] -introduceSpec (n, A.Proc m fs p) +introduceSpec (A.Specification n (A.Proc m fs p)) = do tell ["void "] genName n tell [" (Process *me"] @@ -743,13 +743,13 @@ introduceSpec (n, A.Proc m fs p) tell [") {\n"] genProcess p tell ["}\n"] -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 +introduceSpec (A.Specification n (A.Function _ _ _ _)) = missing "introduceSpec function" +--introduceSpec (A.Specification n (A.Retypes m am t v)) +--introduceSpec (A.Specification n (A.RetypesExpr m am t e)) +introduceSpec (A.Specification n t) = missing $ "introduceSpec " ++ show t removeSpec :: A.Specification -> CGen () -removeSpec (n, A.Declaration m t) +removeSpec (A.Specification n (A.Declaration m t)) = case t of A.Array _ t' -> overArray (genName n) t (declareFree t' (genName n)) _ -> diff --git a/fco2/Parse.hs b/fco2/Parse.hs index d51e6d5..16292ac 100644 --- a/fco2/Parse.hs +++ b/fco2/Parse.hs @@ -252,6 +252,9 @@ tryXVV a b c = try (do { a; bv <- b; cv <- c; return (bv, cv) }) tryXVX :: OccParser a -> OccParser b -> OccParser c -> OccParser b tryXVX a b c = try (do { a; bv <- b; c; return bv }) +tryVXV :: OccParser a -> OccParser b -> OccParser c -> OccParser (a, c) +tryVXV a b c = try (do { av <- a; b; cv <- c; return (av, cv) }) + maybeSubscripted :: String -> OccParser a -> (Meta -> A.Subscript -> a -> a) -> (a -> OccParser A.Type) -> OccParser a maybeSubscripted prodName inner subscripter typer = do m <- md @@ -424,20 +427,20 @@ scopeOut n@(A.Name m nt s) -- FIXME: Do these with generics? (going carefully to avoid nested code blocks) scopeInRep :: A.Replicator -> OccParser A.Replicator -scopeInRep r@(A.For m n b c) +scopeInRep (A.For m n b c) = do n' <- scopeIn n (A.Declaration m A.Int) A.ValAbbrev return $ A.For m n' b c scopeOutRep :: A.Replicator -> OccParser () -scopeOutRep r@(A.For m n b c) = scopeOut n +scopeOutRep (A.For m n b c) = scopeOut n scopeInSpec :: A.Specification -> OccParser A.Specification -scopeInSpec s@(n, st) +scopeInSpec (A.Specification n st) = do n' <- scopeIn n st (abbrevModeOfSpec st) - return (n', st) + return $ A.Specification n' st scopeOutSpec :: A.Specification -> OccParser () -scopeOutSpec s@(n, st) = scopeOut n +scopeOutSpec (A.Specification n st) = scopeOut n scopeInFormal :: A.Formal -> OccParser A.Formal scopeInFormal (A.Formal am t n) @@ -814,12 +817,12 @@ replicator --{{{ specifications, declarations, allocations allocation :: OccParser [A.Specification] allocation - = do { m <- md; sPLACE; n <- variableName; sAT; e <- intExpr; sColon; eol; return [(n, A.Place m e)] } + = do { m <- md; sPLACE; n <- variableName; sAT; e <- intExpr; sColon; eol; return [A.Specification n (A.Place m e)] } "allocation" specification :: OccParser [A.Specification] specification - = try (do { (ns, d) <- declaration; return [(n, d) | n <- ns] }) + = try (do { (ns, d) <- declaration; return [A.Specification n d | n <- ns] }) <|> try (do { a <- abbreviation; return [a] }) <|> do { d <- definition; return [d] } "specification" @@ -835,37 +838,37 @@ declaration abbreviation :: OccParser A.Specification abbreviation = do m <- md - (do { (n, v) <- try (do { n <- newVariableName; sIS; v <- variable; return (n, v) }); sColon; eol; t <- pTypeOfVariable v; return (n, A.Is m A.Abbrev t v) } - <|> do { (s, n, v) <- try (do { s <- specifier; n <- newVariableName; sIS; v <- variable; return (s, n, v) }); sColon; eol; t <- pTypeOfVariable v; matchType s t; return (n, A.Is m A.Abbrev s v) } + (do { (n, v) <- tryVXV newVariableName sIS variable; sColon; eol; t <- pTypeOfVariable v; return $ A.Specification n $ A.Is m A.Abbrev t v } + <|> do { (s, n, v) <- try (do { s <- specifier; n <- newVariableName; sIS; v <- variable; return (s, n, v) }); sColon; eol; t <- pTypeOfVariable v; matchType s t; return $ A.Specification n $ A.Is m A.Abbrev s v } <|> do { sVAL ; - do { (n, e) <- try (do { n <- newVariableName; sIS; e <- expression; return (n, e) }); sColon; eol; t <- pTypeOfExpression e; return (n, A.IsExpr m A.ValAbbrev t e) } - <|> do { s <- specifier; n <- newVariableName; sIS; e <- expression; sColon; eol; t <- pTypeOfExpression e; matchType s t; return (n, A.IsExpr m A.ValAbbrev s e) } } - <|> try (do { n <- newChannelName; sIS; c <- channel; sColon; eol; t <- pTypeOfVariable c; return (n, A.Is m A.Abbrev t c) }) - <|> try (do { n <- newTimerName; sIS; c <- timer; sColon; eol; t <- pTypeOfVariable c; return (n, A.Is m A.Abbrev t c) }) - <|> try (do { n <- newPortName; sIS; c <- port; sColon; eol; t <- pTypeOfVariable c; return (n, A.Is m A.Abbrev t c) }) - <|> try (do { s <- specifier; n <- newChannelName; sIS; c <- channel; sColon; eol; t <- pTypeOfVariable c; matchType s t; return (n, A.Is m A.Abbrev s c) }) - <|> try (do { s <- specifier; n <- newTimerName; sIS; c <- timer; sColon; eol; t <- pTypeOfVariable c; matchType s t; return (n, A.Is m A.Abbrev s c) }) - <|> try (do { s <- specifier; n <- newPortName; sIS; c <- port; sColon; eol; t <- pTypeOfVariable c; matchType s t; return (n, A.Is m A.Abbrev s c) }) - <|> try (do { n <- newChannelName; sIS; sLeft; cs <- sepBy1 channel sComma; sRight; sColon; eol; ts <- mapM pTypeOfVariable cs; t <- listType m ts; return (n, A.IsChannelArray m t cs) }) - <|> try (do { s <- specifier; n <- newChannelName; sIS; sLeft; cs <- sepBy1 channel sComma; sRight; sColon; eol; ts <- mapM pTypeOfVariable cs; t <- listType m ts; matchType s t; return (n, A.IsChannelArray m s cs) })) + do { (n, e) <- try (do { n <- newVariableName; sIS; e <- expression; return (n, e) }); sColon; eol; t <- pTypeOfExpression e; return $ A.Specification n $ A.IsExpr m A.ValAbbrev t e } + <|> do { s <- specifier; n <- newVariableName; sIS; e <- expression; sColon; eol; t <- pTypeOfExpression e; matchType s t; return $ A.Specification n $ A.IsExpr m A.ValAbbrev s e } } + <|> try (do { n <- newChannelName; sIS; c <- channel; sColon; eol; t <- pTypeOfVariable c; return $ A.Specification n $ A.Is m A.Abbrev t c }) + <|> try (do { n <- newTimerName; sIS; c <- timer; sColon; eol; t <- pTypeOfVariable c; return $ A.Specification n $ A.Is m A.Abbrev t c }) + <|> try (do { n <- newPortName; sIS; c <- port; sColon; eol; t <- pTypeOfVariable c; return $ A.Specification n $ A.Is m A.Abbrev t c }) + <|> try (do { s <- specifier; n <- newChannelName; sIS; c <- channel; sColon; eol; t <- pTypeOfVariable c; matchType s t; return $ A.Specification n $ A.Is m A.Abbrev s c }) + <|> try (do { s <- specifier; n <- newTimerName; sIS; c <- timer; sColon; eol; t <- pTypeOfVariable c; matchType s t; return $ A.Specification n $ A.Is m A.Abbrev s c }) + <|> try (do { s <- specifier; n <- newPortName; sIS; c <- port; sColon; eol; t <- pTypeOfVariable c; matchType s t; return $ A.Specification n $ A.Is m A.Abbrev s c }) + <|> try (do { n <- newChannelName; sIS; sLeft; cs <- sepBy1 channel sComma; sRight; sColon; eol; ts <- mapM pTypeOfVariable cs; t <- listType m ts; return $ A.Specification n $ A.IsChannelArray m t cs }) + <|> try (do { s <- specifier; n <- newChannelName; sIS; sLeft; cs <- sepBy1 channel sComma; sRight; sColon; eol; ts <- mapM pTypeOfVariable cs; t <- listType m ts; matchType s t; return $ A.Specification n $ A.IsChannelArray m s cs })) "abbreviation" definition :: OccParser A.Specification definition = do { m <- md; sDATA; sTYPE; n <- newDataTypeName ; - do {sIS; t <- dataType; sColon; eol; return (n, A.DataType m t) } - <|> do { eol; indent; rec <- structuredType; outdent; sColon; eol; return (n, rec) } } + do {sIS; t <- dataType; sColon; eol; return $ A.Specification n (A.DataType m t) } + <|> do { eol; indent; rec <- structuredType; outdent; sColon; eol; return $ A.Specification n rec } } <|> do { m <- md; sPROTOCOL; n <- newProtocolName ; - do { sIS; p <- sequentialProtocol; sColon; eol; return (n, A.Protocol m p) } - <|> do { eol; indent; sCASE; eol; indent; ps <- many1 taggedProtocol; outdent; outdent; sColon; eol; return (n, A.ProtocolCase m ps) } } - <|> do { m <- md; sPROC; n <- newProcName; fs <- formalList; eol; indent; fs' <- scopeInFormals fs; p <- process; scopeOutFormals fs'; outdent; sColon; eol; return (n, A.Proc m fs' p) } + do { sIS; p <- sequentialProtocol; sColon; eol; return $ A.Specification n $ A.Protocol m p } + <|> do { eol; indent; sCASE; eol; indent; ps <- many1 taggedProtocol; outdent; outdent; sColon; eol; return $ A.Specification n $ A.ProtocolCase m ps } } + <|> do { m <- md; sPROC; n <- newProcName; fs <- formalList; eol; indent; fs' <- scopeInFormals fs; p <- process; scopeOutFormals fs'; outdent; sColon; eol; return $ A.Specification n $ A.Proc m fs' p } <|> try (do { m <- md; rs <- sepBy1 dataType sComma; (n, fs) <- functionHeader ; - do { sIS; fs' <- scopeInFormals fs; el <- expressionList; scopeOutFormals fs'; sColon; eol; return (n, A.Function m rs fs' (A.ValOf m (A.Skip m) el)) } - <|> do { eol; indent; fs' <- scopeInFormals fs; vp <- valueProcess; scopeOutFormals fs'; outdent; sColon; eol; return (n, A.Function m rs fs' vp) } }) + do { sIS; fs' <- scopeInFormals fs; el <- expressionList; scopeOutFormals fs'; sColon; eol; return $ A.Specification n $ A.Function m rs fs' (A.ValOf m (A.Skip m) el) } + <|> do { eol; indent; fs' <- scopeInFormals fs; vp <- valueProcess; scopeOutFormals fs'; outdent; sColon; eol; return $ A.Specification n $ A.Function m rs fs' vp } }) <|> try (do { m <- md; s <- specifier; n <- newVariableName ; - sRETYPES <|> sRESHAPES; v <- variable; sColon; eol; return (n, A.Retypes m A.Abbrev s v) }) + sRETYPES <|> sRESHAPES; v <- variable; sColon; eol; return $ A.Specification n $ A.Retypes m A.Abbrev s v }) <|> try (do { m <- md; sVAL; s <- specifier; n <- newVariableName ; - sRETYPES <|> sRESHAPES; e <- expression; sColon; eol; return (n, A.RetypesExpr m A.ValAbbrev s e) }) + sRETYPES <|> sRESHAPES; e <- expression; sColon; eol; return $ A.Specification n $ A.RetypesExpr m A.ValAbbrev s e }) "definition" dataSpecifier :: OccParser A.Type diff --git a/fco2/ParseState.hs b/fco2/ParseState.hs index 90b6397..6b81d43 100644 --- a/fco2/ParseState.hs +++ b/fco2/ParseState.hs @@ -76,7 +76,7 @@ defineNonce m s st nt am A.ndAbbrevMode = am } modify $ psDefineName n nd - return (n, st) + return $ A.Specification n st -- | Generate and define a no-arg wrapper PROC around a process. makeNonceProc :: MonadState ParseState m => Meta -> A.Process -> m A.Specification diff --git a/fco2/SimplifyExprs.hs b/fco2/SimplifyExprs.hs index 16a56c9..725f0cc 100644 --- a/fco2/SimplifyExprs.hs +++ b/fco2/SimplifyExprs.hs @@ -52,7 +52,7 @@ pullUp = doGeneric `extM` doProcess `extM` doExpression `extM` doActual pull t e = do -- FIXME Should get Meta from somewhere... let m = [] - spec@(n, _) <- makeNonceIsExpr "array_expr" m t e + spec@(A.Specification n _) <- makeNonceIsExpr "array_expr" m t e addPulled $ A.ProcSpec m spec return $ A.ExprVariable m (A.Variable m n) @@ -76,7 +76,7 @@ pullUp = doGeneric `extM` doProcess `extM` doExpression `extM` doActual where pull :: Meta -> A.AbbrevMode -> A.Type -> A.Variable -> PassM A.Variable pull m am t v - = do spec@(n, _) <- makeNonceIs "subscript_actual" m t am v + = do spec@(A.Specification n _) <- makeNonceIs "subscript_actual" m t am v addPulled $ A.ProcSpec m spec return $ A.Variable m n doActual a = doGeneric a diff --git a/fco2/Unnest.hs b/fco2/Unnest.hs index 1d4e502..34c7e1f 100644 --- a/fco2/Unnest.hs +++ b/fco2/Unnest.hs @@ -26,12 +26,12 @@ parsToProcs = doGeneric `extM` doProcess doProcess (A.Par m pm ps) = do ps' <- mapM parsToProcs ps procs <- mapM (makeNonceProc m) ps' - let calls = [A.ProcSpec m s (A.ProcCall m n []) | s@(n, _) <- procs] + let calls = [A.ProcSpec m s (A.ProcCall m n []) | s@(A.Specification n _) <- procs] return $ A.Par m pm calls doProcess (A.ParRep m pm rep p) = do p' <- parsToProcs p rep' <- parsToProcs rep - s@(n, _) <- makeNonceProc m p' + s@(A.Specification n _) <- makeNonceProc m p' let call = A.ProcSpec m s (A.ProcCall m n []) return $ A.ParRep m pm rep' call doProcess p = doGeneric p @@ -65,7 +65,7 @@ freeNamesIn = doGeneric `extQ` doName `extQ` doProcess `extQ` doStructured `extQ doValueProcess vp = doGeneric vp doSpec :: Data t => A.Specification -> t -> NameMap - doSpec (n, st) child + doSpec (A.Specification n st) child = Map.union fns $ Map.delete (A.nameName n) $ freeNamesIn child where fns = freeNamesIn st @@ -129,7 +129,7 @@ removeFreeNames = doGeneric `extM` doProcess `extM` doStructured `extM` doValueP doSpec :: Data t => Meta -> A.Specification -> t -> PassM (A.Specification, t) doSpec m spec child = case spec of - (n, st@(A.Proc m fs p)) -> + A.Specification n st@(A.Proc m fs p) -> do -- Figure out the free names let allFreeNames = Map.elems $ freeNamesIn st @@ -156,7 +156,7 @@ removeFreeNames = doGeneric `extM` doProcess `extM` doStructured `extM` doValueP let newFs = [A.Formal am t n | (am, t, n) <- zip3 ams types newNames] p' <- removeFreeNames $ replaceNames (zip freeNames newNames) p let st' = A.Proc m (fs ++ newFs) p' - let spec' = (n, st') + let spec' = A.Specification n st' -- Update the definition of the proc let nameDef = fromJust $ psLookupName ps n modify $ psDefineName n (nameDef { A.ndType = st' }) @@ -197,7 +197,7 @@ removeNesting p doValueProcess vp = doGeneric vp doSpec :: Data t => t -> Meta -> A.Specification -> t -> PassM t - doSpec orig m spec@(_, st) child + doSpec orig m spec@(A.Specification _ st) child = if canPull st then do spec' <- pullSpecs spec addPulled $ A.ProcSpec m spec'