A start at generating C++ code

This commit is contained in:
Adam Sampson 2007-04-06 23:12:21 +00:00
parent 222ba593c7
commit 572fa26ad7
8 changed files with 571 additions and 7 deletions

490
fco2/GenerateC.hs Normal file
View File

@ -0,0 +1,490 @@
-- vim:foldmethod=marker
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: There should be an earlier pass across the AST that resolves Infer
-- types.
import Data.List
import Data.Maybe
import Control.Monad.Writer
import Control.Monad.Error
import Control.Monad.State
import AST
import Metadata
import ParseState
import Errors
import Types
--{{{ monad definition
type CGen a = WriterT [String] (ErrorT String (StateT ParseState IO)) a
--}}}
--{{{ top-level
generateC :: ParseState -> Process -> IO String
generateC st ast
= do v <- evalStateT (runErrorT (runWriterT (genTopLevel ast))) st
case v of
Left e -> die e
Right (_, ss) -> return $ concat ss
genTopLevel :: Process -> CGen ()
genTopLevel p
= do tell ["#include <fco_support.h>\n"]
genProcess p
--}}}
--{{{ utilities
missing :: String -> CGen ()
missing s = tell ["\nUnimplemented: ", s, "\n"]
genComma :: CGen ()
genComma = tell [", "]
makeNonce :: CGen String
makeNonce
= do st <- get
let i = psNonceCounter st
put $ st { psNonceCounter = i + 1 }
return $ "nonce_" ++ show i
withPS :: (ParseState -> a) -> CGen a
withPS f
= do st <- get
return $ f st
--}}}
--{{{ names
genName :: Name -> CGen ()
genName n = tell [[if c == '.' then '_' else c | c <- nameName n]]
--}}}
--{{{ types
genType :: Type -> CGen ()
genType Bool = tell ["bool"]
-- FIXME: This probably isn't right; we might have to explicitly cast string literals...
genType Byte = tell ["char"]
genType Int = tell ["int"]
genType Int16 = tell ["int16_t"]
genType Int32 = tell ["int32_t"]
genType Int64 = tell ["int64_t"]
genType Real32 = tell ["float"]
genType Real64 = tell ["double"]
genType (Array e t)
= do genType t
tell ["["]
genExpression e
tell ["]"]
genType (ArrayUnsized t)
= do genType t
tell ["[]"]
genType (UserDataType n) = genName n
genType (Chan t)
= do tell ["Channel*"]
genType (Val t)
= do tell ["const "]
genType t
genType t = missing $ "genType " ++ show t
--}}}
--{{{ conversions
genConversion :: ConversionMode -> Type -> Expression -> CGen ()
genConversion DefaultConversion t e
= do tell ["(("]
genType t
tell [") "]
genExpression e
tell [")"]
genConversion cm t e = missing $ "genConversion " ++ show cm
--}}}
--{{{ subscripts
genSubscript :: Subscript -> CGen () -> CGen ()
genSubscript (Subscript m e) p
= do p
tell ["["]
genExpression e
tell ["]"]
genSubscript (SubscriptTag m n) p
= do p
tell ["."]
genName n
genSubscript s p = missing $ "genSubscript " ++ show s
--}}}
--{{{ literals
genLiteral :: Literal -> CGen ()
genLiteral (Literal m t lr) = genLiteralRepr lr
genLiteral l = missing $ "genLiteral " ++ show l
genLiteralRepr :: LiteralRepr -> CGen ()
genLiteralRepr (RealLiteral m s) = tell [s]
genLiteralRepr (IntLiteral m s) = tell [s]
genLiteralRepr (HexLiteral m s) = case s of ('#':rest) -> tell ["0x", rest]
genLiteralRepr (ByteLiteral m s) = tell ["'", convStringLiteral s, "'"]
genLiteralRepr (StringLiteral m s) = tell ["\"", convStringLiteral s, "\""]
genLiteralRepr (ArrayLiteral m es)
= do tell ["{"]
sequence_ $ intersperse genComma (map genExpression es)
tell ["}"]
convStringLiteral :: String -> String
convStringLiteral [] = []
convStringLiteral ('*':'#':a:b:s) = "\\x" ++ [a, b] ++ convStringLiteral s
convStringLiteral ('*':c:s) = convStringStar c ++ convStringLiteral s
convStringLiteral (c:s) = c : convStringLiteral s
convStringStar :: Char -> String
convStringStar 'c' = "\\r"
convStringStar 'n' = "\\n"
convStringStar 't' = "\\t"
convStringStar 's' = " "
convStringStar c = [c]
--}}}
--{{{ channels, variables
genChannel :: Channel -> CGen ()
genChannel (Channel m n) = genName n
genChannel (SubscriptedChannel m s c) = genSubscript s (genChannel c)
genVariable :: Variable -> CGen ()
genVariable (Variable m n) = genName n
genVariable (SubscriptedVariable m s v) = genSubscript s (genVariable v)
--}}}
--{{{ expressions
genExpression :: Expression -> CGen ()
genExpression (Monadic m op e) = genMonadic op e
genExpression (Dyadic m op e f) = genDyadic op e f
genExpression (MostPos m t) = genTypeConstant "mostpos" t
genExpression (MostNeg m t) = genTypeConstant "mostneg" t
--genExpression (Size m t)
genExpression (Conversion m cm t e) = genConversion cm t e
genExpression (ExprVariable m v) = genVariable v
genExpression (ExprLiteral m l) = genLiteral l
genExpression (AST.True m) = tell ["true"]
genExpression (AST.False m) = tell ["false"]
--genExpression (FunctionCall m n es)
--genExpression (SubscriptedExpr m s e)
--genExpression (BytesInExpr m e)
genExpression (BytesInType m t)
= do tell ["sizeof ("]
genType t
tell [")"]
--genExpression (OffsetOf m t n)
genExpression t = missing $ "genExpression " ++ show t
genTypeConstant :: String -> Type -> CGen ()
genTypeConstant s t = missing $ "genTypeConstant " ++ show t
--}}}
--{{{ operators
genSimpleMonadic :: String -> Expression -> CGen ()
genSimpleMonadic s e
= do tell ["(", s]
genExpression e
tell [")"]
genMonadic :: MonadicOp -> Expression -> CGen ()
genMonadic MonadicSubtr e = genSimpleMonadic "-" e
genMonadic MonadicBitNot e = genSimpleMonadic "~" e
genMonadic MonadicNot e = genSimpleMonadic "!" e
--genMonadic MonadicSize e
genMonadic op e = missing $ "genMonadic " ++ show op
genSimpleDyadic :: String -> Expression -> Expression -> CGen ()
genSimpleDyadic s e f
= do tell ["("]
genExpression e
tell [" ", s, " "]
genExpression f
tell [")"]
genFuncDyadic :: String -> Expression -> Expression -> CGen ()
genFuncDyadic s e f
= do tell [s, " ("]
genExpression e
tell [", "]
genExpression f
tell [")"]
genDyadic :: DyadicOp -> Expression -> Expression -> CGen ()
genDyadic Add e f = genFuncDyadic "occam_add" e f
genDyadic Subtr e f = genFuncDyadic "occam_subtr" e f
genDyadic Mul e f = genFuncDyadic "occam_mul" e f
genDyadic Div e f = genFuncDyadic "occam_div" e f
genDyadic Rem e f = genFuncDyadic "occam_rem" e f
genDyadic Plus e f = genSimpleDyadic "+" e f
genDyadic Minus e f = genSimpleDyadic "-" e f
genDyadic Times e f = genSimpleDyadic "*" e f
genDyadic BitAnd e f = genSimpleDyadic "&" e f
genDyadic BitOr e f = genSimpleDyadic "|" e f
genDyadic BitXor e f = genSimpleDyadic "^" e f
genDyadic And e f = genSimpleDyadic "&&" e f
genDyadic Or e f = genSimpleDyadic "||" e f
genDyadic Eq e f = genSimpleDyadic "==" e f
genDyadic NotEq e f = genSimpleDyadic "!=" e f
genDyadic Less e f = genSimpleDyadic "<" e f
genDyadic More e f = genSimpleDyadic ">" e f
genDyadic LessEq e f = genSimpleDyadic "<=" e f
genDyadic MoreEq e f = genSimpleDyadic ">=" e f
genDyadic After e f = genFuncDyadic "occam_after" e f
--}}}
--{{{ input/output items
genInputItem :: Channel -> InputItem -> CGen ()
genInputItem c (InCounted m cv av)
= do genInputItem c (InVariable m cv)
-- need to then input as much as appropriate
missing "genInputItem counted"
genInputItem c (InVariable m v)
= do ps <- get
let t = fromJust $ typeOfVariable ps v
case t of
Int ->
do tell ["ChanInInt ("]
genChannel c
tell [", &"]
genVariable v
tell [");\n"]
_ ->
do tell ["ChanIn ("]
genChannel c
tell [", &"]
genVariable v
tell [", sizeof ("]
genType t
tell ["));\n"]
genOutputItem :: Channel -> OutputItem -> CGen ()
genOutputItem c (OutCounted m ce ae)
= do genOutputItem c (OutExpression m ce)
missing "genOutputItem counted"
genOutputItem c (OutExpression m e)
= do n <- makeNonce
ps <- get
let t = fromJust $ typeOfExpression ps e
case t of
Int ->
do tell ["ChanOutInt ("]
genChannel c
tell [", "]
genExpression e
tell [");\n"]
_ ->
do tell ["{\n"]
genType t
tell [" ", n, " = "]
genExpression e
tell [";\n"]
tell ["ChanOut ("]
genChannel c
tell [", &", n, ", sizeof ("]
genType t
tell ["));\n"]
tell ["}\n"]
--}}}
--{{{ replicators
--}}}
--{{{ choice/alternatives/options/variants
--}}}
--{{{ structured
--}}}
--{{{ specifications
genSpec :: Meta -> Specification -> CGen () -> CGen ()
genSpec m spec body
= do introduceSpec spec
body
removeSpec spec
introduceSpec :: Specification -> CGen ()
introduceSpec (n, Declaration m Timer) = return ()
introduceSpec (n, Declaration m t)
= do case t of
Chan _ -> do cn <- makeNonce
tell ["Channel ", cn, ";\n"]
tell ["ChanInit (&", cn, ");\n"]
tell ["Channel *"]
genName n
tell [" = &", cn, ";\n"]
_ -> do genType t
tell [" "]
genName n
tell [";\n"]
introduceSpec (n, Is m t v)
= do genType t
tell ["& "]
genName n
tell [" = "]
genVariable v
tell [";\n"]
introduceSpec (n, ValIs m t e)
= do tell ["const "]
genType t
tell [" "]
genName n
tell [" = "]
genExpression e
tell [";\n"]
introduceSpec (n, IsChannel m t c)
= do genType t
tell [" "]
genName n
tell [" = "]
genChannel c
tell [";\n"]
introduceSpec (n, IsChannelArray m t cs)
= do genType t
tell [" "]
genName n
tell [" = {"]
sequence_ $ intersperse genComma (map genChannel cs)
tell ["};\n"]
introduceSpec (n, Proc m fs p)
= do tell ["void "]
genName n
tell [" ("]
genFormals fs
tell [") {\n"]
genProcess p
tell ["}\n"]
-- CASE protocol should generate an enum for the tags
introduceSpec (n, t) = missing $ "introduceSpec " ++ show t
removeSpec :: Specification -> CGen ()
removeSpec _ = return ()
--}}}
--{{{ actuals/formals
genActuals :: [Actual] -> CGen ()
genActuals as = sequence_ $ intersperse genComma (map genActual as)
genActual :: Actual -> CGen ()
genActual (ActualExpression e) = genExpression e
genActual (ActualChannel c) = genChannel c
genFormals :: Formals -> CGen ()
genFormals fs = sequence_ $ intersperse genComma (map genFormal fs)
-- Arrays must be handled specially
genFormal :: (Type, Name) -> CGen ()
genFormal (ft, n)
= do case ft of
Val t ->
do tell ["const "]
genType t
tell [" "]
Chan t ->
tell ["Channel *"]
_ ->
do genType ft
tell ["& "]
genName n
--}}}
--{{{ par modes
--}}}
--{{{ processes
genProcess :: Process -> CGen ()
genProcess p = case p of
ProcSpec m s p -> genSpec m s (genProcess p)
Assign m vs es -> genAssign vs es
Input m c im -> genInput c im
Output m c ois -> genOutput c ois
--OutputCase m c t ois
Skip m -> tell ["/* skip */\n"]
Stop m -> tell ["SetErr ();\n"]
Main m -> tell ["/* main */\n"]
Seq m ps -> sequence_ $ map genProcess ps
--SeqRep m r p
--If m s
--Case m e s
While m e p -> genWhile e p
--Par m pm ps
--ParRep m pm r p
--Processor m e p
--Alt m b s
ProcCall m n as -> genProcCall n as
_ -> missing $ "genProcess " ++ show p
genAssign :: [Variable] -> ExpressionList -> CGen ()
genAssign vs el
= case el of
FunctionCallList m n es -> missing "function call"
ExpressionList m es -> case vs of
[v] ->
do genVariable v
tell [" = "]
genExpression (head es)
tell [";\n"]
vs ->
do tell ["{\n"]
ns <- mapM (\_ -> makeNonce) vs
mapM (\(v, n, e) -> do st <- get
let t = typeOfVariable st v
genType (fromJust t)
tell [" ", n, " = "]
genExpression e
tell [";\n"])
(zip3 vs ns es)
mapM (\(v, n) -> do genVariable v
tell [" = ", n, ";\n"])
(zip vs ns)
tell ["}\n"]
genInput :: Channel -> InputMode -> CGen ()
genInput c im
= do ps <- get
let t = fromJust $ typeOfChannel ps c
case t of
Timer -> case im of
InputSimple m [InVariable m' v] -> genTimerRead v
InputAfter m e -> genTimerWait e
_ -> case im of
InputSimple m is -> sequence_ $ map (genInputItem c) is
_ -> missing $ "genInput " ++ show im
genTimerRead :: Variable -> CGen ()
genTimerRead v
= do n <- makeNonce
tell ["{\n"]
tell ["Time ", n, ";\n"]
tell ["ProcTime (&", n, ");\n"]
genVariable v
tell [" = ", n, ";\n"]
tell ["}\n"]
genTimerWait :: Expression -> CGen ()
genTimerWait e
= do tell ["ProcTimeAfter ("]
genExpression e
tell [");\n"]
genOutput :: Channel -> [OutputItem] -> CGen ()
genOutput c ois = sequence_ $ map (genOutputItem c) ois
genWhile :: Expression -> Process -> CGen ()
genWhile e p
= do tell ["while ("]
genExpression e
tell [") {\n"]
genProcess p
tell ["}\n"]
genProcCall :: Name -> [Actual] -> CGen ()
genProcCall n as
= do genName n
tell [" ("]
genActuals as
tell [");\n"]
--}}}

View File

@ -9,6 +9,7 @@ import System.IO
import PrettyShow
import Parse
import GenerateC
data Flag = ParseOnly | Verbose
deriving (Eq, Show)
@ -61,5 +62,9 @@ main = do
if ParseOnly `elem` opts then do
putStrLn $ show ast
else do
progress "{{{ Generate C"
c <- generateC state ast
putStr c
progress "}}}"
progress "Done"

View File

@ -5,6 +5,7 @@ all: $(targets)
sources = \
AST.hs \
Errors.hs \
GenerateC.hs \
Indentation.hs \
Main.hs \
Metadata.hs \

View File

@ -9,7 +9,8 @@ import qualified AST as A
data ParseState = ParseState {
psLocalNames :: [(String, A.Name)],
psNames :: [(String, A.NameDef)],
psNameCounter :: Int
psNameCounter :: Int,
psNonceCounter :: Int
}
deriving (Show, Eq, Typeable, Data)
@ -17,7 +18,8 @@ emptyState :: ParseState
emptyState = ParseState {
psLocalNames = [],
psNames = [],
psNameCounter = 0
psNameCounter = 0,
psNonceCounter = 0
}
psLookupName :: ParseState -> A.Name -> Maybe A.NameDef

View File

@ -40,15 +40,46 @@ subscriptType _ = Nothing
typeOfChannel :: ParseState -> A.Channel -> Maybe A.Type
typeOfChannel ps (A.Channel m n) = typeOfName ps n
typeOfChannel ps (A.SubscriptedChannel m s c)
= case typeOfChannel ps c of
Just t -> subscriptType t
_ -> Nothing
= typeOfChannel ps c >>= subscriptType
typeOfVariable :: ParseState -> A.Variable -> Maybe A.Type
typeOfVariable ps v = Nothing
typeOfVariable ps (A.Variable m n) = typeOfName ps n
typeOfVariable ps (A.SubscriptedVariable m s v)
= typeOfVariable ps v >>= subscriptType
typeOfExpression :: ParseState -> A.Expression -> Maybe A.Type
typeOfExpression ps e = Nothing
typeOfExpression ps e
= case e of
A.Monadic m op e -> typeOfExpression ps e
A.Dyadic m op e f -> typeOfExpression ps e -- assume f's been checked!
A.MostPos m t -> Just t
A.MostNeg m t -> Just t
A.Size m t -> Just A.Int
A.Conversion m cm t e -> Just t
A.ExprVariable m v -> typeOfVariable ps v `perhaps` noVal
A.ExprLiteral m l -> typeOfLiteral ps l
A.True m -> Just A.Bool
A.False m -> Just A.Bool
A.FunctionCall m n es
-> case returnTypesOfFunction ps n of
Just [t] -> Just t
_ -> Nothing
A.SubscriptedExpr m s e
-> typeOfExpression ps e >>= subscriptType
A.BytesInExpr m e -> Just A.Int
A.BytesInType m t -> Just A.Int
A.OffsetOf m t n -> Just A.Int
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
returnTypesOfFunction :: ParseState -> A.Name -> Maybe [A.Type]
returnTypesOfFunction ps n
= case specTypeOfName ps n of
Just (A.Function m rs fs vp) -> Just rs
_ -> Nothing
isCaseProtocolType :: ParseState -> A.Type -> Bool
isCaseProtocolType ps (A.Chan (A.UserProtocol pr))
@ -57,3 +88,7 @@ isCaseProtocolType ps (A.Chan (A.UserProtocol pr))
_ -> False
isCaseProtocolType ps _ = False
noVal :: A.Type -> A.Type
noVal (A.Val t) = t
noVal t = t

View File

@ -0,0 +1,7 @@
PROC P ()
INT a, b, c:
INT d, e, f:
SEQ
a := d
a, b, c := d, e, f
:

View File

@ -0,0 +1,21 @@
PROC p (VAL INT x, y, INT z)
z := x + y
:
INT FUNCTION f (VAL INT x, y)
VALOF
SKIP
RESULT x + y
:
PROC test.expressions ()
INT a:
INT b:
INT c:
SEQ
a := 1
b := 2
c := f (a, b)
c := (42 * a) + (b - (72 / c))
p (a, b, c)
:

3
fco2/testcases/skip.occ Normal file
View File

@ -0,0 +1,3 @@
PROC P ()
SKIP
: