Add basic C output support (not compilable yet!)

fco/AST.hs

@@ -37,6 +37,7 @@ data ConversionMode =
 
 data Subscript =
   Subscript Expression
+  | SubscriptTag Tag
   | SubFromFor Expression Expression
   | SubFrom Expression
   | SubFor Expression

fco/ASTPasses.hs

@@ -6,22 +6,47 @@ import qualified AST as A
 import Data.Generics
 import Control.Monad.State
 
+{- FIXME: Passes to add:
+calculate types
+fix Infer types
+resolve "c ! x; y" ambiguity (is x tag or variable?)
+resolve "x[y]" ambiguity (is y expression or tag?)
+check types
+add reference markers where appropriate
+turn inline VALOFs into regular FUNCTIONs
+identify free variables
+rewrite PROC/FUNCTION declarations and uses to take free variables as parameters
+make Names unique
+make Names C-styled
+mark Tags with their associated types
+extract type/PROC/FUNCTION declarations
+check only Main is left
+-}
+
 astPasses =
-  [ ("Silly monad example", numberPass)
+  [ ("C-style names", cStyleNamesPass)
   ]
 
-number :: A.Name -> State Int A.Name
-number (A.Name s) = do
-  i <- get
-  put (i + 1)
-  return $ A.Name (s ++ "." ++ (show i))
-
-number' :: A.Tag -> State Int A.Tag
-number' (A.Tag s) = do
-  i <- get
-  put (i + 1)
-  return $ A.Tag (s ++ "." ++ (show i))
-
+{-
 numberPass :: A.Process -> A.Process
 numberPass n = evalState (everywhereM (mkM (number `extM` number')) n) 0
+  where
+    number :: A.Name -> State Int A.Name
+    number (A.Name s) = do
+      i <- get
+      put (i + 1)
+      return $ A.Name (s ++ "." ++ (show i))
+
+    number' :: A.Tag -> State Int A.Tag
+    number' (A.Tag s) = do
+      i <- get
+      put (i + 1)
+      return $ A.Tag (s ++ "." ++ (show i))
+-}
+
+cStyleNamesPass :: A.Process -> A.Process
+cStyleNamesPass = everywhere (mkT doName)
+  where
+    doName :: A.Name -> A.Name
+    doName (A.Name s) = A.Name [if c == '.' then '_' else c | c <- s]
 

fco/COutput.hs

@@ -0,0 +1,127 @@
+-- Write C code
+
+module COutput where
+
+import List
+import Data.Generics
+import qualified AST as A
+
+concatWith x l = concat $ intersperse x l
+bracketed s = "(" ++ s ++ ")"
+
+unimp :: Data a => a -> String
+unimp = unimpG `extQ` unimpS
+  where
+    unimpG :: Data a => a -> String
+    unimpG t = rep
+      where
+        ctr = showConstr $ toConstr t
+        items = gmapQ unimp t
+        rep = "(" ++ ctr ++ concat [' ' : s | s <- items] ++ ")"
+
+    unimpS :: String -> String
+    unimpS s = show s
+
+writeC :: A.Process -> String
+writeC p = header ++ doProcess p
+  where
+    header = "#include <stdint.h>\n"
+
+    doName :: A.Name -> String
+    doName (A.Name n) = n
+
+    doUserType :: A.Type -> String
+    doUserType (A.UserType (A.Name n)) = "usertype_" ++ n
+
+    doType :: A.Type -> String
+    doType (A.Val t) = "const " ++ (doType t)
+    doType A.Bool = "int8_t"
+    doType A.Byte = "uint8_t"
+    doType A.Int = "int32_t"
+    doType A.Int16 = "int16_t"
+    doType A.Int32 = "int32_t"
+    doType A.Int64 = "int64_t"
+    doType A.Real32 = "float"
+    doType A.Real64 = "double"
+    doType u@(A.UserType _) = doUserType u
+    doType t = unimp t
+
+    doVariable :: A.Variable -> String
+    doVariable (A.Variable n) = doName n
+
+    doLiteralRepr :: A.LiteralRepr -> String
+    doLiteralRepr r = case r of
+      A.IntLiteral s -> s
+
+    doLiteral :: A.Literal -> String
+    doLiteral (A.Literal t r) = doLiteralRepr r
+
+    doFunction :: A.ValueProcess -> String
+    doFunction (A.ValOfSpec s p) = doSpecification s ++ doFunction p
+    doFunction (A.ValOf p el) = doProcess p ++ "return " ++ doExpressionListOne el ++ ";\n"
+    -- FIXME handle multi-value return
+
+    makeDecl :: A.Type -> A.Name -> String
+    makeDecl t n = doType t ++ " " ++ doName n
+
+    makeFormals :: [(A.Type, A.Name)] -> String
+    makeFormals fs = "(" ++ concatWith ", " [makeDecl t n | (t, n) <- fs] ++ ")"
+
+    doSpecification :: A.Specification -> String
+    doSpecification s@(n, st) = case st of
+      A.Declaration t -> makeDecl t n ++ ";\n"
+      A.Proc fs p -> "void " ++ doName n ++ " " ++ makeFormals fs ++ " {\n" ++ doProcess p ++ "}\n"
+      A.Function [r] fs vp -> doType r ++ " " ++ doName n ++ " " ++ makeFormals fs ++ " {\n" ++ doFunction vp ++ "}\n"
+      _ -> unimp s
+
+    doProcSpec :: A.Process -> String
+    doProcSpec p = doP [] p
+      where
+        doP :: [A.Specification] -> A.Process -> String
+        doP ss (A.ProcSpec s p) = doP (ss ++ [s]) p
+        doP ss p = "{\n" ++ concat (map doSpecification ss) ++ doProcess p ++ "}\n"
+
+    doActuals :: [A.Expression] -> String
+    doActuals es = "(" ++ concatWith ", " (map doExpression es) ++ ")"
+
+    doFunctionCall :: A.Name -> [A.Expression] -> String
+    doFunctionCall n as = (doName n) ++ " " ++ doActuals as
+
+    doMonadic :: A.MonadicOp -> A.Expression -> String
+    doMonadic o a = case o of
+      A.MonadicSubtr -> "-" ++ doExpression a
+
+    doDyadic :: A.DyadicOp -> A.Expression -> A.Expression -> String
+    doDyadic o a b = bracketed $ case o of
+      -- FIXME Ops ought to be runtime-checked using inline functions
+      A.Add -> doExpression a ++ " + " ++ doExpression b
+      A.Subtr -> doExpression a ++ " - " ++ doExpression b
+      A.Mul -> doExpression a ++ " * " ++ doExpression b
+      A.Div -> doExpression a ++ " / " ++ doExpression b
+
+    doExpression :: A.Expression -> String
+    doExpression e = case e of
+      A.Monadic o a -> doMonadic o a
+      A.Dyadic o a b -> doDyadic o a b
+      A.ExprVariable v -> doVariable v
+      A.ExprLiteral l -> doLiteral l
+
+    doExpressionListOne :: A.ExpressionList -> String
+    doExpressionListOne e = case e of
+      A.FunctionCallList n as -> doFunctionCall n as
+      A.ExpressionList [e] -> doExpression e
+
+    doAssign :: A.Process -> String
+    doAssign a = case a of
+      A.Assign [v] el -> (doVariable v) ++ " = " ++ (doExpressionListOne el) ++ ";\n"
+
+    doProcess :: A.Process -> String
+    doProcess s@(A.ProcSpec _ _) = doProcSpec s
+    doProcess a@(A.Assign _ _) = doAssign a
+    doProcess A.Skip = "/* SKIP */;\n"
+    doProcess A.Stop = "SetErr ();\n"
+    doProcess A.Main = "/* MAIN-PROCESS */\n";
+    doProcess (A.Seq ps) = concatWith "" (map doProcess ps)
+    doProcess (A.ProcCall n as) = doName n ++ " " ++ doActuals as ++ ";\n"
+    doProcess n = unimp n
+

fco/Main.hs

@@ -14,6 +14,7 @@ import Pass
 import PTPasses
 import PTToAST
 import ASTPasses
+import COutput
 
 data Flag = ParseOnly | SOccamOnly | Verbose
   deriving (Eq, Show)
@@ -50,33 +51,37 @@ main = do
   progress $ "Compiling " ++ fn
   progress ""
 
-  progress $ "{{{ Preprocessor"
+  progress "{{{ Preprocessor"
   preprocessed <- readSource fn
   progress $ numberedListing preprocessed
-  progress $ "}}}"
+  progress "}}}"
 
-  progress $ "{{{ Parser"
+  progress "{{{ Parser"
   let pt = parseSource preprocessed fn
   progress $ pshow pt
-  progress $ "}}}"
+  progress "}}}"
 
   if ParseOnly `elem` opts then do
       putStrLn $ show (nodeToSExp pt)
     else if SOccamOnly `elem` opts then do
       putStrLn $ show (nodeToSOccam pt)
     else do
-      progress $ "{{{ PT passes"
+      progress "{{{ PT passes"
       pt' <- runPasses ptPasses progress pt
-      progress $ "}}}"
+      progress "}}}"
 
-      progress $ "{{{ PT to AST"
+      progress "{{{ PT to AST"
       let ast = ptToAST pt'
       progress $ pshow ast
-      progress $ "}}}"
+      progress "}}}"
 
-      progress $ "{{{ AST passes"
+      progress "{{{ AST passes"
       ast' <- runPasses astPasses progress ast
-      progress $ "}}}"
+      progress "}}}"
 
-      progress $ "Done"
+      progress "{{{ C output"
+      putStr $ writeC ast'
+      progress "}}}"
+
+      progress "Done"
 

fco/Makefile

@@ -3,6 +3,7 @@ all: fco
 sources = \
 	AST.hs \
 	ASTPasses.hs \
+	COutput.hs \
 	Main.hs \
 	Metadata.hs \
 	Parse.hs \

fco/Test.hs

@@ -0,0 +1,18 @@
+-- How to "scrap my boilerplate"...
+
+module Test where
+
+import qualified Tree as N
+import Data.Generics
+import Control.Monad.State
+
+number :: N.Node -> State Int N.Node
+number (N.Name s) = do
+  i <- get
+  put (i + 1)
+  return $ N.Name (s ++ "." ++ (show i))
+number n = return n
+
+numberPass :: N.Node -> N.Node
+numberPass n = evalState (everywhereM (mkM number) n) 0
+

fco/testcases/ambiguous.occ

@@ -7,6 +7,15 @@ PROC x ()
     SEQ
       r := a[b]
 
+    DATA TYPE T
+      RECORD
+        INT b:
+    :
+    T a:
+    INT r:
+    SEQ
+      r := a[b]
+
     DATA TYPE a IS [1]INT:
     INT b:
     a r:

fco/testcases/expressions.occ

@@ -15,7 +15,7 @@ PROC test.expressions ()
   SEQ
     a := 1
     b := 2
-    c := 3
+    c := f (a, b)
     c := (42 * a) + (b - (72 / c))
     p (a, b, c)
 :

fco/testcases/trivial.occ

@@ -0,0 +1,5 @@
+PROC main ()
+  SEQ
+    SKIP
+    STOP
+: