Add basic C output support (not compilable yet!)
This commit is contained in:
parent
7d4e79e56b
commit
7b6258184e
|
@ -37,6 +37,7 @@ data ConversionMode =
|
||||||
|
|
||||||
data Subscript =
|
data Subscript =
|
||||||
Subscript Expression
|
Subscript Expression
|
||||||
|
| SubscriptTag Tag
|
||||||
| SubFromFor Expression Expression
|
| SubFromFor Expression Expression
|
||||||
| SubFrom Expression
|
| SubFrom Expression
|
||||||
| SubFor Expression
|
| SubFor Expression
|
||||||
|
|
|
@ -6,22 +6,47 @@ import qualified AST as A
|
||||||
import Data.Generics
|
import Data.Generics
|
||||||
import Control.Monad.State
|
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 =
|
astPasses =
|
||||||
[ ("Silly monad example", numberPass)
|
[ ("C-style names", cStyleNamesPass)
|
||||||
]
|
]
|
||||||
|
|
||||||
number :: A.Name -> State Int A.Name
|
{-
|
||||||
number (A.Name s) = do
|
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
|
i <- get
|
||||||
put (i + 1)
|
put (i + 1)
|
||||||
return $ A.Name (s ++ "." ++ (show i))
|
return $ A.Name (s ++ "." ++ (show i))
|
||||||
|
|
||||||
number' :: A.Tag -> State Int A.Tag
|
number' :: A.Tag -> State Int A.Tag
|
||||||
number' (A.Tag s) = do
|
number' (A.Tag s) = do
|
||||||
i <- get
|
i <- get
|
||||||
put (i + 1)
|
put (i + 1)
|
||||||
return $ A.Tag (s ++ "." ++ (show i))
|
return $ A.Tag (s ++ "." ++ (show i))
|
||||||
|
-}
|
||||||
|
|
||||||
numberPass :: A.Process -> A.Process
|
cStyleNamesPass :: A.Process -> A.Process
|
||||||
numberPass n = evalState (everywhereM (mkM (number `extM` number')) n) 0
|
cStyleNamesPass = everywhere (mkT doName)
|
||||||
|
where
|
||||||
|
doName :: A.Name -> A.Name
|
||||||
|
doName (A.Name s) = A.Name [if c == '.' then '_' else c | c <- s]
|
||||||
|
|
||||||
|
|
127
fco/COutput.hs
Normal file
127
fco/COutput.hs
Normal file
|
@ -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
|
||||||
|
|
27
fco/Main.hs
27
fco/Main.hs
|
@ -14,6 +14,7 @@ import Pass
|
||||||
import PTPasses
|
import PTPasses
|
||||||
import PTToAST
|
import PTToAST
|
||||||
import ASTPasses
|
import ASTPasses
|
||||||
|
import COutput
|
||||||
|
|
||||||
data Flag = ParseOnly | SOccamOnly | Verbose
|
data Flag = ParseOnly | SOccamOnly | Verbose
|
||||||
deriving (Eq, Show)
|
deriving (Eq, Show)
|
||||||
|
@ -50,33 +51,37 @@ main = do
|
||||||
progress $ "Compiling " ++ fn
|
progress $ "Compiling " ++ fn
|
||||||
progress ""
|
progress ""
|
||||||
|
|
||||||
progress $ "{{{ Preprocessor"
|
progress "{{{ Preprocessor"
|
||||||
preprocessed <- readSource fn
|
preprocessed <- readSource fn
|
||||||
progress $ numberedListing preprocessed
|
progress $ numberedListing preprocessed
|
||||||
progress $ "}}}"
|
progress "}}}"
|
||||||
|
|
||||||
progress $ "{{{ Parser"
|
progress "{{{ Parser"
|
||||||
let pt = parseSource preprocessed fn
|
let pt = parseSource preprocessed fn
|
||||||
progress $ pshow pt
|
progress $ pshow pt
|
||||||
progress $ "}}}"
|
progress "}}}"
|
||||||
|
|
||||||
if ParseOnly `elem` opts then do
|
if ParseOnly `elem` opts then do
|
||||||
putStrLn $ show (nodeToSExp pt)
|
putStrLn $ show (nodeToSExp pt)
|
||||||
else if SOccamOnly `elem` opts then do
|
else if SOccamOnly `elem` opts then do
|
||||||
putStrLn $ show (nodeToSOccam pt)
|
putStrLn $ show (nodeToSOccam pt)
|
||||||
else do
|
else do
|
||||||
progress $ "{{{ PT passes"
|
progress "{{{ PT passes"
|
||||||
pt' <- runPasses ptPasses progress pt
|
pt' <- runPasses ptPasses progress pt
|
||||||
progress $ "}}}"
|
progress "}}}"
|
||||||
|
|
||||||
progress $ "{{{ PT to AST"
|
progress "{{{ PT to AST"
|
||||||
let ast = ptToAST pt'
|
let ast = ptToAST pt'
|
||||||
progress $ pshow ast
|
progress $ pshow ast
|
||||||
progress $ "}}}"
|
progress "}}}"
|
||||||
|
|
||||||
progress $ "{{{ AST passes"
|
progress "{{{ AST passes"
|
||||||
ast' <- runPasses astPasses progress ast
|
ast' <- runPasses astPasses progress ast
|
||||||
progress $ "}}}"
|
progress "}}}"
|
||||||
|
|
||||||
progress $ "Done"
|
progress "{{{ C output"
|
||||||
|
putStr $ writeC ast'
|
||||||
|
progress "}}}"
|
||||||
|
|
||||||
|
progress "Done"
|
||||||
|
|
||||||
|
|
|
@ -3,6 +3,7 @@ all: fco
|
||||||
sources = \
|
sources = \
|
||||||
AST.hs \
|
AST.hs \
|
||||||
ASTPasses.hs \
|
ASTPasses.hs \
|
||||||
|
COutput.hs \
|
||||||
Main.hs \
|
Main.hs \
|
||||||
Metadata.hs \
|
Metadata.hs \
|
||||||
Parse.hs \
|
Parse.hs \
|
||||||
|
|
18
fco/Test.hs
Normal file
18
fco/Test.hs
Normal file
|
@ -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
|
||||||
|
|
|
@ -7,6 +7,15 @@ PROC x ()
|
||||||
SEQ
|
SEQ
|
||||||
r := a[b]
|
r := a[b]
|
||||||
|
|
||||||
|
DATA TYPE T
|
||||||
|
RECORD
|
||||||
|
INT b:
|
||||||
|
:
|
||||||
|
T a:
|
||||||
|
INT r:
|
||||||
|
SEQ
|
||||||
|
r := a[b]
|
||||||
|
|
||||||
DATA TYPE a IS [1]INT:
|
DATA TYPE a IS [1]INT:
|
||||||
INT b:
|
INT b:
|
||||||
a r:
|
a r:
|
||||||
|
|
|
@ -15,7 +15,7 @@ PROC test.expressions ()
|
||||||
SEQ
|
SEQ
|
||||||
a := 1
|
a := 1
|
||||||
b := 2
|
b := 2
|
||||||
c := 3
|
c := f (a, b)
|
||||||
c := (42 * a) + (b - (72 / c))
|
c := (42 * a) + (b - (72 / c))
|
||||||
p (a, b, c)
|
p (a, b, c)
|
||||||
:
|
:
|
||||||
|
|
5
fco/testcases/trivial.occ
Normal file
5
fco/testcases/trivial.occ
Normal file
|
@ -0,0 +1,5 @@
|
||||||
|
PROC main ()
|
||||||
|
SEQ
|
||||||
|
SKIP
|
||||||
|
STOP
|
||||||
|
:
|
Loading…
Reference in New Issue
Block a user