From 572fa26ad7378c6a5b2fb58c64165f6fbe238614 Mon Sep 17 00:00:00 2001
From: Adam Sampson <ats@offog.org>
Date: Fri, 6 Apr 2007 23:12:21 +0000
Subject: [PATCH] A start at generating C++ code

---
 fco2/GenerateC.hs              | 490 +++++++++++++++++++++++++++++++++
 fco2/Main.hs                   |   5 +
 fco2/Makefile                  |   1 +
 fco2/ParseState.hs             |   6 +-
 fco2/Types.hs                  |  45 ++-
 fco2/testcases/assign.occ      |   7 +
 fco2/testcases/expressions.occ |  21 ++
 fco2/testcases/skip.occ        |   3 +
 8 files changed, 571 insertions(+), 7 deletions(-)
 create mode 100644 fco2/GenerateC.hs
 create mode 100644 fco2/testcases/assign.occ
 create mode 100644 fco2/testcases/expressions.occ
 create mode 100644 fco2/testcases/skip.occ

diff --git a/fco2/GenerateC.hs b/fco2/GenerateC.hs
new file mode 100644
index 0000000..b99e3c0
--- /dev/null
+++ b/fco2/GenerateC.hs
@@ -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"]
+--}}}
+
diff --git a/fco2/Main.hs b/fco2/Main.hs
index 907fd77..48ee3b7 100644
--- a/fco2/Main.hs
+++ b/fco2/Main.hs
@@ -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"
 
diff --git a/fco2/Makefile b/fco2/Makefile
index 37ff39d..d353bd5 100644
--- a/fco2/Makefile
+++ b/fco2/Makefile
@@ -5,6 +5,7 @@ all: $(targets)
 sources = \
 	AST.hs \
 	Errors.hs \
+	GenerateC.hs \
 	Indentation.hs \
 	Main.hs \
 	Metadata.hs \
diff --git a/fco2/ParseState.hs b/fco2/ParseState.hs
index 4486b9c..01019b6 100644
--- a/fco2/ParseState.hs
+++ b/fco2/ParseState.hs
@@ -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
diff --git a/fco2/Types.hs b/fco2/Types.hs
index a04ebac..a3da607 100644
--- a/fco2/Types.hs
+++ b/fco2/Types.hs
@@ -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
+
diff --git a/fco2/testcases/assign.occ b/fco2/testcases/assign.occ
new file mode 100644
index 0000000..be81f35
--- /dev/null
+++ b/fco2/testcases/assign.occ
@@ -0,0 +1,7 @@
+PROC P ()
+  INT a, b, c:
+  INT d, e, f:
+  SEQ
+    a := d
+    a, b, c := d, e, f
+:
diff --git a/fco2/testcases/expressions.occ b/fco2/testcases/expressions.occ
new file mode 100644
index 0000000..74616f9
--- /dev/null
+++ b/fco2/testcases/expressions.occ
@@ -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)
+:
diff --git a/fco2/testcases/skip.occ b/fco2/testcases/skip.occ
new file mode 100644
index 0000000..737b4d7
--- /dev/null
+++ b/fco2/testcases/skip.occ
@@ -0,0 +1,3 @@
+PROC P ()
+  SKIP
+: