suzanne.soy/tock-mirror
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

More work

Browse Source
This commit is contained in:
Adam Sampson 2007-04-07 14:33:58 +00:00
parent 77cef723ec
commit 74b2d6d9b9
14 changed files with 281 additions and 198 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
fco2/AST.hs
View File

@ -43,8 +43,6 @@ data Type =
| Any | Any
| Timer | Timer
| Port Type | Port Type
| Infer -- for where the type is not given but can be worked out (e.g. "x IS y:")
| NoType -- for where we need a Type, but none exists (e.g. PROCs scoping in)
deriving (Show, Eq, Typeable, Data) deriving (Show, Eq, Typeable, Data)
data ConversionMode = data ConversionMode =

346
fco2/GenerateC.hs
View File

@ -5,25 +5,21 @@ module GenerateC where
-- FIXME: Checks should be done in the parser, not here -- for example, the -- FIXME: Checks should be done in the parser, not here -- for example, the
-- expressionList production should take an argument with a list of types. -- 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.
-- ... and the sum of the above two is that we should really have a
-- typechecking pass after the Parser.
-- FIXME: There should be a pass that pulls PAR branches (that aren't already -- FIXME: There should be a pass that pulls PAR branches (that aren't already
-- PROC calls) out into PROCs. -- PROC calls) out into PROCs.
-- FIXME: Arrays. Should be a struct that contains the data and size, and we -- FIXME: Arrays. Should be a struct that contains the data and size, and we
-- then use a pointer to the struct to pass around. -- then use a pointer to the struct to pass around.
-- FIXME: The show instance for types should produce occam-looking types.
import Data.List import Data.List
import Data.Maybe import Data.Maybe
import Control.Monad.Writer import Control.Monad.Writer
import Control.Monad.Error import Control.Monad.Error
import Control.Monad.State import Control.Monad.State
import AST import qualified AST as A
import Metadata import Metadata
import ParseState import ParseState
import Errors import Errors
@ -34,14 +30,14 @@ type CGen a = WriterT [String] (ErrorT String (StateT ParseState IO)) a
--}}} --}}}
--{{{ top-level --{{{ top-level
generateC :: ParseState -> Process -> IO String generateC :: ParseState -> A.Process -> IO String
generateC st ast generateC st ast
= do v <- evalStateT (runErrorT (runWriterT (genTopLevel ast))) st = do v <- evalStateT (runErrorT (runWriterT (genTopLevel ast))) st
case v of case v of
Left e -> die e Left e -> die e
Right (_, ss) -> return $ concat ss Right (_, ss) -> return $ concat ss
genTopLevel :: Process -> CGen () genTopLevel :: A.Process -> CGen ()
genTopLevel p genTopLevel p
= do tell ["#include <fco_support.h>\n"] = do tell ["#include <fco_support.h>\n"]
genProcess p genProcess p
@ -68,44 +64,44 @@ withPS f
--}}} --}}}
--{{{ names --{{{ names
genName :: Name -> CGen () genName :: A.Name -> CGen ()
genName n = tell [[if c == '.' then '_' else c | c <- nameName n]] genName n = tell [[if c == '.' then '_' else c | c <- A.nameName n]]
--}}} --}}}
--{{{ types --{{{ types
genType :: Type -> CGen () genType :: A.Type -> CGen ()
genType Bool = tell ["bool"] genType A.Bool = tell ["bool"]
-- FIXME: This probably isn't right; we might have to explicitly cast string literals... -- FIXME: This probably isn't right; we might have to explicitly cast string literals...
genType Byte = tell ["char"] genType A.Byte = tell ["char"]
genType Int = tell ["int"] genType A.Int = tell ["int"]
genType Int16 = tell ["int16_t"] genType A.Int16 = tell ["int16_t"]
genType Int32 = tell ["int32_t"] genType A.Int32 = tell ["int32_t"]
genType Int64 = tell ["int64_t"] genType A.Int64 = tell ["int64_t"]
genType Real32 = tell ["float"] genType A.Real32 = tell ["float"]
genType Real64 = tell ["double"] genType A.Real64 = tell ["double"]
genType (Array e t) genType (A.Array e t)
= do genType t = do genType t
tell ["["] tell ["["]
genExpression e genExpression e
tell ["]"] tell ["]"]
genType (ArrayUnsized t) genType (A.ArrayUnsized t)
= do genType t = do genType t
tell ["[]"] tell ["[]"]
genType (UserDataType n) = genName n genType (A.UserDataType n) = genName n
genType (Chan t) genType (A.Chan t)
= do tell ["Channel*"] = do tell ["Channel*"]
genType t = missing $ "genType " ++ show t genType t = missing $ "genType " ++ show t
--}}} --}}}
--{{{ abbreviations --{{{ abbreviations
genConst :: AbbrevMode -> CGen () genConst :: A.AbbrevMode -> CGen ()
genConst Abbrev = return () genConst A.Abbrev = return ()
genConst ValAbbrev = tell ["const "] genConst A.ValAbbrev = tell ["const "]
--}}} --}}}
--{{{ conversions --{{{ conversions
genConversion :: ConversionMode -> Type -> Expression -> CGen () genConversion :: A.ConversionMode -> A.Type -> A.Expression -> CGen ()
genConversion DefaultConversion t e genConversion A.DefaultConversion t e
= do tell ["(("] = do tell ["(("]
genType t genType t
tell [") "] tell [") "]
@ -115,13 +111,13 @@ genConversion cm t e = missing $ "genConversion " ++ show cm
--}}} --}}}
--{{{ subscripts --{{{ subscripts
genSubscript :: Subscript -> CGen () -> CGen () genSubscript :: A.Subscript -> CGen () -> CGen ()
genSubscript (Subscript m e) p genSubscript (A.Subscript m e) p
= do p = do p
tell ["["] tell ["["]
genExpression e genExpression e
tell ["]"] tell ["]"]
genSubscript (SubscriptTag m n) p genSubscript (A.SubscriptTag m n) p
= do p = do p
tell ["."] tell ["."]
genName n genName n
@ -129,17 +125,17 @@ genSubscript s p = missing $ "genSubscript " ++ show s
--}}} --}}}
--{{{ literals --{{{ literals
genLiteral :: Literal -> CGen () genLiteral :: A.Literal -> CGen ()
genLiteral (Literal m t lr) = genLiteralRepr lr genLiteral (A.Literal m t lr) = genLiteralRepr lr
genLiteral l = missing $ "genLiteral " ++ show l genLiteral l = missing $ "genLiteral " ++ show l
genLiteralRepr :: LiteralRepr -> CGen () genLiteralRepr :: A.LiteralRepr -> CGen ()
genLiteralRepr (RealLiteral m s) = tell [s] genLiteralRepr (A.RealLiteral m s) = tell [s]
genLiteralRepr (IntLiteral m s) = tell [s] genLiteralRepr (A.IntLiteral m s) = tell [s]
genLiteralRepr (HexLiteral m s) = case s of ('#':rest) -> tell ["0x", rest] genLiteralRepr (A.HexLiteral m s) = case s of ('#':rest) -> tell ["0x", rest]
genLiteralRepr (ByteLiteral m s) = tell ["'", convStringLiteral s, "'"] genLiteralRepr (A.ByteLiteral m s) = tell ["'", convStringLiteral s, "'"]
genLiteralRepr (StringLiteral m s) = tell ["\"", convStringLiteral s, "\""] genLiteralRepr (A.StringLiteral m s) = tell ["\"", convStringLiteral s, "\""]
genLiteralRepr (ArrayLiteral m es) genLiteralRepr (A.ArrayLiteral m es)
= do tell ["{"] = do tell ["{"]
sequence_ $ intersperse genComma (map genExpression es) sequence_ $ intersperse genComma (map genExpression es)
tell ["}"] tell ["}"]
@ -159,56 +155,56 @@ convStringStar c = [c]
--}}} --}}}
--{{{ channels, variables --{{{ channels, variables
genChannel :: Channel -> CGen () genChannel :: A.Channel -> CGen ()
genChannel (Channel m n) = genName n genChannel (A.Channel m n) = genName n
genChannel (SubscriptedChannel m s c) = genSubscript s (genChannel c) genChannel (A.SubscriptedChannel m s c) = genSubscript s (genChannel c)
genVariable :: Variable -> CGen () genVariable :: A.Variable -> CGen ()
genVariable (Variable m n) = genName n genVariable (A.Variable m n) = genName n
genVariable (SubscriptedVariable m s v) = genSubscript s (genVariable v) genVariable (A.SubscriptedVariable m s v) = genSubscript s (genVariable v)
--}}} --}}}
--{{{ expressions --{{{ expressions
genExpression :: Expression -> CGen () genExpression :: A.Expression -> CGen ()
genExpression (Monadic m op e) = genMonadic op e genExpression (A.Monadic m op e) = genMonadic op e
genExpression (Dyadic m op e f) = genDyadic op e f genExpression (A.Dyadic m op e f) = genDyadic op e f
genExpression (MostPos m t) = genTypeConstant "mostpos" t genExpression (A.MostPos m t) = genTypeConstant "mostpos" t
genExpression (MostNeg m t) = genTypeConstant "mostneg" t genExpression (A.MostNeg m t) = genTypeConstant "mostneg" t
--genExpression (Size m t) --genExpression (A.Size m t)
genExpression (Conversion m cm t e) = genConversion cm t e genExpression (A.Conversion m cm t e) = genConversion cm t e
genExpression (ExprVariable m v) = genVariable v genExpression (A.ExprVariable m v) = genVariable v
genExpression (ExprLiteral m l) = genLiteral l genExpression (A.ExprLiteral m l) = genLiteral l
genExpression (AST.True m) = tell ["true"] genExpression (A.True m) = tell ["true"]
genExpression (AST.False m) = tell ["false"] genExpression (A.False m) = tell ["false"]
--genExpression (FunctionCall m n es) --genExpression (A.FunctionCall m n es)
--genExpression (SubscriptedExpr m s e) --genExpression (A.SubscriptedExpr m s e)
--genExpression (BytesInExpr m e) --genExpression (A.BytesInExpr m e)
genExpression (BytesInType m t) genExpression (A.BytesInType m t)
= do tell ["sizeof ("] = do tell ["sizeof ("]
genType t genType t
tell [")"] tell [")"]
--genExpression (OffsetOf m t n) --genExpression (A.OffsetOf m t n)
genExpression t = missing $ "genExpression " ++ show t genExpression t = missing $ "genExpression " ++ show t
genTypeConstant :: String -> Type -> CGen () genTypeConstant :: String -> A.Type -> CGen ()
genTypeConstant s t = missing $ "genTypeConstant " ++ show t genTypeConstant s t = missing $ "genTypeConstant " ++ show t
--}}} --}}}
--{{{ operators --{{{ operators
genSimpleMonadic :: String -> Expression -> CGen () genSimpleMonadic :: String -> A.Expression -> CGen ()
genSimpleMonadic s e genSimpleMonadic s e
= do tell ["(", s] = do tell ["(", s]
genExpression e genExpression e
tell [")"] tell [")"]
genMonadic :: MonadicOp -> Expression -> CGen () genMonadic :: A.MonadicOp -> A.Expression -> CGen ()
genMonadic MonadicSubtr e = genSimpleMonadic "-" e genMonadic A.MonadicSubtr e = genSimpleMonadic "-" e
genMonadic MonadicBitNot e = genSimpleMonadic "~" e genMonadic A.MonadicBitNot e = genSimpleMonadic "~" e
genMonadic MonadicNot e = genSimpleMonadic "!" e genMonadic A.MonadicNot e = genSimpleMonadic "!" e
--genMonadic MonadicSize e --genMonadic A.MonadicSize e
genMonadic op e = missing $ "genMonadic " ++ show op genMonadic op e = missing $ "genMonadic " ++ show op
genSimpleDyadic :: String -> Expression -> Expression -> CGen () genSimpleDyadic :: String -> A.Expression -> A.Expression -> CGen ()
genSimpleDyadic s e f genSimpleDyadic s e f
= do tell ["("] = do tell ["("]
genExpression e genExpression e
@ -216,7 +212,7 @@ genSimpleDyadic s e f
genExpression f genExpression f
tell [")"] tell [")"]
genFuncDyadic :: String -> Expression -> Expression -> CGen () genFuncDyadic :: String -> A.Expression -> A.Expression -> CGen ()
genFuncDyadic s e f genFuncDyadic s e f
= do tell [s, " ("] = do tell [s, " ("]
genExpression e genExpression e
@ -224,40 +220,40 @@ genFuncDyadic s e f
genExpression f genExpression f
tell [")"] tell [")"]
genDyadic :: DyadicOp -> Expression -> Expression -> CGen () genDyadic :: A.DyadicOp -> A.Expression -> A.Expression -> CGen ()
genDyadic Add e f = genFuncDyadic "occam_add" e f genDyadic A.Add e f = genFuncDyadic "occam_add" e f
genDyadic Subtr e f = genFuncDyadic "occam_subtr" e f genDyadic A.Subtr e f = genFuncDyadic "occam_subtr" e f
genDyadic Mul e f = genFuncDyadic "occam_mul" e f genDyadic A.Mul e f = genFuncDyadic "occam_mul" e f
genDyadic Div e f = genFuncDyadic "occam_div" e f genDyadic A.Div e f = genFuncDyadic "occam_div" e f
genDyadic Rem e f = genFuncDyadic "occam_rem" e f genDyadic A.Rem e f = genFuncDyadic "occam_rem" e f
genDyadic Plus e f = genSimpleDyadic "+" e f genDyadic A.Plus e f = genSimpleDyadic "+" e f
genDyadic Minus e f = genSimpleDyadic "-" e f genDyadic A.Minus e f = genSimpleDyadic "-" e f
genDyadic Times e f = genSimpleDyadic "*" e f genDyadic A.Times e f = genSimpleDyadic "*" e f
genDyadic BitAnd e f = genSimpleDyadic "&" e f genDyadic A.BitAnd e f = genSimpleDyadic "&" e f
genDyadic BitOr e f = genSimpleDyadic "|" e f genDyadic A.BitOr e f = genSimpleDyadic "|" e f
genDyadic BitXor e f = genSimpleDyadic "^" e f genDyadic A.BitXor e f = genSimpleDyadic "^" e f
genDyadic And e f = genSimpleDyadic "&&" e f genDyadic A.And e f = genSimpleDyadic "&&" e f
genDyadic Or e f = genSimpleDyadic "||" e f genDyadic A.Or e f = genSimpleDyadic "||" e f
genDyadic Eq e f = genSimpleDyadic "==" e f genDyadic A.Eq e f = genSimpleDyadic "==" e f
genDyadic NotEq e f = genSimpleDyadic "!=" e f genDyadic A.NotEq e f = genSimpleDyadic "!=" e f
genDyadic Less e f = genSimpleDyadic "<" e f genDyadic A.Less e f = genSimpleDyadic "<" e f
genDyadic More e f = genSimpleDyadic ">" e f genDyadic A.More e f = genSimpleDyadic ">" e f
genDyadic LessEq e f = genSimpleDyadic "<=" e f genDyadic A.LessEq e f = genSimpleDyadic "<=" e f
genDyadic MoreEq e f = genSimpleDyadic ">=" e f genDyadic A.MoreEq e f = genSimpleDyadic ">=" e f
genDyadic After e f = genFuncDyadic "occam_after" e f genDyadic A.After e f = genFuncDyadic "occam_after" e f
--}}} --}}}
--{{{ input/output items --{{{ input/output items
genInputItem :: Channel -> InputItem -> CGen () genInputItem :: A.Channel -> A.InputItem -> CGen ()
genInputItem c (InCounted m cv av) genInputItem c (A.InCounted m cv av)
= do genInputItem c (InVariable m cv) = do genInputItem c (A.InVariable m cv)
-- need to then input as much as appropriate -- need to then input as much as appropriate
missing "genInputItem counted" missing "genInputItem counted"
genInputItem c (InVariable m v) genInputItem c (A.InVariable m v)
= do ps <- get = do ps <- get
let t = fromJust $ typeOfVariable ps v let t = fromJust $ typeOfVariable ps v
case t of case t of
Int -> A.Int ->
do tell ["ChanInInt ("] do tell ["ChanInInt ("]
genChannel c genChannel c
tell [", &"] tell [", &"]
@ -272,16 +268,16 @@ genInputItem c (InVariable m v)
genType t genType t
tell ["));\n"] tell ["));\n"]
genOutputItem :: Channel -> OutputItem -> CGen () genOutputItem :: A.Channel -> A.OutputItem -> CGen ()
genOutputItem c (OutCounted m ce ae) genOutputItem c (A.OutCounted m ce ae)
= do genOutputItem c (OutExpression m ce) = do genOutputItem c (A.OutExpression m ce)
missing "genOutputItem counted" missing "genOutputItem counted"
genOutputItem c (OutExpression m e) genOutputItem c (A.OutExpression m e)
= do n <- makeNonce = do n <- makeNonce
ps <- get ps <- get
let t = fromJust $ typeOfExpression ps e let t = fromJust $ typeOfExpression ps e
case t of case t of
Int -> A.Int ->
do tell ["ChanOutInt ("] do tell ["ChanOutInt ("]
genChannel c genChannel c
tell [", "] tell [", "]
@ -302,7 +298,7 @@ genOutputItem c (OutExpression m e)
--}}} --}}}
--{{{ replicators --{{{ replicators
genReplicator :: Replicator -> CGen () -> CGen () genReplicator :: A.Replicator -> CGen () -> CGen ()
genReplicator rep body genReplicator rep body
= do tell ["for ("] = do tell ["for ("]
genReplicatorLoop rep genReplicatorLoop rep
@ -312,8 +308,8 @@ genReplicator rep body
-- FIXME This should be special-cased for when base == 0 to generate the sort -- FIXME This should be special-cased for when base == 0 to generate the sort
-- of loop a C programmer would normally write. -- of loop a C programmer would normally write.
genReplicatorLoop :: Replicator -> CGen () genReplicatorLoop :: A.Replicator -> CGen ()
genReplicatorLoop (For m n base count) genReplicatorLoop (A.For m n base count)
= do counter <- makeNonce = do counter <- makeNonce
tell ["int ", counter, " = "] tell ["int ", counter, " = "]
genExpression count genExpression count
@ -333,27 +329,29 @@ genReplicatorLoop (For m n base count)
--}}} --}}}
--{{{ specifications --{{{ specifications
genSpec :: Specification -> CGen () -> CGen () genSpec :: A.Specification -> CGen () -> CGen ()
genSpec spec body genSpec spec body
= do introduceSpec spec = do introduceSpec spec
body body
removeSpec spec removeSpec spec
introduceSpec :: Specification -> CGen () introduceSpec :: A.Specification -> CGen ()
introduceSpec (n, Declaration m Timer) = return () introduceSpec (n, A.Declaration m A.Timer) = return ()
introduceSpec (n, Declaration m t) introduceSpec (n, A.Declaration m t)
= do case t of = do case t of
Chan _ -> do cn <- makeNonce A.Chan _ ->
tell ["Channel ", cn, ";\n"] do cn <- makeNonce
tell ["ChanInit (&", cn, ");\n"] tell ["Channel ", cn, ";\n"]
tell ["Channel *"] tell ["ChanInit (&", cn, ");\n"]
genName n tell ["Channel *"]
tell [" = &", cn, ";\n"] genName n
_ -> do genType t tell [" = &", cn, ";\n"]
tell [" "] _ ->
genName n do genType t
tell [";\n"] tell [" "]
introduceSpec (n, Is m am t v) genName n
tell [";\n"]
introduceSpec (n, A.Is m am t v)
= do genConst am = do genConst am
genType t genType t
tell ["& "] tell ["& "]
@ -361,7 +359,7 @@ introduceSpec (n, Is m am t v)
tell [" = "] tell [" = "]
genVariable v genVariable v
tell [";\n"] tell [";\n"]
introduceSpec (n, IsExpr m am t e) introduceSpec (n, A.IsExpr m am t e)
= do genConst am = do genConst am
genType t genType t
tell [" "] tell [" "]
@ -369,21 +367,21 @@ introduceSpec (n, IsExpr m am t e)
tell [" = "] tell [" = "]
genExpression e genExpression e
tell [";\n"] tell [";\n"]
introduceSpec (n, IsChannel m t c) introduceSpec (n, A.IsChannel m t c)
= do genType t = do genType t
tell [" "] tell [" "]
genName n genName n
tell [" = "] tell [" = "]
genChannel c genChannel c
tell [";\n"] tell [";\n"]
introduceSpec (n, IsChannelArray m t cs) introduceSpec (n, A.IsChannelArray m t cs)
= do genType t = do genType t
tell [" "] tell [" "]
genName n genName n
tell [" = {"] tell [" = {"]
sequence_ $ intersperse genComma (map genChannel cs) sequence_ $ intersperse genComma (map genChannel cs)
tell ["};\n"] tell ["};\n"]
introduceSpec (n, Proc m fs p) introduceSpec (n, A.Proc m fs p)
= do tell ["void "] = do tell ["void "]
genName n genName n
tell [" ("] tell [" ("]
@ -394,30 +392,30 @@ introduceSpec (n, Proc m fs p)
-- CASE protocol should generate an enum for the tags -- CASE protocol should generate an enum for the tags
introduceSpec (n, t) = missing $ "introduceSpec " ++ show t introduceSpec (n, t) = missing $ "introduceSpec " ++ show t
removeSpec :: Specification -> CGen () removeSpec :: A.Specification -> CGen ()
removeSpec _ = return () removeSpec _ = return ()
--}}} --}}}
--{{{ actuals/formals --{{{ actuals/formals
genActuals :: [Actual] -> CGen () genActuals :: [A.Actual] -> CGen ()
genActuals as = sequence_ $ intersperse genComma (map genActual as) genActuals as = sequence_ $ intersperse genComma (map genActual as)
genActual :: Actual -> CGen () genActual :: A.Actual -> CGen ()
genActual (ActualExpression e) = genExpression e genActual (A.ActualExpression e) = genExpression e
genActual (ActualChannel c) = genChannel c genActual (A.ActualChannel c) = genChannel c
genFormals :: [Formal] -> CGen () genFormals :: [A.Formal] -> CGen ()
genFormals fs = sequence_ $ intersperse genComma (map genFormal fs) genFormals fs = sequence_ $ intersperse genComma (map genFormal fs)
-- Arrays must be handled specially -- Arrays must be handled specially
genFormal :: Formal -> CGen () genFormal :: A.Formal -> CGen ()
genFormal (Formal am t n) genFormal (A.Formal am t n)
= do case am of = do case am of
ValAbbrev -> A.ValAbbrev ->
do genConst am do genConst am
genType t genType t
tell [" "] tell [" "]
Abbrev -> A.Abbrev ->
do genType t do genType t
tell ["& "] tell ["& "]
genName n genName n
@ -427,33 +425,33 @@ genFormal (Formal am t n)
--}}} --}}}
--{{{ processes --{{{ processes
genProcess :: Process -> CGen () genProcess :: A.Process -> CGen ()
genProcess p = case p of genProcess p = case p of
ProcSpec m s p -> genSpec s (genProcess p) A.ProcSpec m s p -> genSpec s (genProcess p)
Assign m vs es -> genAssign vs es A.Assign m vs es -> genAssign vs es
Input m c im -> genInput c im A.Input m c im -> genInput c im
Output m c ois -> genOutput c ois A.Output m c ois -> genOutput c ois
--OutputCase m c t ois --A.OutputCase m c t ois
Skip m -> tell ["/* skip */\n"] A.Skip m -> tell ["/* skip */\n"]
Stop m -> genStop A.Stop m -> genStop
Main m -> tell ["/* main */\n"] A.Main m -> tell ["/* main */\n"]
Seq m ps -> sequence_ $ map genProcess ps A.Seq m ps -> sequence_ $ map genProcess ps
SeqRep m r p -> genReplicator r (genProcess p) A.SeqRep m r p -> genReplicator r (genProcess p)
If m s -> genIf s A.If m s -> genIf s
--Case m e s --A.Case m e s
While m e p -> genWhile e p A.While m e p -> genWhile e p
--Par m pm ps --A.Par m pm ps
--ParRep m pm r p --A.ParRep m pm r p
--Processor m e p --A.Processor m e p
--Alt m b s --A.Alt m b s
ProcCall m n as -> genProcCall n as A.ProcCall m n as -> genProcCall n as
_ -> missing $ "genProcess " ++ show p _ -> missing $ "genProcess " ++ show p
genAssign :: [Variable] -> ExpressionList -> CGen () genAssign :: [A.Variable] -> A.ExpressionList -> CGen ()
genAssign vs el genAssign vs el
= case el of = case el of
FunctionCallList m n es -> missing "function call" A.FunctionCallList m n es -> missing "function call"
ExpressionList m es -> case vs of A.ExpressionList m es -> case vs of
[v] -> [v] ->
do genVariable v do genVariable v
tell [" = "] tell [" = "]
@ -474,19 +472,19 @@ genAssign vs el
(zip vs ns) (zip vs ns)
tell ["}\n"] tell ["}\n"]
genInput :: Channel -> InputMode -> CGen () genInput :: A.Channel -> A.InputMode -> CGen ()
genInput c im genInput c im
= do ps <- get = do ps <- get
let t = fromJust $ typeOfChannel ps c let t = fromJust $ typeOfChannel ps c
case t of case t of
Timer -> case im of A.Timer -> case im of
InputSimple m [InVariable m' v] -> genTimerRead v A.InputSimple m [A.InVariable m' v] -> genTimerRead v
InputAfter m e -> genTimerWait e A.InputAfter m e -> genTimerWait e
_ -> case im of _ -> case im of
InputSimple m is -> sequence_ $ map (genInputItem c) is A.InputSimple m is -> sequence_ $ map (genInputItem c) is
_ -> missing $ "genInput " ++ show im _ -> missing $ "genInput " ++ show im
genTimerRead :: Variable -> CGen () genTimerRead :: A.Variable -> CGen ()
genTimerRead v genTimerRead v
= do n <- makeNonce = do n <- makeNonce
tell ["{\n"] tell ["{\n"]
@ -496,13 +494,13 @@ genTimerRead v
tell [" = ", n, ";\n"] tell [" = ", n, ";\n"]
tell ["}\n"] tell ["}\n"]
genTimerWait :: Expression -> CGen () genTimerWait :: A.Expression -> CGen ()
genTimerWait e genTimerWait e
= do tell ["ProcTimeAfter ("] = do tell ["ProcTimeAfter ("]
genExpression e genExpression e
tell [");\n"] tell [");\n"]
genOutput :: Channel -> [OutputItem] -> CGen () genOutput :: A.Channel -> [A.OutputItem] -> CGen ()
genOutput c ois = sequence_ $ map (genOutputItem c) ois genOutput c ois = sequence_ $ map (genOutputItem c) ois
genStop :: CGen () genStop :: CGen ()
@ -510,7 +508,7 @@ genStop = tell ["SetErr ();\n"]
-- FIXME: This could be special-cased to generate if ... else if ... for bits -- FIXME: This could be special-cased to generate if ... else if ... for bits
-- that aren't replicated and don't have specs. -- that aren't replicated and don't have specs.
genIf :: Structured -> CGen () genIf :: A.Structured -> CGen ()
genIf s genIf s
= do label <- makeNonce = do label <- makeNonce
genIfBody label s genIfBody label s
@ -518,19 +516,19 @@ genIf s
tell [label, ":\n;\n"] tell [label, ":\n;\n"]
-- FIXME: This should be generic for any Structured type. -- FIXME: This should be generic for any Structured type.
genIfBody :: String -> Structured -> CGen () genIfBody :: String -> A.Structured -> CGen ()
genIfBody label (Rep m rep s) = genReplicator rep (genIfBody label s) genIfBody label (A.Rep m rep s) = genReplicator rep (genIfBody label s)
genIfBody label (Spec m spec s) = genSpec spec (genIfBody label s) genIfBody label (A.Spec m spec s) = genSpec spec (genIfBody label s)
genIfBody label (OnlyC m (Choice m' e p)) genIfBody label (A.OnlyC m (A.Choice m' e p))
= do tell ["if ("] = do tell ["if ("]
genExpression e genExpression e
tell [") {\n"] tell [") {\n"]
genProcess p genProcess p
tell ["goto ", label, ";\n"] tell ["goto ", label, ";\n"]
tell ["}\n"] tell ["}\n"]
genIfBody label (Several m ss) = sequence_ $ map (genIfBody label) ss genIfBody label (A.Several m ss) = sequence_ $ map (genIfBody label) ss
genWhile :: Expression -> Process -> CGen () genWhile :: A.Expression -> A.Process -> CGen ()
genWhile e p genWhile e p
= do tell ["while ("] = do tell ["while ("]
genExpression e genExpression e
@ -538,7 +536,7 @@ genWhile e p
genProcess p genProcess p
tell ["}\n"] tell ["}\n"]
genProcCall :: Name -> [Actual] -> CGen () genProcCall :: A.Name -> [A.Actual] -> CGen ()
genProcCall n as genProcCall n as
= do genName n = do genName n
tell [" ("] tell [" ("]

7
fco2/Indentation.hs
View File

@ -2,9 +2,10 @@ module Indentation (parseIndentation, indentMarker, outdentMarker, eolMarker) wh
import Data.List import Data.List
-- XXX this doesn't handle multi-line strings -- FIXME this doesn't handle multi-line strings
-- XXX or VALOF processes -- FIXME or VALOF processes
-- XXX or tabs -- FIXME or tabs
-- FIXME or continuation lines...
indentMarker = "__indent" indentMarker = "__indent"
outdentMarker = "__outdent" outdentMarker = "__outdent"

5
fco2/Main.hs
View File

@ -9,6 +9,7 @@ import System.IO
import PrettyShow import PrettyShow
import Parse import Parse
import Unnest
import GenerateC import GenerateC
data Flag = ParseOnly | Verbose data Flag = ParseOnly | Verbose
@ -59,6 +60,10 @@ main = do
progress $ pshow state progress $ pshow state
progress "}}}" progress "}}}"
progress "{{{ Unnest"
(state, ast) <- unnest state ast
progress "}}}"
if ParseOnly `elem` opts then do if ParseOnly `elem` opts then do
putStrLn $ show ast putStrLn $ show ast
else do else do

3
fco2/Makefile
View File

@ -12,7 +12,8 @@ sources = \
Parse.hs \ Parse.hs \
ParseState.hs \ ParseState.hs \
PrettyShow.hs \ PrettyShow.hs \
Types.hs Types.hs \
Unnest.hs
$(targets): $(sources) $(targets): $(sources)
ghc -fglasgow-exts -o fco --make Main ghc -fglasgow-exts -o fco --make Main

70
fco2/Parse.hs
View File

@ -1,6 +1,11 @@
-- vim:foldmethod=marker -- vim:foldmethod=marker
-- Parse occam code -- Parse occam code
-- FIXME: Need to:
-- - insert type checks
-- - remove as many trys as possible; every production should consume input
-- when it's unambiguous
module Parse where module Parse where
import Data.List import Data.List
@ -274,6 +279,35 @@ sepBy1NE item sep
tryTrail :: OccParser a -> OccParser b -> OccParser a tryTrail :: OccParser a -> OccParser b -> OccParser a
tryTrail p q = try (do { v <- p; q; return v }) tryTrail p q = try (do { v <- p; q; return v })
listType :: [A.Type] -> OccParser A.Type
listType [] = fail "expected non-empty list"
listType [t] = return $ A.ArrayUnsized t
listType (t1 : rest@(t2 : _))
= if t1 == t2 then listType rest
else fail "multiple types in list"
matchType :: A.Type -> A.Type -> OccParser ()
matchType et rt
= if rt == et then return ()
else fail $ "type mismatch (got " ++ show rt ++ "; expected " ++ show et ++ ")"
checkMaybe :: String -> Maybe a -> OccParser a
checkMaybe msg op
= case op of
Just t -> return t
Nothing -> fail msg
pTypeOf :: (ParseState -> a -> Maybe A.Type) -> a -> OccParser A.Type
pTypeOf f item
= do st <- getState
case f st item of
Just t -> return t
Nothing -> fail "cannot compute type"
pTypeOfVariable = pTypeOf typeOfVariable
pTypeOfChannel = pTypeOf typeOfChannel
pTypeOfExpression = pTypeOf typeOfExpression
--}}} --}}}
--{{{ name scoping --{{{ name scoping
@ -431,9 +465,9 @@ literal
= try (do { m <- md; v <- real; sLeftR; t <- dataType; sRightR; return $ A.Literal m t v }) = try (do { m <- md; v <- real; sLeftR; t <- dataType; sRightR; return $ A.Literal m t v })
<|> try (do { m <- md; v <- integer; sLeftR; t <- dataType; sRightR; return $ A.Literal m t v }) <|> try (do { m <- md; v <- integer; sLeftR; t <- dataType; sRightR; return $ A.Literal m t v })
<|> try (do { m <- md; v <- byte; sLeftR; t <- dataType; sRightR; return $ A.Literal m t v }) <|> try (do { m <- md; v <- byte; sLeftR; t <- dataType; sRightR; return $ A.Literal m t v })
<|> try (do { m <- md; r <- real; return $ A.Literal m A.Infer r }) <|> try (do { m <- md; r <- real; return $ A.Literal m A.Real32 r })
<|> try (do { m <- md; r <- integer; return $ A.Literal m A.Infer r }) <|> try (do { m <- md; r <- integer; return $ A.Literal m A.Int r })
<|> try (do { m <- md; r <- byte; return $ A.Literal m A.Infer r }) <|> try (do { m <- md; r <- byte; return $ A.Literal m A.Byte r })
<?> "literal" <?> "literal"
real :: OccParser A.LiteralRepr real :: OccParser A.LiteralRepr
@ -481,9 +515,14 @@ table
table' :: OccParser A.Literal table' :: OccParser A.Literal
table' table'
= try (do { m <- md; s <- stringLiteral; sLeftR; t <- dataType; sRightR; return $ A.Literal m t s }) = try (do { m <- md; s <- stringLiteral; sLeftR; t <- dataType; sRightR; return $ A.Literal m t s })
<|> try (do { m <- md; s <- stringLiteral; return $ A.Literal m A.Infer s }) <|> try (do { m <- md; s <- stringLiteral; return $ A.Literal m (A.ArrayUnsized A.Byte) s })
<|> try (do { m <- md; sLeft; es <- sepBy1 expression sComma; sRight; return $ A.Literal m A.Infer (A.ArrayLiteral m es) }) <|> do m <- md
<|> try (maybeSliced table A.SubscriptedLiteral) es <- tryTrail (do { sLeft; sepBy1 expression sComma }) sRight
ps <- getState
ets <- mapM (\e -> checkMaybe "can't type expression" $ typeOfExpression ps e) es
t <- listType ets
return $ A.Literal m t (A.ArrayLiteral m es)
<|> maybeSliced table A.SubscriptedLiteral
<?> "table'" <?> "table'"
stringLiteral :: OccParser A.LiteralRepr stringLiteral :: OccParser A.LiteralRepr
@ -723,15 +762,16 @@ declaration
abbreviation :: OccParser A.Specification abbreviation :: OccParser A.Specification
abbreviation abbreviation
= try (do { m <- md; n <- newVariableName; sIS; v <- variable; sColon; eol; return (n, A.Is m A.Abbrev A.Infer v) }) = do m <- md
<|> try (do { m <- md; s <- specifier; n <- newVariableName; sIS; v <- variable; sColon; eol; return (n, A.Is m A.Abbrev s v) }) (do { (n, v) <- try (do { n <- newVariableName; sIS; v <- variable; return (n, v) }); sColon; eol; t <- pTypeOfVariable v; return (n, A.Is m A.Abbrev t v) }
<|> do { m <- md; sVAL ; <|> do { (s, n, v) <- try (do { s <- specifier; n <- newVariableName; sIS; v <- variable; return (s, n, v) }); sColon; eol; t <- pTypeOfVariable v; matchType s t; return (n, A.Is m A.Abbrev s v) }
try (do { n <- newVariableName; sIS; e <- expression; sColon; eol; return (n, A.IsExpr m A.ValAbbrev A.Infer e) }) <|> do { sVAL ;
<|> do { s <- specifier; n <- newVariableName; sIS; e <- expression; sColon; eol; return (n, A.IsExpr m A.ValAbbrev s e) } } do { (n, e) <- try (do { n <- newVariableName; sIS; e <- expression; return (n, e) }); sColon; eol; t <- pTypeOfExpression e; return (n, A.IsExpr m A.ValAbbrev t e) }
<|> try (do { m <- md; n <- newChannelName <|> newTimerName <|> newPortName; sIS; c <- channel; sColon; eol; return (n, A.IsChannel m A.Infer c) }) <|> do { s <- specifier; n <- newVariableName; sIS; e <- expression; sColon; eol; t <- pTypeOfExpression e; matchType s t; return (n, A.IsExpr m A.ValAbbrev s e) } }
<|> try (do { m <- md; s <- specifier; n <- newChannelName <|> newTimerName <|> newPortName; sIS; c <- channel; sColon; eol; return (n, A.IsChannel m s c) }) <|> try (do { n <- newChannelName <|> newTimerName <|> newPortName; sIS; c <- channel; sColon; eol; t <- pTypeOfChannel c; return (n, A.IsChannel m t c) })
<|> try (do { m <- md; n <- newChannelName; sIS; sLeft; cs <- sepBy1 channel sComma; sRight; sColon; eol; return (n, A.IsChannelArray m A.Infer cs) }) <|> try (do { s <- specifier; n <- newChannelName <|> newTimerName <|> newPortName; sIS; c <- channel; sColon; eol; t <- pTypeOfChannel c; matchType s t; return (n, A.IsChannel m s c) })
<|> try (do { m <- md; s <- specifier; n <- newChannelName; sIS; sLeft; cs <- sepBy1 channel sComma; sRight; sColon; eol; return (n, A.IsChannelArray m s cs) }) <|> try (do { n <- newChannelName; sIS; sLeft; cs <- sepBy1 channel sComma; sRight; sColon; eol; ts <- mapM pTypeOfChannel cs; t <- listType ts; return (n, A.IsChannelArray m t cs) })
<|> try (do { s <- specifier; n <- newChannelName; sIS; sLeft; cs <- sepBy1 channel sComma; sRight; sColon; eol; ts <- mapM pTypeOfChannel cs; t <- listType ts; matchType s t; return (n, A.IsChannelArray m s cs) }))
<?> "abbreviation" <?> "abbreviation"
definition :: OccParser A.Specification definition :: OccParser A.Specification

1
fco2/Types.hs
View File

@ -22,6 +22,7 @@ typeOfName ps n
= case specTypeOfName ps n of = case specTypeOfName ps n of
Just (A.Declaration m t) -> Just t Just (A.Declaration m t) -> Just t
Just (A.Is m am t v) -> typeOfVariable ps v Just (A.Is m am t v) -> typeOfVariable ps v
Just (A.IsExpr m am t e) -> typeOfExpression ps e
Just (A.IsChannel m t c) -> typeOfChannel ps c Just (A.IsChannel m t c) -> typeOfChannel ps c
Just (A.IsChannelArray m t (c:_)) -> typeOfChannel ps c `perhaps` A.ArrayUnsized Just (A.IsChannelArray m t (c:_)) -> typeOfChannel ps c `perhaps` A.ArrayUnsized
Just (A.Retypes m am t v) -> Just t Just (A.Retypes m am t v) -> Just t

11
fco2/Unnest.hs Normal file
View File

@ -0,0 +1,11 @@
module Unnest where
import qualified AST as A
import Metadata
import ParseState
import Types
unnest :: ParseState -> A.Process -> IO (ParseState, A.Process)
unnest ps ast
= do return (ps, ast)

15
fco2/testcases/abbrev.occ Normal file
View File

@ -0,0 +1,15 @@
PROC main ()
INT a, b:
VAL INT c IS 42:
VAL BYTE bb IS 27 (BYTE):
VAL INT d IS a + b:
VAL INT dd IS c + d:
INT e IS a:
[4]BYTE a RETYPES a:
VAL BYTE b IS a[0]:
SEQ i = (a + 20) FOR (b + 30)
VAL INT ii IS (i + 40):
SKIP
:

4
fco2/testcases/arraylit.occ Normal file
View File

@ -0,0 +1,4 @@
PROC P ()
VAL []INT numbers IS [2, 4, 6, 0, 1]:
SKIP
:

4
fco2/testcases/ats1-q7.occ
View File

@ -6,8 +6,8 @@
--{{{ stuff from the standard library --{{{ stuff from the standard library
--#INCLUDE "consts.inc" --#INCLUDE "consts.inc"
--#USE "course.lib" --#USE "course.lib"
VAL BYTE ESCAPE IS 27: VAL BYTE ESCAPE IS 27 (BYTE):
VAL BYTE FLUSH IS 255: VAL BYTE FLUSH IS 255 (BYTE):
PROC out.int (VAL INT n, w, CHAN OF BYTE out) PROC out.int (VAL INT n, w, CHAN OF BYTE out)
STOP STOP
: :

4
fco2/testcases/broken7.occ Normal file
View File

@ -0,0 +1,4 @@
PROC P ()
VAL []INT foo IS [2, 4, 6, "herring", 1]:
SKIP
:

5
fco2/testcases/broken8.occ Normal file
View File

@ -0,0 +1,5 @@
PROC P ()
INT x:
BOOL y IS x:
SKIP
:

2
fco2/testcases/commstime-mini.occ
View File

@ -113,7 +113,7 @@ PROC consume (VAL INT n.loops, CHAN OF INT in, CHAN OF BYTE out)
tim ? t1 tim ? t1
--{{{ report --{{{ report
VAL INT microsecs IS t1 MINUS t0: VAL INT microsecs IS t1 MINUS t0:
VAL INT64 nanosecs IS 1000 * (INT64 microsecs): VAL INT64 nanosecs IS 1000 (INT64) * (INT64 microsecs):
SEQ SEQ
out.string ("Last value received = ", 0, out) out.string ("Last value received = ", 0, out)
out.int (value, 0, out) out.int (value, 0, out)