From 6085cae11fca8a18d3e5893eefe5a9db4f508a6c Mon Sep 17 00:00:00 2001 From: Adam Sampson Date: Tue, 10 Apr 2007 22:12:53 +0000 Subject: [PATCH] Use AbbrevMode to track whether things are abbreviated, and thus generate C --- fco2/AST.hs | 6 +- fco2/GenerateC.hs | 150 +++++++++++++++++++++++-------------- fco2/Parse.hs | 45 +++++++++-- fco2/Types.hs | 17 ++--- fco2/testcases/actuals.occ | 12 +++ 5 files changed, 156 insertions(+), 74 deletions(-) create mode 100644 fco2/testcases/actuals.occ diff --git a/fco2/AST.hs b/fco2/AST.hs index 6fca466..14d3013 100644 --- a/fco2/AST.hs +++ b/fco2/AST.hs @@ -171,7 +171,8 @@ data InputMode = deriving (Show, Eq, Typeable, Data) data AbbrevMode = - Abbrev + Original + | Abbrev | ValAbbrev deriving (Show, Eq, Typeable, Data) @@ -198,8 +199,9 @@ data Formal = deriving (Show, Eq, Typeable, Data) data Actual = - ActualExpression Expression + ActualVariable Variable | ActualChannel Channel + | ActualExpression Expression deriving (Show, Eq, Typeable, Data) data ValueProcess = diff --git a/fco2/GenerateC.hs b/fco2/GenerateC.hs index 4c3222a..247960d 100644 --- a/fco2/GenerateC.hs +++ b/fco2/GenerateC.hs @@ -1,23 +1,26 @@ --- | Generate C++ code from the mangled AST. +-- | Generate C code from the mangled AST. module GenerateC where --- FIXME: Use AbbrevMode to track whether something is an abbreviation at all --- (and hence make it a pointer or not -- so we can go to C proper). - -- FIXME: Use Structured for Par and Seq (and ValOf, etc.). This would make it -- easier to put {} around sets of declarations. -- 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: There should be a pass that pulls PAR branches (that aren't already --- PROC calls) out into PROCs. - -- FIXME: Arrays. Should be a struct that contains the data and size, and we -- then use a pointer to the struct to pass around. -- FIXME: The show instance for types should produce occam-looking types. +-- FIXME: Should have a "current type context" in the parser, so that +-- VAL BYTE b IS 4: works correctly. + +-- FIXME: Tock would be a good name for this (Translator from occam to C from Kent). + +-- 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). + import Data.List import Data.Maybe import Control.Monad.Writer @@ -59,6 +62,10 @@ withPS :: (ParseState -> a) -> CGen a withPS f = do st <- get return $ f st + +checkJust :: Maybe t -> CGen t +checkJust (Just v) = return v +checkJust Nothing = fail "checkJust failed" --}}} --{{{ names @@ -91,10 +98,23 @@ genType (A.Chan t) genType t = missing $ "genType " ++ show t --}}} ---{{{ abbreviations -genConst :: A.AbbrevMode -> CGen () -genConst A.Abbrev = return () -genConst A.ValAbbrev = tell ["const "] +--{{{ declarations +genDeclType :: A.AbbrevMode -> A.Type -> CGen () +genDeclType am t + = do case am of + 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 + = do genDeclType am t + tell [" "] + genName n --}}} --{{{ conversions @@ -153,12 +173,41 @@ 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] / +-} genChannel :: A.Channel -> CGen () -genChannel (A.Channel m n) = genName n +genChannel (A.Channel m n) + = do ps <- get + am <- checkJust $ abbrevModeOfName ps n + case am of + A.Original -> tell ["&"] + A.Abbrev -> return () + genName n 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] / +-} genVariable :: A.Variable -> CGen () -genVariable (A.Variable m n) = genName n +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 () genVariable (A.SubscriptedVariable m s v) = genSubscript s (genVariable v) --}}} @@ -249,7 +298,7 @@ genInputItem c (A.InCounted m cv av) missing "genInputItem counted" genInputItem c (A.InVariable m v) = do ps <- get - let t = fromJust $ typeOfVariable ps v + t <- checkJust $ typeOfVariable ps v case t of A.Int -> do tell ["ChanInInt ("] @@ -273,7 +322,7 @@ genOutputItem c (A.OutCounted m ce ae) genOutputItem c (A.OutExpression m e) = do n <- makeNonce "output_item" ps <- get - let t = fromJust $ typeOfExpression ps e + t <- checkJust $ typeOfExpression ps e case t of A.Int -> do tell ["ChanOutInt ("] @@ -333,49 +382,43 @@ genSpec spec body body removeSpec spec +-- FIXME This needs to be rather smarter than it is -- in particular, +-- when declaring arrays of things (like channels) it needs to make sure +-- they're initialised. Probably split into declare/init parts so that +-- it can just recurse sensibly. introduceSpec :: A.Specification -> CGen () -introduceSpec (n, A.Declaration m A.Timer) = return () introduceSpec (n, A.Declaration m t) - = do case t of - A.Chan _ -> - do cn <- makeNonce "channel" - tell ["Channel ", cn, ";\n"] - tell ["ChanInit (&", cn, ");\n"] - tell ["Channel *"] - genName n - tell [" = &", cn, ";\n"] - _ -> - do genType t - tell [" "] - genName n - tell [";\n"] + = case t of + A.Timer -> return () + A.Chan _ -> + do tell ["Channel "] + genName n + tell [";\n"] + tell ["ChanInit (&"] + genName n + tell [");\n"] + _ -> + do genDeclType A.Original t + tell [" "] + genName n + tell [";\n"] introduceSpec (n, A.Is m am t v) - = do genConst am - genType t - tell ["& "] - genName n - tell [" = "] + = do genDecl am t n + tell [" = &"] genVariable v tell [";\n"] introduceSpec (n, A.IsExpr m am t e) - = do genConst am - genType t - tell [" "] - genName n + = do genDecl am t n tell [" = "] genExpression e tell [";\n"] introduceSpec (n, A.IsChannel m t c) - = do genType t - tell [" "] - genName n + = do genDecl A.Abbrev t n tell [" = "] genChannel c tell [";\n"] introduceSpec (n, A.IsChannelArray m t cs) - = do genType t - tell [" "] - genName n + = do genDecl A.Abbrev t n tell [" = {"] sequence_ $ intersperse genComma (map genChannel cs) tell ["};\n"] @@ -401,6 +444,9 @@ genActuals as = sequence_ $ intersperse genComma (map genActual as) genActual :: A.Actual -> CGen () genActual (A.ActualExpression e) = genExpression e genActual (A.ActualChannel c) = genChannel c +genActual (A.ActualVariable v) + = do tell ["&"] + genVariable v genFormals :: [A.Formal] -> CGen () genFormals fs = sequence_ $ intersperse genComma (map genFormal fs) @@ -408,14 +454,8 @@ genFormals fs = sequence_ $ intersperse genComma (map genFormal fs) -- Arrays must be handled specially genFormal :: A.Formal -> CGen () genFormal (A.Formal am t n) - = do case am of - A.ValAbbrev -> - do genConst am - genType t - tell [" "] - A.Abbrev -> - do genType t - tell ["& "] + = do genDeclType am t + tell [" "] genName n --}}} @@ -459,8 +499,8 @@ genAssign vs el do tell ["{\n"] ns <- mapM (\_ -> makeNonce "assign_tmp") vs mapM (\(v, n, e) -> do st <- get - let t = typeOfVariable st v - genType (fromJust t) + t <- checkJust $ typeOfVariable st v + genType t tell [" ", n, " = "] genExpression e tell [";\n"]) @@ -473,7 +513,7 @@ genAssign vs el genInput :: A.Channel -> A.InputMode -> CGen () genInput c im = do ps <- get - let t = fromJust $ typeOfChannel ps c + t <- checkJust $ typeOfChannel ps c case t of A.Timer -> case im of A.InputSimple m [A.InVariable m' v] -> genTimerRead v diff --git a/fco2/Parse.hs b/fco2/Parse.hs index 74e5fd8..f080521 100644 --- a/fco2/Parse.hs +++ b/fco2/Parse.hs @@ -266,7 +266,7 @@ handleSpecs specs inner specMarker mapM scopeOutSpec ss' return $ foldl (\e s -> specMarker m s e) v ss' --- Like sepBy1, but not eager: it won't consume the separator unless it finds +-- | Like sepBy1, but not eager: it won't consume the separator unless it finds -- another item after it. sepBy1NE :: OccParser a -> OccParser b -> OccParser [a] sepBy1NE item sep @@ -275,6 +275,20 @@ sepBy1NE item sep sepBy1NE item sep) return $ i : rest +-- | Run several different parsers with a separator between them. +-- If you give it [a, b, c] and s, it'll parse [a, s, b, s, c] then +-- give you back the results from [a, b, c]. +intersperseP :: [OccParser a] -> OccParser b -> OccParser [a] +intersperseP [] _ = return [] +intersperseP [f] _ + = do a <- f + return [a] +intersperseP (f:fs) sep + = do a <- f + sep + as <- intersperseP fs sep + return $ a : as + tryTrail :: OccParser a -> OccParser b -> OccParser a tryTrail p q = try (do { v <- p; q; return v }) @@ -296,7 +310,7 @@ checkMaybe msg op Just t -> return t Nothing -> fail msg -pTypeOf :: (ParseState -> a -> Maybe A.Type) -> a -> OccParser A.Type +pTypeOf :: (ParseState -> a -> Maybe b) -> a -> OccParser b pTypeOf f item = do st <- getState case f st item of @@ -306,6 +320,7 @@ pTypeOf f item pTypeOfVariable = pTypeOf typeOfVariable pTypeOfChannel = pTypeOf typeOfChannel pTypeOfExpression = pTypeOf typeOfExpression +pSpecTypeOfName = pTypeOf specTypeOfName --}}} --{{{ name scoping @@ -1170,14 +1185,28 @@ guard --{{{ PROC calls procInstance :: OccParser A.Process procInstance - = do { m <- md; n <- tryTrail procName sLeftR; as <- sepBy actual sComma; sRightR; eol; return $ A.ProcCall m n as } + = do m <- md + n <- tryTrail procName sLeftR + st <- pSpecTypeOfName n + let fs = case st of A.Proc _ fs _ -> fs + as <- actuals fs + sRightR + eol + return $ A.ProcCall m n as "procInstance" -actual :: OccParser A.Actual -actual - = try (do { e <- expression; return $ A.ActualExpression e }) - <|> try (do { c <- channel; return $ A.ActualChannel c }) - "actual" +actuals :: [A.Formal] -> OccParser [A.Actual] +actuals fs = intersperseP (map actual fs) sComma + +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 + where + an = A.nameName n --}}} --}}} --{{{ top-level forms diff --git a/fco2/Types.hs b/fco2/Types.hs index 688d052..234b965 100644 --- a/fco2/Types.hs +++ b/fco2/Types.hs @@ -1,18 +1,13 @@ -- | Type inference and checking. module Types where +import Control.Monad + import qualified AST as A import ParseState --- I'm pretty sure this is in the standard library, but I can't find it! -perhapsM :: Maybe a -> (a -> Maybe b) -> Maybe b -perhapsM m f - = case m of - Just v -> f v - _ -> Nothing - perhaps :: Maybe a -> (a -> b) -> Maybe b -perhaps m f = m `perhapsM` (Just . f) +perhaps m f = m >>= (Just . f) -- FIXME: Eww, this shouldn't be necessary -- the lookups should really work on -- Strings. @@ -30,6 +25,10 @@ specTypeOfName :: ParseState -> A.Name -> Maybe A.SpecType specTypeOfName ps n = (psLookupName ps n) `perhaps` A.ndType +abbrevModeOfName :: ParseState -> A.Name -> Maybe A.AbbrevMode +abbrevModeOfName ps n + = (psLookupName ps n) `perhaps` A.ndAbbrevMode + typeOfName :: ParseState -> A.Name -> Maybe A.Type typeOfName ps n = case specTypeOfName ps n of @@ -108,5 +107,5 @@ abbrevModeOfSpec s A.IsChannelArray _ _ _ -> A.Abbrev A.Retypes _ am _ _ -> am A.RetypesExpr _ am _ _ -> am - _ -> A.ValAbbrev + _ -> A.Original diff --git a/fco2/testcases/actuals.occ b/fco2/testcases/actuals.occ new file mode 100644 index 0000000..360a90e --- /dev/null +++ b/fco2/testcases/actuals.occ @@ -0,0 +1,12 @@ +-- FIXME This should check arrays too. +PROC O (VAL INT val1, val2, INT abbr, CHAN OF INT channel) + SKIP +: +PROC P (VAL INT val1, val2, INT abbr, CHAN OF INT channel) + O (val1, val2, abbr, channel) +: +PROC Q () + INT x, y: + CHAN OF INT c: + P (42, x, y, c) +: