diff --git a/fco/AST.hs b/fco/AST.hs index 78a1490..57b0164 100644 --- a/fco/AST.hs +++ b/fco/AST.hs @@ -37,6 +37,7 @@ data ConversionMode = data Subscript = Subscript Expression + | SubscriptTag Tag | SubFromFor Expression Expression | SubFrom Expression | SubFor Expression diff --git a/fco/ASTPasses.hs b/fco/ASTPasses.hs index f71b4c6..2608574 100644 --- a/fco/ASTPasses.hs +++ b/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] diff --git a/fco/COutput.hs b/fco/COutput.hs new file mode 100644 index 0000000..bf06f5e --- /dev/null +++ b/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 \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 + diff --git a/fco/Main.hs b/fco/Main.hs index f0acc02..b96eb16 100644 --- a/fco/Main.hs +++ b/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" diff --git a/fco/Makefile b/fco/Makefile index c2dcd32..489a3ed 100644 --- a/fco/Makefile +++ b/fco/Makefile @@ -3,6 +3,7 @@ all: fco sources = \ AST.hs \ ASTPasses.hs \ + COutput.hs \ Main.hs \ Metadata.hs \ Parse.hs \ diff --git a/fco/Test.hs b/fco/Test.hs new file mode 100644 index 0000000..627355e --- /dev/null +++ b/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 + diff --git a/fco/testcases/ambiguous.occ b/fco/testcases/ambiguous.occ index 8a5f2aa..54f98a4 100644 --- a/fco/testcases/ambiguous.occ +++ b/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: diff --git a/fco/testcases/expressions.occ b/fco/testcases/expressions.occ index 1825c5b..74616f9 100644 --- a/fco/testcases/expressions.occ +++ b/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) : diff --git a/fco/testcases/trivial.occ b/fco/testcases/trivial.occ new file mode 100644 index 0000000..122b453 --- /dev/null +++ b/fco/testcases/trivial.occ @@ -0,0 +1,5 @@ +PROC main () + SEQ + SKIP + STOP +: