Give tock its own repo -- i.e. remove everything else and move tock up
This commit is contained in:
Adam Sampson
parent
bf1a0392d5
commit
50731d0b75
199
fco/AST.hs
199
fco/AST.hs
|
|
@ -1,199 +0,0 @@
|
|||
-- Data types for occam abstract syntax
|
||||
-- This is intended to be imported qualified:
|
||||
-- import qualified AST as O
|
||||
|
||||
module AST where
|
||||
|
||||
import Data.Generics
|
||||
import Metadata
|
||||
|
||||
data Name = Name Meta String
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
|
||||
data Tag = Tag Meta String
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
|
||||
data Type =
|
||||
Bool
|
||||
| Byte
|
||||
| Int | Int16 | Int32 | Int64
|
||||
| Real32 | Real64
|
||||
| Array Expression Type
|
||||
| ArrayUnsized Type
|
||||
| UserType Name
|
||||
| Chan Type
|
||||
| Counted Type Type
|
||||
| Any
|
||||
| Timer
|
||||
| Port Type
|
||||
| Val Type
|
||||
| Infer -- for where the type is not given but can be worked out (e.g. "x IS y:")
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
|
||||
data ConversionMode =
|
||||
DefaultConversion
|
||||
| Round
|
||||
| Trunc
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
|
||||
data Subscript =
|
||||
Subscript Meta Expression
|
||||
| SubscriptTag Meta Tag
|
||||
| SubFromFor Meta Expression Expression
|
||||
| SubFrom Meta Expression
|
||||
| SubFor Meta Expression
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
|
||||
data LiteralRepr =
|
||||
RealLiteral Meta String
|
||||
| IntLiteral Meta String
|
||||
| HexLiteral Meta String
|
||||
| ByteLiteral Meta String
|
||||
| StringLiteral Meta String
|
||||
| ArrayLiteral Meta [Expression]
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
|
||||
data Literal =
|
||||
Literal Meta Type LiteralRepr
|
||||
| SubscriptedLiteral Meta Subscript Literal
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
|
||||
data Variable =
|
||||
Variable Meta Name
|
||||
| SubscriptedVariable Meta Subscript Variable
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
|
||||
data Expression =
|
||||
Monadic Meta MonadicOp Expression
|
||||
| Dyadic Meta DyadicOp Expression Expression
|
||||
| MostPos Meta Type
|
||||
| MostNeg Meta Type
|
||||
| Size Meta Type
|
||||
| Conversion Meta ConversionMode Type Expression
|
||||
| ExprVariable Meta Variable
|
||||
| ExprLiteral Meta Literal
|
||||
| True Meta
|
||||
| False Meta
|
||||
| FunctionCall Meta Name [Expression]
|
||||
| BytesInType Meta Type
|
||||
| OffsetOf Meta Type Tag
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
|
||||
data ExpressionList =
|
||||
FunctionCallList Meta Name [Expression]
|
||||
| ExpressionList Meta [Expression]
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
|
||||
data MonadicOp =
|
||||
MonadicBytesIn
|
||||
| MonadicSubtr
|
||||
| MonadicBitNot
|
||||
| MonadicNot
|
||||
| MonadicSize
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
|
||||
data DyadicOp =
|
||||
Add | Subtr | Mul | Div | Rem
|
||||
| Plus | Minus | Times
|
||||
| BitAnd | BitOr | BitXor
|
||||
| And | Or
|
||||
| Eq | NotEq | Less | More | LessEq | MoreEq
|
||||
| After
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
|
||||
data InputItem =
|
||||
InCounted Meta Variable Variable
|
||||
| InVariable Meta Variable
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
|
||||
data OutputItem =
|
||||
OutCounted Meta Expression Expression
|
||||
| OutExpression Meta Expression
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
|
||||
data Replicator = For Meta Name Expression Expression
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
|
||||
data Choice = Choice Meta Expression Process
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
|
||||
data Alternative =
|
||||
Alternative Meta Variable InputMode Process
|
||||
| AlternativeCond Meta Expression Variable InputMode Process
|
||||
| AlternativeSkip Meta Expression Process
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
|
||||
data Option =
|
||||
Option Meta [Expression] Process
|
||||
| Else Meta Process
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
|
||||
data Variant = Variant Meta Tag [InputItem] Process
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
|
||||
-- This represents something that can contain local replicators and specifications.
|
||||
-- (This ought to be a parametric type, "Structured Variant" etc., but doing so
|
||||
-- makes using generic functions across it hard.)
|
||||
data Structured =
|
||||
Rep Meta Replicator Structured
|
||||
| Spec Meta Specification Structured
|
||||
| OnlyV Meta Variant
|
||||
| OnlyC Meta Choice
|
||||
| OnlyO Meta Option
|
||||
| OnlyP Meta Process
|
||||
| OnlyA Meta Alternative
|
||||
| Several Meta [Structured]
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
|
||||
data InputMode =
|
||||
InputSimple Meta [InputItem]
|
||||
| InputCase Meta Structured
|
||||
| InputAfter Meta Expression
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
|
||||
type Formals = [(Type, Name)]
|
||||
type Specification = (Name, SpecType)
|
||||
data SpecType =
|
||||
Place Meta Expression
|
||||
| Declaration Meta Type
|
||||
| Is Meta Type Variable
|
||||
| ValIs Meta Type Expression
|
||||
| DataTypeIs Meta Type
|
||||
| DataTypeRecord Meta Bool [(Type, Tag)]
|
||||
| ProtocolIs Meta [Type]
|
||||
| ProtocolCase Meta [(Tag, [Type])]
|
||||
| Proc Meta Formals Process
|
||||
| Function Meta [Type] Formals ValueProcess
|
||||
| Retypes Meta Type Variable
|
||||
| Reshapes Meta Type Variable
|
||||
| ValRetypes Meta Type Variable
|
||||
| ValReshapes Meta Type Variable
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
|
||||
data ValueProcess =
|
||||
ValOfSpec Meta Specification ValueProcess
|
||||
| ValOf Meta Process ExpressionList
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
|
||||
data Process =
|
||||
ProcSpec Meta Specification Process
|
||||
| Assign Meta [Variable] ExpressionList
|
||||
| Input Meta Variable InputMode
|
||||
| Output Meta Variable [OutputItem]
|
||||
| OutputCase Meta Variable Tag [OutputItem]
|
||||
| Skip Meta
|
||||
| Stop Meta
|
||||
| Main Meta
|
||||
| Seq Meta [Process]
|
||||
| SeqRep Meta Replicator Process
|
||||
| If Meta Structured
|
||||
| Case Meta Expression Structured
|
||||
| While Meta Expression Process
|
||||
| Par Meta Bool [Process]
|
||||
| ParRep Meta Bool Replicator Process
|
||||
| PlacedPar Meta Structured
|
||||
| Processor Meta Expression Process
|
||||
| Alt Meta Bool Structured
|
||||
| ProcCall Meta Name [Expression]
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
|
||||
125
fco/ASTPasses.hs
125
fco/ASTPasses.hs
|
|
@ -1,125 +0,0 @@
|
|||
-- Passes across the AST
|
||||
|
||||
module ASTPasses (astPasses) where
|
||||
|
||||
import List
|
||||
import Data.Generics
|
||||
import Control.Monad.State
|
||||
import Metadata
|
||||
import qualified AST as A
|
||||
|
||||
{- 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 =
|
||||
[ ("Unique names", uniqueNamesPass)
|
||||
, ("C-style names", cStyleNamesPass)
|
||||
]
|
||||
|
||||
type UniqueState = (Int, [(String, String)])
|
||||
type UniqueM t = State UniqueState t
|
||||
|
||||
uniqueNamesPass :: A.Process -> A.Process
|
||||
uniqueNamesPass p = evalState (doAny p) (0, [])
|
||||
where
|
||||
doAny :: Data t => t -> UniqueM t
|
||||
doAny = doGeneric `extM` doName `extM` doProcess `extM` doValueProcess `extM` doStructured
|
||||
|
||||
doGeneric :: Data t => t -> UniqueM t
|
||||
doGeneric = gmapM doAny
|
||||
|
||||
withNames :: Data t => [A.Name] -> t -> UniqueM ([A.Name], t)
|
||||
withNames ns b = do
|
||||
(count, vars) <- get
|
||||
let (ms, names) = unzip [(m, s) | A.Name m s <- ns]
|
||||
let names' = [n ++ "." ++ show (count + i) | (n, i) <- zip names [0..]]
|
||||
put (count + length ns, (zip names names') ++ vars)
|
||||
|
||||
b' <- doAny b
|
||||
|
||||
(count', _) <- get
|
||||
put (count', vars)
|
||||
|
||||
return ([A.Name m n | (m, n) <- zip ms names'], b')
|
||||
|
||||
withName :: Data t => A.Name -> t -> UniqueM (A.Name, t)
|
||||
withName n b = do
|
||||
(n':[], b') <- withNames [n] b
|
||||
return (n', b')
|
||||
|
||||
withFormals :: Data t => A.Formals -> t -> UniqueM (A.Formals, t)
|
||||
withFormals fs b = do
|
||||
(fns', b') <- withNames (map snd fs) b
|
||||
ts' <- mapM doAny (map fst fs)
|
||||
return (zip ts' fns', b')
|
||||
|
||||
withSpec :: Data t => A.Specification -> t -> UniqueM (A.Specification, t)
|
||||
withSpec (n, st) b = do
|
||||
st' <- case st of
|
||||
A.Proc m fs pp -> do (fs', pp') <- withFormals fs pp
|
||||
return $ A.Proc m fs' pp'
|
||||
A.Function m rt fs pp -> do (fs', pp') <- withFormals fs pp
|
||||
return $ A.Function m rt fs' pp'
|
||||
otherwise -> doAny st
|
||||
(n', b') <- withName n b
|
||||
return ((n', st'), b')
|
||||
|
||||
withRep :: Data t => A.Replicator -> t -> UniqueM (A.Replicator, t)
|
||||
withRep (A.For m n f1 f2) b = do
|
||||
(n', b') <- withName n b
|
||||
f1' <- doAny f1
|
||||
f2' <- doAny f2
|
||||
return $ (A.For m n' f1' f2', b')
|
||||
|
||||
doProcess :: A.Process -> UniqueM A.Process
|
||||
doProcess p = case p of
|
||||
A.ProcSpec m s b -> do (s', b') <- withSpec s b
|
||||
return $ A.ProcSpec m s' b'
|
||||
A.SeqRep m r b -> do (r', b') <- withRep r b
|
||||
return $ A.SeqRep m r' b'
|
||||
A.ParRep m pri r b -> do (r', b') <- withRep r b
|
||||
return $ A.ParRep m pri r' b'
|
||||
otherwise -> doGeneric p
|
||||
|
||||
doValueProcess :: A.ValueProcess -> UniqueM A.ValueProcess
|
||||
doValueProcess p = case p of
|
||||
A.ValOfSpec m s b -> do (s', b') <- withSpec s b
|
||||
return $ A.ValOfSpec m s' b'
|
||||
otherwise -> doGeneric p
|
||||
|
||||
doStructured :: A.Structured -> UniqueM A.Structured
|
||||
doStructured p = case p of
|
||||
A.Rep m r b -> do (r', b') <- withRep r b
|
||||
return $ A.Rep m r' b'
|
||||
A.Spec m s b -> do (s', b') <- withSpec s b
|
||||
return $ A.Spec m s' b'
|
||||
otherwise -> doGeneric p
|
||||
|
||||
doName :: A.Name -> UniqueM A.Name
|
||||
doName (A.Name m s) = do
|
||||
(_, vars) <- get
|
||||
let s' = case lookup s vars of
|
||||
Just n -> n
|
||||
Nothing -> dieP m $ "Name " ++ s ++ " not declared before use"
|
||||
return $ A.Name m s'
|
||||
|
||||
cStyleNamesPass :: A.Process -> A.Process
|
||||
cStyleNamesPass = everywhere (mkT doName)
|
||||
where
|
||||
doName :: A.Name -> A.Name
|
||||
doName (A.Name m s) = A.Name m [if c == '.' then '_' else c | c <- s]
|
||||
|
||||
131
fco/COutput.hs
131
fco/COutput.hs
|
|
@ -1,131 +0,0 @@
|
|||
-- Write C code
|
||||
|
||||
module COutput where
|
||||
|
||||
import List
|
||||
import Data.Generics
|
||||
import Metadata
|
||||
import qualified AST as A
|
||||
|
||||
concatWith x l = concat $ intersperse x l
|
||||
bracketed s = "(" ++ s ++ ")"
|
||||
|
||||
unimp :: Data a => a -> String
|
||||
unimp = unimpG `extQ` unimpS `extQ` unimpM
|
||||
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
|
||||
|
||||
unimpM :: Meta -> String
|
||||
unimpM m = formatSourcePos m
|
||||
|
||||
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
|
||||
|
||||
87
fco/Main.hs
87
fco/Main.hs
|
|
@ -1,87 +0,0 @@
|
|||
-- Driver for FCO
|
||||
|
||||
module Main where
|
||||
|
||||
import List
|
||||
import System
|
||||
import System.Console.GetOpt
|
||||
import System.IO
|
||||
|
||||
import PrettyShow
|
||||
import Parse
|
||||
import SExpression
|
||||
import Pass
|
||||
import PTPasses
|
||||
import PTToAST
|
||||
import ASTPasses
|
||||
import COutput
|
||||
|
||||
data Flag = ParseOnly | SOccamOnly | Verbose
|
||||
deriving (Eq, Show)
|
||||
|
||||
options :: [OptDescr Flag]
|
||||
options =
|
||||
[ Option [] ["parse-tree"] (NoArg ParseOnly) "parse input files and output S-expression parse tree"
|
||||
, Option [] ["soccam"] (NoArg SOccamOnly) "parse input files and output soccam"
|
||||
, Option ['v'] ["verbose"] (NoArg Verbose) "show more detail about what's going on"
|
||||
]
|
||||
|
||||
getOpts :: [String] -> IO ([Flag], [String])
|
||||
getOpts argv =
|
||||
case getOpt RequireOrder options argv of
|
||||
(o,n,[] ) -> return (o,n)
|
||||
(_,_,errs) -> error (concat errs ++ usageInfo header options)
|
||||
where header = "Usage: fco [OPTION...] SOURCEFILE"
|
||||
|
||||
numberedListing :: String -> String
|
||||
numberedListing s = concat $ intersperse "\n" $ [(show n) ++ ": " ++ s | (n, s) <- zip [1..] (lines s)]
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
argv <- getArgs
|
||||
(opts, args) <- getOpts argv
|
||||
|
||||
let fn = case args of
|
||||
[fn] -> fn
|
||||
_ -> error "Must specify a single input file"
|
||||
|
||||
let progress = if Verbose `elem` opts then hPutStrLn stderr else (\s -> return ())
|
||||
|
||||
progress $ "Options: " ++ (show opts)
|
||||
progress $ "Compiling " ++ fn
|
||||
progress ""
|
||||
|
||||
progress "{{{ Preprocessor"
|
||||
preprocessed <- readSource fn
|
||||
progress $ numberedListing preprocessed
|
||||
progress "}}}"
|
||||
|
||||
progress "{{{ Parser"
|
||||
let pt = parseSource preprocessed fn
|
||||
progress $ pshow pt
|
||||
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"
|
||||
pt' <- runPasses ptPasses progress pt
|
||||
progress "}}}"
|
||||
|
||||
progress "{{{ PT to AST"
|
||||
let ast = ptToAST pt'
|
||||
progress $ pshow ast
|
||||
progress "}}}"
|
||||
|
||||
progress "{{{ AST passes"
|
||||
ast' <- runPasses astPasses progress ast
|
||||
progress "}}}"
|
||||
|
||||
progress "{{{ C output"
|
||||
putStr $ writeC ast'
|
||||
progress "}}}"
|
||||
|
||||
progress "Done"
|
||||
|
||||
38
fco/Makefile
38
fco/Makefile
|
|
@ -1,38 +0,0 @@
|
|||
targets = fco
|
||||
|
||||
all: $(targets)
|
||||
|
||||
sources = \
|
||||
AST.hs \
|
||||
ASTPasses.hs \
|
||||
COutput.hs \
|
||||
Main.hs \
|
||||
Metadata.hs \
|
||||
Parse.hs \
|
||||
Pass.hs \
|
||||
PrettyShow.hs \
|
||||
PT.hs \
|
||||
PTPasses.hs \
|
||||
SExpression.hs \
|
||||
PTToAST.hs
|
||||
|
||||
$(targets): $(sources)
|
||||
ghc -fglasgow-exts -o fco --make Main
|
||||
|
||||
tests = $(wildcard testcases/*.occ)
|
||||
|
||||
test: $(targets) $(tests)
|
||||
@set -e; for x in $(tests); do \
|
||||
echo -n "$$x: " ; \
|
||||
if ! ./fco --parse-tree $$x >$$x.log 2>&1 ; then \
|
||||
echo "parse failed" ; \
|
||||
elif ! ./fco -v $$x >$$x.log 2>&1 ; then \
|
||||
echo "full failed" ; \
|
||||
else \
|
||||
echo "ok" ; \
|
||||
fi ; \
|
||||
done
|
||||
|
||||
clean:
|
||||
rm -f $(targets) *.o *.hi
|
||||
|
||||
|
|
@ -1,30 +0,0 @@
|
|||
-- Metadata types
|
||||
|
||||
module Metadata where
|
||||
|
||||
import Data.Generics
|
||||
import Data.List
|
||||
|
||||
type Meta = [Metadatum]
|
||||
|
||||
data Metadatum =
|
||||
SourcePos String Int Int
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
|
||||
findSourcePos :: Meta -> Maybe Metadatum
|
||||
findSourcePos ms = find (\x -> case x of SourcePos _ _ _ -> True
|
||||
otherwise -> False) ms
|
||||
|
||||
formatSourcePos :: Meta -> String
|
||||
formatSourcePos m = case findSourcePos m of
|
||||
Just (SourcePos f l c) -> "<@" ++ show l ++ ":" ++ show c ++ ">"
|
||||
Nothing -> "<?>"
|
||||
|
||||
die :: Monad m => String -> m a
|
||||
die s = error $ "error: " ++ s
|
||||
|
||||
dieP :: Monad m => Meta -> String -> m a
|
||||
dieP m s = case findSourcePos m of
|
||||
Just (SourcePos f l c) -> die $ f ++ ":" ++ (show l) ++ ":" ++ (show c) ++ ": " ++ s
|
||||
Nothing -> die $ "unknown position: " ++ s
|
||||
|
||||
159
fco/PT.hs
159
fco/PT.hs
|
|
@ -1,159 +0,0 @@
|
|||
-- occam parse tree
|
||||
-- This is intended to be imported qualified:
|
||||
-- import qualified PT as N
|
||||
|
||||
module PT where
|
||||
|
||||
import Data.Generics
|
||||
import Metadata
|
||||
|
||||
data Node = Node Meta NodeType
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
|
||||
data NodeType =
|
||||
Decl Node Node
|
||||
| Alt [Node]
|
||||
| AltRep Node Node
|
||||
| PriAlt [Node]
|
||||
| PriAltRep Node Node
|
||||
|
||||
| In Node Node
|
||||
| InSimple [Node]
|
||||
-- e.g. In (Name "c") (InCase [Variant .., Variant ..])
|
||||
| Variant Node Node
|
||||
| InCase [Node]
|
||||
| InTag Node
|
||||
| InAfter Node
|
||||
|
||||
| Out Node [Node]
|
||||
| OutCase Node Node [Node]
|
||||
| ExpList [Node]
|
||||
| Assign [Node] Node
|
||||
| If [Node]
|
||||
| IfRep Node Node
|
||||
| While Node Node
|
||||
| Par [Node]
|
||||
| ParRep Node Node
|
||||
| PriPar [Node]
|
||||
| PriParRep Node Node
|
||||
| PlacedPar [Node]
|
||||
| PlacedParRep Node Node
|
||||
| Processor Node Node
|
||||
| Skip
|
||||
| Stop
|
||||
| Case Node [Node]
|
||||
| Seq [Node]
|
||||
| SeqRep Node Node
|
||||
| ProcCall Node [Node]
|
||||
| MainProcess
|
||||
|
||||
| Vars Node [Node]
|
||||
| Is Node Node
|
||||
| IsType Node Node Node
|
||||
| ValIs Node Node
|
||||
| ValIsType Node Node Node
|
||||
| Place Node Node
|
||||
|
||||
| DataType Node Node
|
||||
| Record [Node]
|
||||
| PackedRecord [Node]
|
||||
| Fields Node [Node]
|
||||
| Protocol Node [Node]
|
||||
| TaggedProtocol Node [Node]
|
||||
| Tag Node [Node]
|
||||
-- e.g. Proc (Name "out.string") [Formals Int [Name "x", Name "y"], Formal Bool [Name "z"]]
|
||||
| Formals Node [Node]
|
||||
| Proc Node [Node] Node
|
||||
| Func Node [Node] [Node] Node
|
||||
| FuncIs Node [Node] [Node] Node
|
||||
| Retypes Node Node Node
|
||||
| ValRetypes Node Node Node
|
||||
| Reshapes Node Node Node
|
||||
| ValReshapes Node Node Node
|
||||
| ValOf Node Node
|
||||
|
||||
| Sub Node Node
|
||||
| SubPlain Node
|
||||
| SubFromFor Node Node
|
||||
| SubFrom Node
|
||||
| SubFor Node
|
||||
|
||||
| CaseExps [Node] Node
|
||||
| Else Node
|
||||
|
||||
| For Node Node Node
|
||||
|
||||
| Conv Node Node
|
||||
| Round Node Node
|
||||
| Trunc Node Node
|
||||
|
||||
| DyadicOp Node Node Node
|
||||
| Add
|
||||
| Subtr
|
||||
| Mul
|
||||
| Div
|
||||
| Rem
|
||||
| Plus
|
||||
| Minus
|
||||
| Times
|
||||
| BitAnd
|
||||
| BitOr
|
||||
| BitXor
|
||||
| And
|
||||
| Or
|
||||
| Eq
|
||||
| NEq
|
||||
| Less
|
||||
| More
|
||||
| LessEq
|
||||
| MoreEq
|
||||
| After
|
||||
|
||||
| MonadicOp Node Node
|
||||
| MonSub
|
||||
| MonBitNot
|
||||
| MonNot
|
||||
| MonSize
|
||||
|
||||
| MostPos Node
|
||||
| MostNeg Node
|
||||
| Size Node
|
||||
| Call Node [Node]
|
||||
| BytesIn Node
|
||||
| OffsetOf Node Node
|
||||
|
||||
| Guard Node Node
|
||||
| CondGuard Node Node
|
||||
|
||||
| Choice Node Node
|
||||
|
||||
| Val Node
|
||||
| ChanOf Node
|
||||
| PortOf Node
|
||||
| Timer
|
||||
| Array Node Node
|
||||
| ArrayUnsized Node
|
||||
| Counted Node Node
|
||||
| Bool
|
||||
| Byte
|
||||
| Int
|
||||
| Int16
|
||||
| Int32
|
||||
| Int64
|
||||
| Real32
|
||||
| Real64
|
||||
| Any
|
||||
|
||||
| TypedLit Node Node
|
||||
| LitReal String
|
||||
| LitInt String
|
||||
| LitHex String
|
||||
| LitByte String
|
||||
| LitString String
|
||||
| LitArray [Node]
|
||||
| True
|
||||
| False
|
||||
| Name String
|
||||
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
|
||||
|
|
@ -1,8 +0,0 @@
|
|||
-- Passes across the parse tree
|
||||
|
||||
module PTPasses (ptPasses) where
|
||||
|
||||
import qualified PT as P
|
||||
|
||||
ptPasses = []
|
||||
|
||||
252
fco/PTToAST.hs
252
fco/PTToAST.hs
|
|
@ -1,252 +0,0 @@
|
|||
-- Convert the parse tree into the AST
|
||||
|
||||
module PTToAST (ptToAST) where
|
||||
|
||||
import Metadata
|
||||
import qualified PT as N
|
||||
import qualified AST as O
|
||||
|
||||
doName :: N.Node -> O.Name
|
||||
doName (N.Node m (N.Name s)) = O.Name m s
|
||||
doName n = error $ "Failed to translate to Name: " ++ (show n)
|
||||
|
||||
doTag :: N.Node -> O.Tag
|
||||
doTag (N.Node m (N.Name s)) = O.Tag m s
|
||||
|
||||
doType :: N.Node -> O.Type
|
||||
doType n@(N.Node _ nt) = case nt of
|
||||
N.Bool -> O.Bool
|
||||
N.Byte -> O.Byte
|
||||
N.Int -> O.Int
|
||||
N.Int16 -> O.Int16
|
||||
N.Int32 -> O.Int32
|
||||
N.Int64 -> O.Int64
|
||||
N.Real32 -> O.Real32
|
||||
N.Real64 -> O.Real64
|
||||
N.Array e t -> O.Array (doExpression e) (doType t)
|
||||
N.ArrayUnsized t -> O.ArrayUnsized (doType t)
|
||||
N.Name _ -> O.UserType (doName n)
|
||||
N.ChanOf t -> O.Chan (doType t)
|
||||
N.Counted ct dt -> O.Counted (doType ct) (doType dt)
|
||||
N.Any -> O.Any
|
||||
N.Timer -> O.Timer
|
||||
N.PortOf t -> O.Port (doType t)
|
||||
N.Val t -> O.Val (doType t)
|
||||
|
||||
doMonadicOp :: N.Node -> O.MonadicOp
|
||||
doMonadicOp n@(N.Node _ nt) = case nt of
|
||||
N.MonSub -> O.MonadicSubtr
|
||||
N.MonBitNot -> O.MonadicBitNot
|
||||
N.MonNot -> O.MonadicNot
|
||||
N.MonSize -> O.MonadicSize
|
||||
|
||||
doDyadicOp :: N.Node -> O.DyadicOp
|
||||
doDyadicOp n@(N.Node _ nt) = case nt of
|
||||
N.Add -> O.Add
|
||||
N.Subtr -> O.Subtr
|
||||
N.Mul -> O.Mul
|
||||
N.Div -> O.Div
|
||||
N.Rem -> O.Rem
|
||||
N.Plus -> O.Plus
|
||||
N.Minus -> O.Minus
|
||||
N.Times -> O.Times
|
||||
N.BitAnd -> O.BitAnd
|
||||
N.BitOr -> O.BitOr
|
||||
N.BitXor -> O.BitXor
|
||||
N.And -> O.And
|
||||
N.Or -> O.Or
|
||||
N.Eq -> O.Eq
|
||||
N.NEq -> O.NotEq
|
||||
N.Less -> O.Less
|
||||
N.More -> O.More
|
||||
N.LessEq -> O.LessEq
|
||||
N.MoreEq -> O.MoreEq
|
||||
N.After -> O.After
|
||||
|
||||
doSubscript :: N.Node -> O.Subscript
|
||||
doSubscript n@(N.Node m nt) = case nt of
|
||||
N.SubPlain e -> O.Subscript m (doExpression e)
|
||||
N.SubFromFor e f -> O.SubFromFor m (doExpression e) (doExpression f)
|
||||
N.SubFrom e -> O.SubFrom m (doExpression e)
|
||||
N.SubFor f -> O.SubFor m (doExpression f)
|
||||
|
||||
doLiteral :: N.Node -> O.Literal
|
||||
doLiteral n@(N.Node m nt) = case nt of
|
||||
N.TypedLit t l -> O.Literal m (doType t) rep where (O.Literal _ _ rep) = doLiteral l
|
||||
N.LitReal s -> O.Literal m O.Real32 (O.RealLiteral m s)
|
||||
N.LitInt s -> O.Literal m O.Int (O.IntLiteral m s)
|
||||
N.LitHex s -> O.Literal m O.Int (O.HexLiteral m s)
|
||||
N.LitByte s -> O.Literal m O.Byte (O.ByteLiteral m s)
|
||||
N.LitString s -> O.Literal m (O.ArrayUnsized O.Byte) (O.StringLiteral m s)
|
||||
N.LitArray ns -> O.Literal m O.Infer (O.ArrayLiteral m (map doExpression ns))
|
||||
N.Sub s l -> O.SubscriptedLiteral m (doSubscript s) (doLiteral l)
|
||||
|
||||
doVariable :: N.Node -> O.Variable
|
||||
doVariable n@(N.Node m nt) = case nt of
|
||||
N.Name _ -> O.Variable m (doName n)
|
||||
N.Sub s v -> O.SubscriptedVariable m (doSubscript s) (doVariable v)
|
||||
_ -> error $ "Failed to translate to Variable: " ++ (show n)
|
||||
|
||||
doExpression :: N.Node -> O.Expression
|
||||
doExpression n@(N.Node m nt) = case nt of
|
||||
N.MonadicOp o a -> O.Monadic m (doMonadicOp o) (doExpression a)
|
||||
N.DyadicOp o a b -> O.Dyadic m (doDyadicOp o) (doExpression a) (doExpression b)
|
||||
N.MostPos t -> O.MostPos m (doType t)
|
||||
N.MostNeg t -> O.MostNeg m (doType t)
|
||||
N.Size t -> O.Size m (doType t)
|
||||
N.Conv t e -> O.Conversion m O.DefaultConversion (doType t) (doExpression e)
|
||||
N.Round t e -> O.Conversion m O.Round (doType t) (doExpression e)
|
||||
N.Trunc t e -> O.Conversion m O.Trunc (doType t) (doExpression e)
|
||||
N.TypedLit _ _ -> O.ExprLiteral m $ doLiteral n
|
||||
N.LitReal _ -> O.ExprLiteral m $ doLiteral n
|
||||
N.LitInt _ -> O.ExprLiteral m $ doLiteral n
|
||||
N.LitHex _ -> O.ExprLiteral m $ doLiteral n
|
||||
N.LitByte _ -> O.ExprLiteral m $ doLiteral n
|
||||
N.LitString _ -> O.ExprLiteral m $ doLiteral n
|
||||
N.LitArray _ -> O.ExprLiteral m $ doLiteral n
|
||||
N.True -> O.True m
|
||||
N.False -> O.False m
|
||||
N.Call f es -> O.FunctionCall m (doName f) (map doExpression es)
|
||||
N.BytesIn t -> O.BytesInType m (doType t)
|
||||
N.OffsetOf t g -> O.OffsetOf m (doType t) (doTag g)
|
||||
otherwise -> O.ExprVariable m (doVariable n)
|
||||
|
||||
doExpressionList :: N.Node -> O.ExpressionList
|
||||
doExpressionList n@(N.Node m nt) = case nt of
|
||||
N.Call f es -> O.FunctionCallList m (doName f) (map doExpression es)
|
||||
N.ExpList es -> O.ExpressionList m (map doExpression es)
|
||||
|
||||
doReplicator :: N.Node -> O.Replicator
|
||||
doReplicator n@(N.Node m nt) = case nt of
|
||||
N.For v f t -> O.For m (doName v) (doExpression f) (doExpression t)
|
||||
|
||||
doFields :: [N.Node] -> [(O.Type, O.Tag)]
|
||||
doFields ns = concat $ [[(doType t, doTag f) | f <- fs] | (N.Node _ (N.Fields t fs)) <- ns]
|
||||
|
||||
doFormals :: [N.Node] -> [(O.Type, O.Name)]
|
||||
doFormals fs = concat $ [[(doType t, doName n) | n <- ns] | (N.Node _ (N.Formals t ns)) <- fs]
|
||||
|
||||
doVariant :: N.Node -> O.Structured
|
||||
doVariant n@(N.Node m nt) = case nt of
|
||||
N.Variant (N.Node _ (N.Tag t is)) p -> O.OnlyV m $ O.Variant m (doTag t) (map doInputItem is) (doProcess p)
|
||||
N.Decl s v -> doSpecifications s O.Spec (doVariant v)
|
||||
|
||||
doChoice :: N.Node -> O.Structured
|
||||
doChoice n@(N.Node m nt) = case nt of
|
||||
N.If cs -> O.Several m $ map doChoice cs
|
||||
N.IfRep r c -> O.Rep m (doReplicator r) (doChoice c)
|
||||
N.Choice b p -> O.OnlyC m $ O.Choice m (doExpression b) (doProcess p)
|
||||
N.Decl s c -> doSpecifications s O.Spec (doChoice c)
|
||||
|
||||
doOption :: N.Node -> O.Structured
|
||||
doOption n@(N.Node m nt) = case nt of
|
||||
N.CaseExps cs p -> O.OnlyO m $ O.Option m (map doExpression cs) (doProcess p)
|
||||
N.Else p -> O.OnlyO m $ O.Else m (doProcess p)
|
||||
N.Decl s o -> doSpecifications s O.Spec (doOption o)
|
||||
|
||||
doInputItem :: N.Node -> O.InputItem
|
||||
doInputItem n@(N.Node m nt) = case nt of
|
||||
N.Counted c d -> O.InCounted m (doVariable c) (doVariable d)
|
||||
otherwise -> O.InVariable m (doVariable n)
|
||||
|
||||
doOutputItem :: N.Node -> O.OutputItem
|
||||
doOutputItem n@(N.Node m nt) = case nt of
|
||||
N.Counted c d -> O.OutCounted m (doExpression c) (doExpression d)
|
||||
otherwise -> O.OutExpression m (doExpression n)
|
||||
|
||||
doInputMode :: N.Node -> O.InputMode
|
||||
doInputMode n@(N.Node m nt) = case nt of
|
||||
N.InSimple is -> O.InputSimple m (map doInputItem is)
|
||||
N.InCase vs -> O.InputCase m (O.Several m $ map doVariant vs)
|
||||
N.InTag (N.Node _ (N.Tag t is)) -> O.InputCase m (O.OnlyV m $ O.Variant m (doTag t) (map doInputItem is) (O.Skip m))
|
||||
N.InAfter e -> O.InputAfter m (doExpression e)
|
||||
|
||||
doSimpleSpec :: N.Node -> O.Specification
|
||||
doSimpleSpec n@(N.Node m nt) = case nt of
|
||||
N.Is d v -> (doName d, O.Is m O.Infer (doVariable v))
|
||||
N.IsType t d v -> (doName d, O.Is m (doType t) (doVariable v))
|
||||
N.ValIs d e -> (doName d, O.ValIs m O.Infer (doExpression e))
|
||||
N.ValIsType t d e -> (doName d, O.ValIs m (doType t) (doExpression e))
|
||||
N.Place v e -> (doName v, O.Place m (doExpression e))
|
||||
N.DataType n (N.Node _ (N.Record fs)) -> (doName n, O.DataTypeRecord m False (doFields fs))
|
||||
N.DataType n (N.Node _ (N.PackedRecord fs)) -> (doName n, O.DataTypeRecord m True (doFields fs))
|
||||
N.DataType n t -> (doName n, O.DataTypeIs m (doType t))
|
||||
N.Protocol n is -> (doName n, O.ProtocolIs m (map doType is))
|
||||
N.TaggedProtocol n ts -> (doName n, O.ProtocolCase m [(doTag tn, map doType tts) | (N.Node _ (N.Tag tn tts)) <- ts])
|
||||
N.Proc n fs p -> (doName n, O.Proc m (doFormals fs) (doProcess p))
|
||||
N.Func n rs fs vp -> (doName n, O.Function m (map doType rs) (doFormals fs) (doValueProcess vp))
|
||||
N.FuncIs n rs fs el -> (doName n, O.Function m (map doType rs) (doFormals fs) (O.ValOf m (O.Skip m) (doExpressionList el)))
|
||||
N.Retypes t d s -> (doName d, O.Retypes m (doType t) (doVariable s))
|
||||
N.ValRetypes t d s -> (doName d, O.ValRetypes m (doType t) (doVariable s))
|
||||
N.Reshapes t d s -> (doName d, O.Reshapes m (doType t) (doVariable s))
|
||||
N.ValReshapes t d s -> (doName d, O.ValReshapes m (doType t) (doVariable s))
|
||||
|
||||
doSpecifications :: N.Node -> (Meta -> O.Specification -> a -> a) -> a -> a
|
||||
doSpecifications n@(N.Node m nt) comb arg = case nt of
|
||||
N.Vars t [] -> arg
|
||||
N.Vars t (v:vs) -> comb m (doName v, O.Declaration m (doType t)) (doSpecifications (N.Node m (N.Vars t vs)) comb arg)
|
||||
otherwise -> comb m (doSimpleSpec n) arg
|
||||
|
||||
doAlternative :: N.Node -> O.Alternative
|
||||
doAlternative n@(N.Node m nt) = case nt of
|
||||
N.Guard (N.Node _ (N.In c md)) p -> O.Alternative m (doVariable c) (doInputMode md) (doProcess p)
|
||||
N.Guard (N.Node _ (N.CondGuard b (N.Node _ (N.In c md)))) p -> O.AlternativeCond m (doExpression b) (doVariable c) (doInputMode md) (doProcess p)
|
||||
N.Guard (N.Node _ (N.CondGuard b (N.Node _ N.Skip))) p -> O.AlternativeSkip m (doExpression b) (doProcess p)
|
||||
-- ALT over "? CASE": the O.Skip that gets inserted here doesn't correspond
|
||||
-- to anything in real occam; it's just there to let us handle these the same
|
||||
-- way as the regular ALT inputs.
|
||||
N.In c md@(N.Node _ (N.InCase _)) -> O.Alternative m (doVariable c) (doInputMode md) (O.Skip m)
|
||||
N.CondGuard b (N.Node _ (N.In c md@(N.Node _ (N.InCase _)))) -> O.AlternativeCond m (doExpression b) (doVariable c) (doInputMode md) (O.Skip m)
|
||||
|
||||
doAlt :: N.Node -> O.Structured
|
||||
doAlt n@(N.Node m nt) = case nt of
|
||||
N.Alt ns -> O.Several m $ map doAlt ns
|
||||
N.PriAlt ns -> O.Several m $ map doAlt ns
|
||||
N.AltRep r n -> O.Rep m (doReplicator r) (doAlt n)
|
||||
N.PriAltRep r n -> O.Rep m (doReplicator r) (doAlt n)
|
||||
N.Decl s n -> doSpecifications s O.Spec (doAlt n)
|
||||
otherwise -> O.OnlyA m $ doAlternative n
|
||||
|
||||
doValueProcess :: N.Node -> O.ValueProcess
|
||||
doValueProcess n@(N.Node m nt) = case nt of
|
||||
N.Decl s n -> doSpecifications s O.ValOfSpec (doValueProcess n)
|
||||
N.ValOf p el -> O.ValOf m (doProcess p) (doExpressionList el)
|
||||
|
||||
doPlacedPar :: N.Node -> O.Structured
|
||||
doPlacedPar n@(N.Node m nt) = case nt of
|
||||
N.PlacedPar ps -> O.Several m $ map doPlacedPar ps
|
||||
N.PlacedParRep r p -> O.Rep m (doReplicator r) (doPlacedPar p)
|
||||
N.Processor e p -> O.OnlyP m $ O.Processor m (doExpression e) (doProcess p)
|
||||
N.Decl s p -> doSpecifications s O.Spec (doPlacedPar p)
|
||||
|
||||
doProcess :: N.Node -> O.Process
|
||||
doProcess n@(N.Node m nt) = case nt of
|
||||
N.Decl s p -> doSpecifications s O.ProcSpec (doProcess p)
|
||||
N.Assign vs el -> O.Assign m (map doVariable vs) (doExpressionList el)
|
||||
N.In c md -> O.Input m (doVariable c) (doInputMode md)
|
||||
N.Out c os -> O.Output m (doVariable c) (map doOutputItem os)
|
||||
N.OutCase c t os -> O.OutputCase m (doVariable c) (doTag t) (map doOutputItem os)
|
||||
N.Skip -> O.Skip m
|
||||
N.Stop -> O.Stop m
|
||||
N.MainProcess -> O.Main m
|
||||
N.Seq ps -> O.Seq m (map doProcess ps)
|
||||
N.SeqRep r p -> O.SeqRep m (doReplicator r) (doProcess p)
|
||||
N.If _ -> O.If m $ doChoice n
|
||||
N.Case e os -> O.Case m (doExpression e) (O.Several m $ map doOption os)
|
||||
N.While e p -> O.While m (doExpression e) (doProcess p)
|
||||
N.Par ns -> O.Par m False (map doProcess ns)
|
||||
N.PriPar ns -> O.Par m True (map doProcess ns)
|
||||
N.ParRep r p -> O.ParRep m False (doReplicator r) (doProcess p)
|
||||
N.PriParRep r p -> O.ParRep m True (doReplicator r) (doProcess p)
|
||||
N.PlacedPar _ -> O.PlacedPar m $ doPlacedPar n
|
||||
N.PlacedParRep _ _ -> O.PlacedPar m $ doPlacedPar n
|
||||
N.Processor _ _ -> O.PlacedPar m $ doPlacedPar n
|
||||
N.Alt _ -> O.Alt m False $ doAlt n
|
||||
N.AltRep _ _ -> O.Alt m False $ doAlt n
|
||||
N.PriAlt _ -> O.Alt m True $ doAlt n
|
||||
N.PriAltRep _ _ -> O.Alt m True $ doAlt n
|
||||
N.ProcCall p es -> O.ProcCall m (doName p) (map doExpression es)
|
||||
|
||||
ptToAST :: N.Node -> O.Process
|
||||
ptToAST = doProcess
|
||||
|
||||
803
fco/Parse.hs
803
fco/Parse.hs
|
|
@ -1,803 +0,0 @@
|
|||
-- Parse occam code
|
||||
|
||||
module Parse (readSource, parseSource) where
|
||||
|
||||
import Data.List
|
||||
import Text.ParserCombinators.Parsec
|
||||
import qualified Text.ParserCombinators.Parsec.Token as P
|
||||
import Text.ParserCombinators.Parsec.Language (emptyDef)
|
||||
import qualified IO
|
||||
|
||||
import qualified PT as N
|
||||
import Metadata
|
||||
|
||||
-- -------------------------------------------------------------
|
||||
|
||||
md :: Parser Meta
|
||||
md = do
|
||||
pos <- getPosition
|
||||
return $ [SourcePos (sourceName pos) (sourceLine pos) (sourceColumn pos)]
|
||||
|
||||
nd :: Meta -> N.NodeType -> N.Node
|
||||
nd = N.Node
|
||||
|
||||
-- -------------------------------------------------------------
|
||||
|
||||
mainMarker = "##MAGIC-FCO-MAIN-PROCESS##"
|
||||
|
||||
occamStyle
|
||||
= emptyDef
|
||||
{ P.commentLine = "--"
|
||||
, P.nestedComments = False
|
||||
, P.identStart = letter
|
||||
, P.identLetter = alphaNum <|> char '.'
|
||||
, P.opStart = oneOf "+-*/\\>=<~"
|
||||
, P.opLetter = oneOf "/\\>=<"
|
||||
, P.reservedOpNames= [
|
||||
"+",
|
||||
"-",
|
||||
"*",
|
||||
"/",
|
||||
"\\",
|
||||
"/\\",
|
||||
"\\/",
|
||||
"><",
|
||||
"=",
|
||||
"<>",
|
||||
"<",
|
||||
">",
|
||||
">=",
|
||||
"<=",
|
||||
"-",
|
||||
"~"
|
||||
]
|
||||
, P.reservedNames = [
|
||||
"AFTER",
|
||||
"ALT",
|
||||
"AND",
|
||||
"ANY",
|
||||
"AT",
|
||||
"BITAND",
|
||||
"BITNOT",
|
||||
"BITOR",
|
||||
"BOOL",
|
||||
"BYTE",
|
||||
"BYTESIN",
|
||||
"CASE",
|
||||
"CHAN",
|
||||
"DATA",
|
||||
"ELSE",
|
||||
"FALSE",
|
||||
"FOR",
|
||||
"FROM",
|
||||
"FUNCTION",
|
||||
"IF",
|
||||
"INT",
|
||||
"INT16",
|
||||
"INT32",
|
||||
"INT64",
|
||||
"IS",
|
||||
"MINUS",
|
||||
"MOSTNEG",
|
||||
"MOSTPOS",
|
||||
"NOT",
|
||||
"OF",
|
||||
"OFFSETOF",
|
||||
"OR",
|
||||
"PACKED",
|
||||
"PAR",
|
||||
"PLACE",
|
||||
"PLACED",
|
||||
"PLUS",
|
||||
"PORT",
|
||||
"PRI",
|
||||
"PROC",
|
||||
"PROCESSOR",
|
||||
"PROTOCOL",
|
||||
"REAL32",
|
||||
"REAL64",
|
||||
"RECORD",
|
||||
"REM",
|
||||
"RESHAPES",
|
||||
"RESULT",
|
||||
"RETYPES",
|
||||
"ROUND",
|
||||
"SEQ",
|
||||
"SIZE",
|
||||
"SKIP",
|
||||
"STOP",
|
||||
"TIMER",
|
||||
"TIMES",
|
||||
"TRUE",
|
||||
"TRUNC",
|
||||
"TYPE",
|
||||
"VAL",
|
||||
"VALOF",
|
||||
"WHILE",
|
||||
mainMarker
|
||||
]
|
||||
, P.caseSensitive = True
|
||||
}
|
||||
|
||||
lexer :: P.TokenParser ()
|
||||
lexer = P.makeTokenParser occamStyle
|
||||
-- XXX replace whitespace with something that doesn't eat \ns
|
||||
|
||||
whiteSpace = P.whiteSpace lexer
|
||||
lexeme = P.lexeme lexer
|
||||
symbol = P.symbol lexer
|
||||
natural = P.natural lexer
|
||||
parens = P.parens lexer
|
||||
semi = P.semi lexer
|
||||
identifier= P.identifier lexer
|
||||
reserved = P.reserved lexer
|
||||
reservedOp= P.reservedOp lexer
|
||||
|
||||
sLeft = try $ symbol "["
|
||||
sRight = try $ symbol "]"
|
||||
sLeftR = try $ symbol "("
|
||||
sRightR = try $ symbol ")"
|
||||
sAssign = try $ symbol ":="
|
||||
sColon = try $ symbol ":"
|
||||
sColons = try $ symbol "::"
|
||||
sComma = try $ symbol ","
|
||||
sSemi = try $ symbol ";"
|
||||
sAmp = try $ symbol "&"
|
||||
sQuest = try $ symbol "?"
|
||||
sBang = try $ symbol "!"
|
||||
sEq = try $ symbol "="
|
||||
|
||||
sAFTER = reserved "AFTER"
|
||||
sALT = reserved "ALT"
|
||||
sAND = reserved "AND"
|
||||
sANY = reserved "ANY"
|
||||
sAT = reserved "AT"
|
||||
sBITAND = reserved "BITAND"
|
||||
sBITNOT = reserved "BITNOT"
|
||||
sBITOR = reserved "BITOR"
|
||||
sBOOL = reserved "BOOL"
|
||||
sBYTE = reserved "BYTE"
|
||||
sBYTESIN = reserved "BYTESIN"
|
||||
sCASE = reserved "CASE"
|
||||
sCHAN = reserved "CHAN"
|
||||
sDATA = reserved "DATA"
|
||||
sELSE = reserved "ELSE"
|
||||
sFALSE = reserved "FALSE"
|
||||
sFOR = reserved "FOR"
|
||||
sFROM = reserved "FROM"
|
||||
sFUNCTION = reserved "FUNCTION"
|
||||
sIF = reserved "IF"
|
||||
sINT = reserved "INT"
|
||||
sINT16 = reserved "INT16"
|
||||
sINT32 = reserved "INT32"
|
||||
sINT64 = reserved "INT64"
|
||||
sIS = reserved "IS"
|
||||
sMINUS = reserved "MINUS"
|
||||
sMOSTNEG = reserved "MOSTNEG"
|
||||
sMOSTPOS = reserved "MOSTPOS"
|
||||
sNOT = reserved "NOT"
|
||||
sOF = reserved "OF"
|
||||
sOFFSETOF = reserved "OFFSETOF"
|
||||
sOR = reserved "OR"
|
||||
sPACKED = reserved "PACKED"
|
||||
sPAR = reserved "PAR"
|
||||
sPLACE = reserved "PLACE"
|
||||
sPLACED = reserved "PLACED"
|
||||
sPLUS = reserved "PLUS"
|
||||
sPORT = reserved "PORT"
|
||||
sPRI = reserved "PRI"
|
||||
sPROC = reserved "PROC"
|
||||
sPROCESSOR = reserved "PROCESSOR"
|
||||
sPROTOCOL = reserved "PROTOCOL"
|
||||
sREAL32 = reserved "REAL32"
|
||||
sREAL64 = reserved "REAL64"
|
||||
sRECORD = reserved "RECORD"
|
||||
sREM = reserved "REM"
|
||||
sRESHAPES = reserved "RESHAPES"
|
||||
sRESULT = reserved "RESULT"
|
||||
sRETYPES = reserved "RETYPES"
|
||||
sROUND = reserved "ROUND"
|
||||
sSEQ = reserved "SEQ"
|
||||
sSIZE = reserved "SIZE"
|
||||
sSKIP = reserved "SKIP"
|
||||
sSTOP = reserved "STOP"
|
||||
sTIMER = reserved "TIMER"
|
||||
sTIMES = reserved "TIMES"
|
||||
sTRUE = reserved "TRUE"
|
||||
sTRUNC = reserved "TRUNC"
|
||||
sTYPE = reserved "TYPE"
|
||||
sVAL = reserved "VAL"
|
||||
sVALOF = reserved "VALOF"
|
||||
sWHILE = reserved "WHILE"
|
||||
sMainMarker = reserved mainMarker
|
||||
|
||||
-- XXX could handle VALOF by translating each step to one { and matching multiple ones?
|
||||
indent = symbol "{"
|
||||
outdent = symbol "}"
|
||||
eol = symbol "@"
|
||||
|
||||
-- -------------------------------------------------------------
|
||||
|
||||
-- These productions are based on the syntax in the occam2.1 manual.
|
||||
|
||||
-- The way productions should work is that each production should only consume input if it's sure that it's unambiguous.
|
||||
|
||||
abbreviation
|
||||
= try (do { m <- md ; n <- name ; sIS ; v <- variable ; sColon ; eol ; return $ nd m $ N.Is n v })
|
||||
<|> try (do { m <- md ; s <- specifier ; n <- name ; sIS ; v <- variable ; sColon ; eol ; return $ nd m $ N.IsType s n v })
|
||||
<|> do { m <- md ; sVAL ;
|
||||
try (do { n <- name ; sIS ; e <- expression ; sColon ; eol ; return $ nd m $ N.ValIs n e })
|
||||
<|> do { s <- specifier ; n <- name ; sIS ; e <- expression ; sColon ; eol ; return $ nd m $ N.ValIsType s n e } }
|
||||
<?> "abbreviation"
|
||||
|
||||
actual
|
||||
= expression
|
||||
<|> variable
|
||||
<|> channel
|
||||
<?> "actual"
|
||||
|
||||
allocation
|
||||
= do { m <- md ; sPLACE ; n <- name ; sAT ; e <- expression ; sColon ; eol ; return $ nd m $ N.Place n e }
|
||||
<?> "allocation"
|
||||
|
||||
alternation
|
||||
= do { m <- md ; sALT ;
|
||||
do { eol ; indent ; as <- many1 alternative ; outdent ; return $ nd m $ N.Alt as }
|
||||
<|> do { r <- replicator ; eol ; indent ; a <- alternative ; outdent ; return $ nd m $ N.AltRep r a } }
|
||||
<|> do { m <- md ; sPRI ; sALT ;
|
||||
do { eol ; indent ; as <- many1 alternative ; outdent ; return $ nd m $ N.PriAlt as }
|
||||
<|> do { r <- replicator ; eol ; indent ; a <- alternative ; outdent ; return $ nd m $ N.PriAltRep r a } }
|
||||
<?> "alternation"
|
||||
|
||||
-- The reason the CASE guards end up here is because they have to be handled
|
||||
-- specially: you can't tell until parsing the guts of the CASE what the processes
|
||||
-- are.
|
||||
alternative
|
||||
= guardedAlternative
|
||||
<|> alternation
|
||||
<|> try (do { m <- md ; b <- boolean ; sAmp ; c <- channel ; sQuest ; sCASE ; eol ; indent ; vs <- many1 variant ; outdent ; return $ nd m $ N.CondGuard b (nd m $ N.In c (nd m $ N.InCase vs)) })
|
||||
<|> try (do { m <- md ; c <- channel ; sQuest ; sCASE ; eol ; indent ; vs <- many1 variant ; outdent ; return $ nd m $ N.In c (nd m $ N.InCase vs) })
|
||||
<|> do { m <- md ; s <- specification ; a <- alternative ; return $ nd m $ N.Decl s a }
|
||||
<?> "alternative"
|
||||
|
||||
assignment
|
||||
= do { m <- md ; vs <- variableList ; sAssign ; es <- expressionList ; eol ; return $ nd m $ N.Assign vs es }
|
||||
<?> "assignment"
|
||||
|
||||
base
|
||||
= expression
|
||||
<?> "base"
|
||||
|
||||
boolean
|
||||
= expression
|
||||
<?> "boolean"
|
||||
|
||||
byte
|
||||
= lexeme (do { m <- md ; char '\'' ; s <- character ; char '\'' ; return $ nd m $ N.LitByte s })
|
||||
<?> "byte"
|
||||
|
||||
caseExpression
|
||||
= expression
|
||||
<?> "caseExpression"
|
||||
|
||||
caseInput
|
||||
= do { m <- md ; c <- channel ; sQuest ; sCASE ; eol ; indent ; vs <- many1 variant ; outdent ; return $ nd m $ N.In c (nd m $ N.InCase vs) }
|
||||
<?> "caseInput"
|
||||
|
||||
-- This is also used for timers and ports, since the syntax is identical (and
|
||||
-- the parser really can't tell at this stage which is which).
|
||||
channel
|
||||
= do { m <- md ; v <- channel' ; es <- many (do { sLeft ; e <- expression ; sRight ; return e }) ; return $ foldl (\e s -> nd m $ N.Sub (nd m $ N.SubPlain s) e) v es }
|
||||
<?> "channel"
|
||||
|
||||
channel'
|
||||
= try name
|
||||
<|> try (do { m <- md ; sLeft ; n <- channel ; sFROM ; e <- expression ; sFOR ; f <- expression ; sRight ; return $ nd m $ N.Sub (nd m $ N.SubFromFor e f) n })
|
||||
<|> try (do { m <- md ; sLeft ; n <- channel ; sFROM ; e <- expression ; sRight ; return $ nd m $ N.Sub (nd m $ N.SubFrom e) n })
|
||||
<|> do { m <- md ; sLeft ; n <- channel ; sFOR ; e <- expression ; sRight ; return $ nd m $ N.Sub (nd m $ N.SubFor e) n }
|
||||
<?> "channel'"
|
||||
|
||||
-- FIXME should probably make CHAN INT work, since that'd be trivial...
|
||||
channelType
|
||||
= do { m <- md ; sCHAN ; sOF ; p <- protocol ; return $ nd m $ N.ChanOf p }
|
||||
<|> try (do { m <- md ; sLeft ; s <- expression ; sRight ; t <- channelType ; return $ nd m $ N.Array s t })
|
||||
<?> "channelType"
|
||||
|
||||
-- FIXME this isn't at all the right way to return the character!
|
||||
character
|
||||
= try (do { char '*' ;
|
||||
do { char '#' ; a <- hexDigit ; b <- hexDigit ; return $ ['*', '#', a, b] }
|
||||
<|> do { c <- anyChar ; return $ ['*', c] } })
|
||||
<|> do { c <- anyChar ; return $ [c] }
|
||||
<?> "character"
|
||||
|
||||
occamChoice
|
||||
= guardedChoice
|
||||
<|> conditional
|
||||
<|> do { m <- md ; s <- try specification ; c <- occamChoice ; return $ nd m $ N.Decl s c }
|
||||
<?> "choice"
|
||||
|
||||
conditional
|
||||
= do { m <- md ; sIF ;
|
||||
do { eol ; indent ; cs <- many1 occamChoice ; outdent ; return $ nd m $ N.If cs }
|
||||
<|> do { r <- replicator ; eol ; indent ; c <- occamChoice ; outdent ; return $ nd m $ N.IfRep r c } }
|
||||
<?> "conditional"
|
||||
|
||||
-- This uses operandNotTable to resolve the "x[y]" ambiguity.
|
||||
conversion
|
||||
= try (do { m <- md ; t <- dataType; do { sROUND ; o <- operand ; return $ nd m $ N.Round t o } <|> do { sTRUNC ; o <- operand ; return $ nd m $ N.Trunc t o } <|> do { o <- operandNotTable ; return $ nd m $ N.Conv t o } })
|
||||
<?> "conversion"
|
||||
|
||||
occamCount
|
||||
= expression
|
||||
<?> "count"
|
||||
|
||||
dataType
|
||||
= do { m <- md ; sBOOL ; return $ nd m $ N.Bool }
|
||||
<|> do { m <- md ; sBYTE ; return $ nd m $ N.Byte }
|
||||
<|> do { m <- md ; sINT ; return $ nd m $ N.Int }
|
||||
<|> do { m <- md ; sINT16 ; return $ nd m $ N.Int16 }
|
||||
<|> do { m <- md ; sINT32 ; return $ nd m $ N.Int32 }
|
||||
<|> do { m <- md ; sINT64 ; return $ nd m $ N.Int64 }
|
||||
<|> do { m <- md ; sREAL32 ; return $ nd m $ N.Real32 }
|
||||
<|> do { m <- md ; sREAL64 ; return $ nd m $ N.Real64 }
|
||||
<|> try (do { m <- md ; sLeft ; s <- expression ; sRight ; t <- dataType ; return $ nd m $ N.Array s t })
|
||||
<|> name
|
||||
<?> "data type"
|
||||
|
||||
declType
|
||||
= dataType
|
||||
<|> channelType
|
||||
<|> timerType
|
||||
<|> portType
|
||||
|
||||
-- FIXME this originally had four lines like this, one for each of the above;
|
||||
-- it might be nicer to generate a different nd m $ N.Node for each type of declaration
|
||||
declaration
|
||||
= do { m <- md ; d <- declType ; ns <- sepBy1 name sComma ; sColon ; eol ; return $ nd m $ N.Vars d ns }
|
||||
<?> "declaration"
|
||||
|
||||
definition
|
||||
= do { m <- md ; sDATA ; sTYPE ; n <- name ;
|
||||
do {sIS ; t <- dataType ; sColon ; eol ; return $ nd m $ N.DataType n t }
|
||||
<|> do { eol ; indent ; t <- structuredType ; outdent ; sColon ; eol ; return $ nd m $ N.DataType n t } }
|
||||
<|> do { m <- md ; sPROTOCOL ; n <- name ;
|
||||
do { sIS ; p <- sequentialProtocol ; sColon ; eol ; return $ nd m $ N.Protocol n p }
|
||||
<|> do { eol ; indent ; sCASE ; eol ; indent ; ps <- many1 taggedProtocol ; outdent ; outdent ; sColon ; eol ; return $ nd m $ N.TaggedProtocol n ps } }
|
||||
<|> do { m <- md ; sPROC ; n <- name ; fs <- formalList ; eol ; indent ; p <- process ; outdent ; sColon ; eol ; return $ nd m $ N.Proc n fs p }
|
||||
<|> try (do { m <- md ; rs <- sepBy1 dataType sComma ; (n, fs) <- functionHeader ;
|
||||
do { sIS ; el <- expressionList ; sColon ; eol ; return $ nd m $ N.FuncIs n rs fs el }
|
||||
<|> do { eol ; indent ; vp <- valueProcess ; outdent ; sColon ; eol ; return $ nd m $ N.Func n rs fs vp } })
|
||||
<|> try (do { m <- md ; s <- specifier ; n <- name ;
|
||||
do { sRETYPES ; v <- variable ; sColon ; eol ; return $ nd m $ N.Retypes s n v }
|
||||
<|> do { try sRESHAPES ; v <- variable ; sColon ; eol ; return $ nd m $ N.Reshapes s n v } })
|
||||
<|> do { m <- md ; sVAL ; s <- specifier ; n <- name ;
|
||||
do { sRETYPES ; v <- variable ; sColon ; eol ; return $ nd m $ N.ValRetypes s n v }
|
||||
<|> do { sRESHAPES ; v <- variable ; sColon ; eol ; return $ nd m $ N.ValReshapes s n v } }
|
||||
<?> "definition"
|
||||
|
||||
digits
|
||||
= many1 digit
|
||||
<?> "digits"
|
||||
|
||||
dyadicOperator
|
||||
= do { m <- md ; reservedOp "+" ; return $ nd m $ N.Add }
|
||||
<|> do { m <- md ; reservedOp "-" ; return $ nd m $ N.Subtr }
|
||||
<|> do { m <- md ; reservedOp "*" ; return $ nd m $ N.Mul }
|
||||
<|> do { m <- md ; reservedOp "/" ; return $ nd m $ N.Div }
|
||||
<|> do { m <- md ; reservedOp "\\" ; return $ nd m $ N.Rem }
|
||||
<|> do { m <- md ; sREM ; return $ nd m $ N.Rem }
|
||||
<|> do { m <- md ; sPLUS ; return $ nd m $ N.Plus }
|
||||
<|> do { m <- md ; sMINUS ; return $ nd m $ N.Minus }
|
||||
<|> do { m <- md ; sTIMES ; return $ nd m $ N.Times }
|
||||
<|> do { m <- md ; reservedOp "/\\" ; return $ nd m $ N.BitAnd }
|
||||
<|> do { m <- md ; reservedOp "\\/" ; return $ nd m $ N.BitOr }
|
||||
<|> do { m <- md ; reservedOp "><" ; return $ nd m $ N.BitXor }
|
||||
<|> do { m <- md ; sBITAND ; return $ nd m $ N.BitAnd }
|
||||
<|> do { m <- md ; sBITOR ; return $ nd m $ N.BitOr }
|
||||
<|> do { m <- md ; sAND ; return $ nd m $ N.And }
|
||||
<|> do { m <- md ; sOR ; return $ nd m $ N.Or }
|
||||
<|> do { m <- md ; reservedOp "=" ; return $ nd m $ N.Eq }
|
||||
<|> do { m <- md ; reservedOp "<>" ; return $ nd m $ N.NEq }
|
||||
<|> do { m <- md ; reservedOp "<" ; return $ nd m $ N.Less }
|
||||
<|> do { m <- md ; reservedOp ">" ; return $ nd m $ N.More }
|
||||
<|> do { m <- md ; reservedOp "<=" ; return $ nd m $ N.LessEq }
|
||||
<|> do { m <- md ; reservedOp ">=" ; return $ nd m $ N.MoreEq }
|
||||
<|> do { m <- md ; sAFTER ; return $ nd m $ N.After }
|
||||
<?> "dyadicOperator"
|
||||
|
||||
occamExponent
|
||||
= try (do { c <- oneOf "+-" ; d <- digits ; return $ c : d })
|
||||
<?> "exponent"
|
||||
|
||||
expression
|
||||
= try (do { m <- md ; o <- monadicOperator ; v <- operand ; return $ nd m $ N.MonadicOp o v })
|
||||
<|> do { m <- md ; a <- sMOSTPOS ; t <- dataType ; return $ nd m $ N.MostPos t }
|
||||
<|> do { m <- md ; a <- sMOSTNEG ; t <- dataType ; return $ nd m $ N.MostNeg t }
|
||||
<|> do { m <- md ; a <- sSIZE ; t <- dataType ; return $ nd m $ N.Size t }
|
||||
<|> try (do { m <- md ; a <- operand ; o <- dyadicOperator ; b <- operand ; return $ nd m $ N.DyadicOp o a b })
|
||||
<|> try conversion
|
||||
<|> operand
|
||||
<?> "expression"
|
||||
|
||||
expressionList
|
||||
= try (do { m <- md ; n <- name ; sLeftR ; as <- sepBy expression sComma ; sRightR ; return $ nd m $ N.Call n as })
|
||||
<|> do { m <- md ; es <- sepBy1 expression sComma ; return $ nd m $ N.ExpList es }
|
||||
-- XXX value process
|
||||
<?> "expressionList"
|
||||
|
||||
fieldName
|
||||
= name
|
||||
<?> "fieldName"
|
||||
|
||||
-- This is rather different from the grammar, since I had some difficulty
|
||||
-- getting Parsec to parse it as a list of lists of arguments.
|
||||
formalList
|
||||
= do { m <- md ; sLeftR ; fs <- sepBy formalArg sComma ; sRightR ; return $ markTypes m fs }
|
||||
<?> "formalList"
|
||||
where
|
||||
formalArg :: Parser (Maybe N.Node, N.Node)
|
||||
formalArg = try (do { m <- md ; sVAL ; s <- specifier ; n <- name ; return $ (Just (nd m $ N.Val s), n) })
|
||||
<|> try (do { s <- specifier ; n <- name ; return $ (Just s, n) })
|
||||
<|> try (do { n <- name ; return $ (Nothing, n) })
|
||||
|
||||
markTypes :: Meta -> [(Maybe N.Node, N.Node)] -> [N.Node]
|
||||
markTypes _ [] = []
|
||||
markTypes _ ((Nothing, _):_) = error "Formal list must start with a type"
|
||||
markTypes m ((Just ft, fn):is) = markRest m ft [fn] is
|
||||
|
||||
markRest :: Meta -> N.Node -> [N.Node] -> [(Maybe N.Node, N.Node)] -> [N.Node]
|
||||
markRest m lt ns [] = [nd m $ N.Formals lt ns]
|
||||
markRest m lt ns ((Nothing, n):is) = markRest m lt (ns ++ [n]) is
|
||||
markRest m lt ns ((Just t, n):is) = (markRest m lt ns []) ++ (markRest m t [n] is)
|
||||
|
||||
functionHeader
|
||||
= do { sFUNCTION ; n <- name ; fs <- formalList ; return $ (n, fs) }
|
||||
<?> "functionHeader"
|
||||
|
||||
guard
|
||||
= try input
|
||||
<|> try (do { m <- md ; b <- boolean ; sAmp ; i <- input ; return $ nd m $ N.CondGuard b i })
|
||||
<|> try (do { m <- md ; b <- boolean ; sAmp ; sSKIP ; eol ; return $ nd m $ N.CondGuard b (nd m $ N.Skip) })
|
||||
<?> "guard"
|
||||
|
||||
guardedAlternative
|
||||
= do { m <- md ; g <- guard ; indent ; p <- process ; outdent ; return $ nd m $ N.Guard g p }
|
||||
<?> "guardedAlternative"
|
||||
|
||||
guardedChoice
|
||||
= do { m <- md ; b <- boolean ; eol ; indent ; p <- process ; outdent ; return $ nd m $ N.Choice b p }
|
||||
<?> "guardedChoice"
|
||||
|
||||
hexDigits
|
||||
= do { m <- md ; d <- many1 hexDigit ; return $ nd m $ N.LitHex d }
|
||||
<?> "hexDigits"
|
||||
|
||||
input
|
||||
= do m <- md
|
||||
c <- channel
|
||||
sQuest
|
||||
(do { sCASE ; tl <- taggedList ; eol ; return $ nd m $ N.In c (nd m $ N.InTag tl) }
|
||||
<|> do { sAFTER ; e <- expression ; eol ; return $ nd m $ N.In c (nd m $ N.InAfter e) }
|
||||
<|> do { is <- sepBy1 inputItem sSemi ; eol ; return $ nd m $ N.In c (nd m $ N.InSimple is) })
|
||||
<?> "input"
|
||||
|
||||
inputItem
|
||||
= try (do { m <- md ; v <- variable ; sColons ; w <- variable ; return $ nd m $ N.Counted v w })
|
||||
<|> variable
|
||||
<?> "inputItem"
|
||||
|
||||
integer
|
||||
= try (do { m <- md ; d <- lexeme digits ; return $ nd m $ N.LitInt d })
|
||||
<|> do { char '#' ; d <- lexeme hexDigits ; return $ d }
|
||||
<?> "integer"
|
||||
|
||||
literal
|
||||
= try real
|
||||
<|> try integer
|
||||
<|> try byte
|
||||
<|> try (do { m <- md ; v <- real ; sLeftR ; t <- dataType ; sRightR ; return $ nd m $ N.TypedLit t v })
|
||||
<|> try (do { m <- md ; v <- integer ; sLeftR ; t <- dataType ; sRightR ; return $ nd m $ N.TypedLit t v })
|
||||
<|> try (do { m <- md ; v <- byte ; sLeftR ; t <- dataType ; sRightR ; return $ nd m $ N.TypedLit t v })
|
||||
<|> try (do { m <- md ; sTRUE ; return $ nd m $ N.True })
|
||||
<|> do { m <- md ; sFALSE ; return $ nd m $ N.False }
|
||||
<?> "literal"
|
||||
|
||||
loop
|
||||
= do { m <- md ; sWHILE ; b <- boolean ; eol ; indent ; p <- process ; outdent ; return $ nd m $ N.While b p }
|
||||
|
||||
monadicOperator
|
||||
= do { m <- md ; reservedOp "-" ; return $ nd m $ N.MonSub }
|
||||
<|> do { m <- md ; sMINUS ; return $ nd m $ N.MonSub }
|
||||
<|> do { m <- md ; reservedOp "~" ; return $ nd m $ N.MonBitNot }
|
||||
<|> do { m <- md ; sBITNOT ; return $ nd m $ N.MonBitNot }
|
||||
<|> do { m <- md ; sNOT ; return $ nd m $ N.MonNot }
|
||||
<|> do { m <- md ; sSIZE ; return $ nd m $ N.MonSize }
|
||||
<?> "monadicOperator"
|
||||
|
||||
name
|
||||
= do { m <- md ; s <- identifier ; return $ nd m $ N.Name s }
|
||||
<?> "name"
|
||||
|
||||
occamString
|
||||
= lexeme (do { m <- md ; char '"' ; s <- many (noneOf "\"") ; char '"' ; return $ nd m $ N.LitString s })
|
||||
<?> "string"
|
||||
|
||||
operandNotTable
|
||||
= do { m <- md ; v <- operandNotTable' ; es <- many (do { sLeft ; e <- expression ; sRight ; return e }) ; return $ foldl (\e s -> nd m $ N.Sub (nd m $ N.SubPlain s) e) v es }
|
||||
<?> "operandNotTable"
|
||||
|
||||
operandNotTable'
|
||||
= try variable
|
||||
<|> try literal
|
||||
<|> try (do { sLeftR ; e <- expression ; sRightR ; return e })
|
||||
-- XXX value process
|
||||
<|> try (do { m <- md ; n <- name ; sLeftR ; as <- sepBy expression sComma ; sRightR ; return $ nd m $ N.Call n as })
|
||||
<|> try (do { m <- md ; sBYTESIN ; sLeftR ; o <- operand ; sRightR ; return $ nd m $ N.BytesIn o })
|
||||
<|> try (do { m <- md ; sBYTESIN ; sLeftR ; o <- dataType ; sRightR ; return $ nd m $ N.BytesIn o })
|
||||
<|> try (do { m <- md ; sOFFSETOF ; sLeftR ; n <- name ; sComma ; f <- fieldName ; sRightR ; return $ nd m $ N.OffsetOf n f })
|
||||
<?> "operandNotTable'"
|
||||
|
||||
operand
|
||||
= do { m <- md ; v <- operand' ; es <- many (do { sLeft ; e <- expression ; sRight ; return e }) ; return $ foldl (\e s -> nd m $ N.Sub (nd m $ N.SubPlain s) e) v es }
|
||||
<?> "operand"
|
||||
|
||||
operand'
|
||||
= try table
|
||||
<|> operandNotTable'
|
||||
<?> "operand'"
|
||||
|
||||
occamOption
|
||||
= try (do { m <- md ; ces <- sepBy caseExpression sComma ; eol ; indent ; p <- process ; outdent ; return $ nd m $ N.CaseExps ces p })
|
||||
<|> try (do { m <- md ; sELSE ; eol ; indent ; p <- process ; outdent ; return $ nd m $ N.Else p })
|
||||
<|> do { m <- md ; s <- specification ; o <- occamOption ; return $ nd m $ N.Decl s o }
|
||||
<?> "option"
|
||||
|
||||
-- XXX This can't tell at parse time in "c ! x; y" whether x is a variable or a tag...
|
||||
-- ... so this now wants "c ! CASE x" if it's a tag, to match input.
|
||||
-- We can fix this with a pass later...
|
||||
output
|
||||
= do m <- md
|
||||
c <- channel
|
||||
sBang
|
||||
(do { sCASE ; t <- tag ; sSemi ; os <- sepBy1 outputItem sSemi ; eol ; return $ nd m $ N.OutCase c t os }
|
||||
<|> do { sCASE ; t <- tag ; eol ; return $ nd m $ N.OutCase c t [] }
|
||||
<|> do { os <- sepBy1 outputItem sSemi ; eol ; return $ nd m $ N.Out c os })
|
||||
<?> "output"
|
||||
|
||||
outputItem
|
||||
= try (do { m <- md ; a <- expression ; sColons ; b <- expression ; return $ nd m $ N.Counted a b })
|
||||
<|> expression
|
||||
<?> "outputItem"
|
||||
|
||||
parallel
|
||||
= do { m <- md ; sPAR ; do { eol ; indent ; ps <- many1 process ; outdent ; return $ nd m $ N.Par ps } <|> do { r <- replicator ; eol ; indent ; p <- process ; outdent ; return $ nd m $ N.ParRep r p } }
|
||||
<|> do { m <- md ; sPRI ; sPAR ; do { eol ; indent ; ps <- many1 process ; outdent ; return $ nd m $ N.PriPar ps } <|> do { r <- replicator ; eol ; indent ; p <- process ; outdent ; return $ nd m $ N.PriParRep r p } }
|
||||
<|> placedpar
|
||||
<?> "parallel"
|
||||
|
||||
-- XXX PROCESSOR as a process isn't really legal, surely?
|
||||
placedpar
|
||||
= do { m <- md ; sPLACED ; sPAR ; do { eol ; indent ; ps <- many1 placedpar ; outdent ; return $ nd m $ N.PlacedPar ps } <|> do { r <- replicator ; eol ; indent ; p <- placedpar ; outdent ; return $ nd m $ N.PlacedParRep r p } }
|
||||
<|> do { m <- md ; sPROCESSOR ; e <- expression ; eol ; indent ; p <- process ; outdent ; return $ nd m $ N.Processor e p }
|
||||
<?> "placedpar"
|
||||
|
||||
portType
|
||||
= do { m <- md ; sPORT ; sOF ; p <- protocol ; return $ nd m $ N.PortOf p }
|
||||
<|> do { m <- md ; try sLeft ; s <- try expression ; try sRight ; t <- portType ; return $ nd m $ N.Array s t }
|
||||
<?> "portType"
|
||||
|
||||
procInstance
|
||||
= do { m <- md ; n <- name ; sLeftR ; as <- sepBy actual sComma ; sRightR ; eol ; return $ nd m $ N.ProcCall n as }
|
||||
<?> "procInstance"
|
||||
|
||||
process
|
||||
= try assignment
|
||||
<|> try input
|
||||
<|> try output
|
||||
<|> do { m <- md ; sSKIP ; eol ; return $ nd m $ N.Skip }
|
||||
<|> do { m <- md ; sSTOP ; eol ; return $ nd m $ N.Stop }
|
||||
<|> occamSequence
|
||||
<|> conditional
|
||||
<|> selection
|
||||
<|> loop
|
||||
<|> try parallel
|
||||
<|> alternation
|
||||
<|> try caseInput
|
||||
<|> try procInstance
|
||||
<|> do { m <- md ; sMainMarker ; eol ; return $ nd m $ N.MainProcess }
|
||||
<|> do { m <- md ; a <- allocation ; p <- process ; return $ nd m $ N.Decl a p }
|
||||
<|> do { m <- md ; s <- specification ; p <- process ; return $ nd m $ N.Decl s p }
|
||||
<?> "process"
|
||||
|
||||
protocol
|
||||
= try name
|
||||
<|> simpleProtocol
|
||||
<?> "protocol"
|
||||
|
||||
real
|
||||
= try (do { m <- md ; l <- digits ; char '.' ; r <- digits ; char 'e' ; e <- lexeme occamExponent ; return $ nd m $ N.LitReal (l ++ "." ++ r ++ "e" ++ e) })
|
||||
<|> do { m <- md ; l <- digits ; char '.' ; r <- lexeme digits ; return $ nd m $ N.LitReal (l ++ "." ++ r) }
|
||||
<?> "real"
|
||||
|
||||
replicator
|
||||
= do { m <- md ; n <- name ; sEq ; b <- base ; sFOR ; c <- occamCount ; return $ nd m $ N.For n b c }
|
||||
<?> "replicator"
|
||||
|
||||
selection
|
||||
= do { m <- md ; sCASE ; s <- selector ; eol ; indent ; os <- many1 occamOption ; outdent ; return $ nd m $ N.Case s os }
|
||||
<?> "selection"
|
||||
|
||||
selector
|
||||
= expression
|
||||
<?> "selector"
|
||||
|
||||
occamSequence
|
||||
= do m <- md
|
||||
sSEQ
|
||||
(do { eol ; indent ; ps <- many1 process ; outdent ; return $ nd m $ N.Seq ps }
|
||||
<|> do { r <- replicator ; eol ; indent ; p <- process ; outdent ; return $ nd m $ N.SeqRep r p })
|
||||
<?> "sequence"
|
||||
|
||||
sequentialProtocol
|
||||
= do { l <- try $ sepBy1 simpleProtocol sSemi ; return $ l }
|
||||
<?> "sequentialProtocol"
|
||||
|
||||
simpleProtocol
|
||||
= try (do { m <- md ; l <- dataType ; sColons ; sLeft ; sRight ; r <- dataType ; return $ nd m $ N.Counted l r })
|
||||
<|> dataType
|
||||
<|> do { m <- md ; sANY ; return $ nd m $ N.Any }
|
||||
<?> "simpleProtocol"
|
||||
|
||||
specification
|
||||
= try declaration
|
||||
<|> try abbreviation
|
||||
<|> definition
|
||||
<?> "specification"
|
||||
|
||||
specifier
|
||||
= try dataType
|
||||
<|> try channelType
|
||||
<|> try timerType
|
||||
<|> try portType
|
||||
<|> try (do { m <- md ; sLeft ; sRight ; s <- specifier ; return $ nd m $ N.ArrayUnsized s })
|
||||
<|> do { m <- md ; sLeft ; e <- expression ; sRight ; s <- specifier ; return $ nd m $ N.Array e s }
|
||||
<?> "specifier"
|
||||
|
||||
structuredType
|
||||
= try (do { m <- md ; sRECORD ; eol ; indent ; fs <- many1 structuredTypeField ; outdent ; return $ nd m $ N.Record fs })
|
||||
<|> do { m <- md ; sPACKED ; sRECORD ; eol ; indent ; fs <- many1 structuredTypeField ; outdent ; return $ nd m $ N.PackedRecord fs }
|
||||
<?> "structuredType"
|
||||
|
||||
-- FIXME this should use the same type-folding code as proc/func definitions
|
||||
structuredTypeField
|
||||
= do { m <- md ; t <- dataType ; fs <- many1 fieldName ; sColon ; eol ; return $ nd m $ N.Fields t fs }
|
||||
<?> "structuredTypeField"
|
||||
|
||||
-- i.e. array literal
|
||||
table
|
||||
= do { m <- md ; v <- table' ; es <- many (do { sLeft ; e <- expression ; sRight ; return e }) ; return $ foldl (\e s -> nd m $ N.Sub (nd m $ N.SubPlain s) e) v es }
|
||||
<?> "table"
|
||||
|
||||
table'
|
||||
= try occamString
|
||||
<|> try (do { m <- md ; s <- occamString ; sLeftR ; n <- name ; sRightR ; return $ nd m $ N.TypedLit n s })
|
||||
<|> do { sLeft ;
|
||||
try (do { m <- md ; es <- sepBy1 expression sComma ; sRight ; return $ nd m $ N.LitArray es })
|
||||
<|> try (do { m <- md ; n <- table ; sFROM ; e <- expression ; sFOR ; f <- expression ; sRight ; return $ nd m $ N.Sub (nd m $ N.SubFromFor e f) n })
|
||||
<|> try (do { m <- md ; n <- table ; sFROM ; e <- expression ; sRight ; return $ nd m $ N.Sub (nd m $ N.SubFrom e) n })
|
||||
<|> do { m <- md ; n <- table ; sFOR ; e <- expression ; sRight ; return $ nd m $ N.Sub (nd m $ N.SubFor e) n } }
|
||||
<?> "table'"
|
||||
|
||||
tag
|
||||
= name
|
||||
<?> "tag"
|
||||
|
||||
taggedList
|
||||
= try (do { m <- md ; t <- tag ; sSemi ; is <- sepBy1 inputItem sSemi ; return $ nd m $ N.Tag t is })
|
||||
<|> do { m <- md ; t <- tag ; return $ nd m $ N.Tag t [] }
|
||||
<?> "taggedList"
|
||||
|
||||
taggedProtocol
|
||||
= try (do { m <- md ; t <- tag ; eol ; return $ nd m $ N.Tag t [] })
|
||||
<|> try (do { m <- md ; t <- tag ; sSemi ; sp <- sequentialProtocol ; eol ; return $ nd m $ N.Tag t sp })
|
||||
|
||||
timerType
|
||||
= do { m <- md ; sTIMER ; return $ nd m $ N.Timer }
|
||||
<|> do { m <- md ; try sLeft ; s <- try expression ; try sRight ; t <- timerType ; return $ nd m $ N.Array s t }
|
||||
<?> "timerType"
|
||||
|
||||
valueProcess
|
||||
= try (do { m <- md ; sVALOF ; eol ; indent ; p <- process ; sRESULT ; el <- expressionList ; eol ; outdent ; return $ nd m $ N.ValOf p el })
|
||||
<|> do { m <- md ; s <- specification ; v <- valueProcess ; return $ nd m $ N.Decl s v }
|
||||
|
||||
variable
|
||||
= do { m <- md ; v <- variable' ; es <- many (do { sLeft ; e <- expression ; sRight ; return e }) ; return $ foldl (\e s -> nd m $ N.Sub (nd m $ N.SubPlain s) e) v es }
|
||||
<?> "variable"
|
||||
|
||||
variable'
|
||||
= try name
|
||||
<|> try (do { m <- md ; sLeft ; n <- variable ; sFROM ; e <- expression ; sFOR ; f <- expression ; sRight ; return $ nd m $ N.Sub (nd m $ N.SubFromFor e f) n })
|
||||
<|> try (do { m <- md ; sLeft ; n <- variable ; sFROM ; e <- expression ; sRight ; return $ nd m $ N.Sub (nd m $ N.SubFrom e) n })
|
||||
<|> do { m <- md ; sLeft ; n <- variable ; sFOR ; e <- expression ; sRight ; return $ nd m $ N.Sub (nd m $ N.SubFor e) n }
|
||||
<?> "variable'"
|
||||
|
||||
variableList
|
||||
= do { vs <- sepBy1 variable sComma ; return $ vs }
|
||||
<?> "variableList"
|
||||
|
||||
variant
|
||||
= try (do { m <- md ; t <- taggedList ; eol ; indent ; p <- process ; outdent ; return $ nd m $ N.Variant t p })
|
||||
<|> do { m <- md ; s <- specification ; v <- variant ; return $ nd m $ N.Decl s v }
|
||||
<?> "variant"
|
||||
|
||||
-- -------------------------------------------------------------
|
||||
|
||||
-- This is only really true once we've tacked a process onto the bottom; a
|
||||
-- source file is really a series of specifications, but the later ones need to
|
||||
-- have the earlier ones in scope, so we can't parse them separately.
|
||||
|
||||
sourceFile = do { whiteSpace ; process }
|
||||
|
||||
-- -------------------------------------------------------------
|
||||
|
||||
-- XXX this doesn't handle multi-line strings
|
||||
-- XXX or VALOF processes
|
||||
|
||||
countIndent :: String -> Int
|
||||
countIndent (' ':' ':cs) = 1 + (countIndent cs)
|
||||
countIndent (' ':cs) = error "Bad indentation"
|
||||
countIndent _ = 0
|
||||
|
||||
stripIndent :: String -> String
|
||||
stripIndent (' ':cs) = stripIndent cs
|
||||
stripIndent cs = cs
|
||||
|
||||
stripComment :: String -> String
|
||||
stripComment [] = []
|
||||
stripComment ('-':'-':s) = []
|
||||
stripComment ('"':s) = '"' : stripCommentInString s
|
||||
stripComment (c:s) = c : stripComment s
|
||||
|
||||
stripCommentInString :: String -> String
|
||||
stripCommentInString [] = error "In string at end of line"
|
||||
stripCommentInString ('"':s) = '"' : stripComment s
|
||||
stripCommentInString (c:s) = c : stripCommentInString s
|
||||
|
||||
flatten :: [String] -> String
|
||||
flatten ls = concat $ intersperse "\n" $ flatten' ls 0
|
||||
where
|
||||
rep n i = take n (repeat i)
|
||||
flatten' [] level = [rep level '}']
|
||||
flatten' (s:ss) level
|
||||
| stripped == "" = "" : flatten' ss level
|
||||
| newLevel > level = (rep (newLevel - level) '{' ++ stripped) : rest
|
||||
| newLevel < level = (rep (level - newLevel) '}' ++ stripped) : rest
|
||||
| otherwise = stripped : rest
|
||||
where newLevel = countIndent s
|
||||
stripped' = stripComment s
|
||||
stripped = if stripIndent stripped' == "" then "" else (stripped' ++ "@")
|
||||
rest = flatten' ss newLevel
|
||||
|
||||
-- -------------------------------------------------------------
|
||||
|
||||
-- XXX Doesn't handle preprocessor instructions.
|
||||
|
||||
preprocess :: String -> String
|
||||
preprocess d = flatten $ lines (d ++ "\n" ++ mainMarker)
|
||||
|
||||
readSource :: String -> IO String
|
||||
readSource fn = do
|
||||
f <- IO.openFile fn IO.ReadMode
|
||||
d <- IO.hGetContents f
|
||||
let prep = preprocess d
|
||||
return prep
|
||||
|
||||
-- -------------------------------------------------------------
|
||||
|
||||
parseSource :: String -> String -> N.Node
|
||||
parseSource prep sourceFileName
|
||||
= case (parse sourceFile sourceFileName prep) of
|
||||
Left err -> error ("Parsing error: " ++ (show err))
|
||||
Right defs -> defs
|
||||
|
||||
23
fco/Pass.hs
23
fco/Pass.hs
|
|
@ -1,23 +0,0 @@
|
|||
-- Defining and running passes across some type of tree
|
||||
|
||||
module Pass where
|
||||
|
||||
import Control.Monad.State
|
||||
import Data.Generics
|
||||
import PrettyShow
|
||||
|
||||
type Progress = (String -> IO ())
|
||||
|
||||
type Pass t = t -> t
|
||||
|
||||
type PassList t = [(String, Pass t)]
|
||||
|
||||
runPasses :: Data t => PassList t -> Progress -> t -> IO t
|
||||
runPasses [] _ d = return d
|
||||
runPasses ((name, pass):ps) progress d = do
|
||||
progress $ "{{{ Pass: " ++ name
|
||||
let d' = pass d
|
||||
progress $ pshow d'
|
||||
progress $ "}}}"
|
||||
runPasses ps progress d'
|
||||
|
||||
|
|
@ -1,49 +0,0 @@
|
|||
-- A generic show implementation that pretty-prints expressions
|
||||
-- This ought to use a class (like show does), so that it can be extended
|
||||
-- properly without me needing to have FCO-specific cases in here -- see the
|
||||
-- appropriate SYB paper.
|
||||
|
||||
module PrettyShow (pshow) where
|
||||
|
||||
import Data.Generics
|
||||
import Text.PrettyPrint.HughesPJ
|
||||
import Metadata
|
||||
|
||||
-- This is ugly -- but it looks like you can't easily define a generic function
|
||||
-- even for a single tuple type, since it has to parameterise over multiple Data
|
||||
-- types...
|
||||
isTupleCtr :: String -> Bool
|
||||
isTupleCtr ('(':cs) = checkRest cs
|
||||
where
|
||||
checkRest ",)" = True
|
||||
checkRest (',':cs) = checkRest cs
|
||||
checkRest _ = False
|
||||
isTupleCtr _ = False
|
||||
|
||||
doGeneral :: Data a => a -> Doc
|
||||
doGeneral t =
|
||||
if isTupleCtr cn then
|
||||
parens $ sep $ punctuate (text ",") l
|
||||
else case l of
|
||||
[] -> con
|
||||
otherwise -> parens $ sep (con : l)
|
||||
where
|
||||
cn = showConstr (toConstr t)
|
||||
con = text $ cn
|
||||
l = gmapQ doAny t
|
||||
|
||||
doList :: Data a => [a] -> Doc
|
||||
doList t = brackets $ sep $ punctuate (text ",") (map doAny t)
|
||||
|
||||
doString :: String -> Doc
|
||||
doString s = text $ show s
|
||||
|
||||
doMeta :: Meta -> Doc
|
||||
doMeta m = text $ formatSourcePos m
|
||||
|
||||
doAny :: Data a => a -> Doc
|
||||
doAny = doGeneral `ext1Q` doList `extQ` doString `extQ` doMeta
|
||||
|
||||
pshow :: Data a => a -> String
|
||||
pshow x = render $ doAny x
|
||||
|
||||
|
|
@ -1,274 +0,0 @@
|
|||
-- Lisp-style s-expression support
|
||||
|
||||
module SExpression where
|
||||
|
||||
import List
|
||||
import qualified PT as N
|
||||
import Text.PrettyPrint.HughesPJ
|
||||
|
||||
data SExp = Item String | List [SExp]
|
||||
|
||||
sexpToDoc :: SExp -> Doc
|
||||
sexpToDoc (Item s) = text s
|
||||
sexpToDoc (List is) = parens $ sep (map sexpToDoc is)
|
||||
|
||||
instance Show SExp where
|
||||
show s = render $ sexpToDoc s
|
||||
|
||||
dyadicName :: N.Node -> String
|
||||
dyadicName (N.Node meta node) = case node of
|
||||
N.Add -> "+"
|
||||
N.Subtr -> "-"
|
||||
N.Mul -> "*"
|
||||
N.Div -> "/"
|
||||
N.Rem -> "mod"
|
||||
N.Plus -> "plus"
|
||||
N.Minus -> "minus"
|
||||
N.Times -> "times"
|
||||
N.BitAnd -> "bitand"
|
||||
N.BitOr -> "bitor"
|
||||
N.BitXor -> "bitxor"
|
||||
N.And -> "and"
|
||||
N.Or -> "or"
|
||||
N.Eq -> "="
|
||||
N.NEq -> "<>"
|
||||
N.Less -> "<"
|
||||
N.More -> ">"
|
||||
N.LessEq -> "<="
|
||||
N.MoreEq -> ">="
|
||||
N.After -> "after"
|
||||
|
||||
monadicName :: N.Node -> String
|
||||
monadicName (N.Node meta node) = case node of
|
||||
N.MonSub -> "-"
|
||||
N.MonBitNot -> "bitnot"
|
||||
N.MonNot -> "not"
|
||||
N.MonSize -> "size"
|
||||
|
||||
nodeToSExp :: N.Node -> SExp
|
||||
nodeToSExp (N.Node meta node)
|
||||
= case node of
|
||||
N.Decl a b -> wrap2 ":" (top a) (top b)
|
||||
N.Alt a -> wrapl "alt" (map top a)
|
||||
N.AltRep a b -> wrap2 "alt-rep" (top a) (top b)
|
||||
N.PriAlt a -> wrapl "pri-alt" (map top a)
|
||||
N.PriAltRep a b -> wrap2 "pri-alt-rep" (top a) (top b)
|
||||
N.In a (N.Node _ (N.InSimple b)) -> wrapl1 "?" (top a) (map top b)
|
||||
N.Variant a b -> wrap2 "variant" (top a) (top b)
|
||||
N.In a (N.Node _ (N.InCase b)) -> wrapl1 "?case" (top a) (map top b)
|
||||
N.In a (N.Node _ (N.InTag b)) -> wrap2 "?case-tag" (top a) (top b)
|
||||
N.In a (N.Node _ (N.InAfter b)) -> wrap2 "?after" (top a) (top b)
|
||||
N.Out a b -> wrapl1 "!" (top a) (map top b)
|
||||
N.OutCase a b c -> wrapl2 "!case" (top a) (top b) (map top c)
|
||||
N.ExpList a -> wrapl "exp-list" (map top a)
|
||||
N.Assign a b -> wrap2 ":=" (List $ map top a) (top b)
|
||||
N.If a -> wrapl "if" (map top a)
|
||||
N.IfRep a b -> wrap2 "if-rep" (top a) (top b)
|
||||
N.While a b -> wrap2 "while" (top a) (top b)
|
||||
N.Par a -> wrapl "par" (map top a)
|
||||
N.ParRep a b -> wrap2 "par-rep" (top a) (top b)
|
||||
N.PriPar a -> wrapl "pri-par" (map top a)
|
||||
N.PriParRep a b -> wrap2 "pri-par-rep" (top a) (top b)
|
||||
N.PlacedPar a -> wrapl "placed-par" (map top a)
|
||||
N.PlacedParRep a b -> wrap2 "placed-par-rep" (top a) (top b)
|
||||
N.Processor a b -> wrap2 "processor" (top a) (top b)
|
||||
N.Skip -> Item "skip"
|
||||
N.Stop -> Item "stop"
|
||||
N.Case a b -> wrapl1 "case" (top a) (map top b)
|
||||
N.Seq a -> wrapl "seq" (map top a)
|
||||
N.SeqRep a b -> wrap2 "seq-rep" (top a) (top b)
|
||||
N.ProcCall a b -> wrapl1 "proc-call" (top a) (map top b)
|
||||
N.MainProcess -> Item "main"
|
||||
N.Vars a b -> wrapl1 "vars" (top a) (map top b)
|
||||
N.Is a b -> wrap2 "is" (top a) (top b)
|
||||
N.IsType a b c -> wrap3 "is-type" (top a) (top b) (top c)
|
||||
N.ValIs a b -> wrap2 "val-is" (top a) (top b)
|
||||
N.ValIsType a b c -> wrap3 "val-is-type" (top a) (top b) (top c)
|
||||
N.Place a b -> wrap2 "place-at" (top a) (top b)
|
||||
N.DataType a b -> wrap2 "data-type" (top a) (top b)
|
||||
N.Record a -> wrapl "record" (map top a)
|
||||
N.PackedRecord a -> wrapl "packed-record" (map top a)
|
||||
N.Fields a b -> wrapl1 "fields" (top a) (map top b)
|
||||
N.Protocol a b -> wrapl1 "protocol" (top a) (map top b)
|
||||
N.TaggedProtocol a b -> wrapl1 "protocol-tagged" (top a) (map top b)
|
||||
N.Tag a b -> wrapl1 "tag" (top a) (map top b)
|
||||
N.Formals a b -> wrapl1 "formal" (top a) (map top b)
|
||||
N.Proc a b c -> wrap3 "proc" (top a) (List $ map top b) (top c)
|
||||
N.Func a b c d -> wrap4 "function" (top a) (List $ map top b) (List $ map top c) (top d)
|
||||
N.FuncIs a b c d -> wrap4 "function-is" (top a) (List $ map top b) (List $ map top c) (top d)
|
||||
N.Retypes a b c -> wrap3 "retypes" (top a) (top b) (top c)
|
||||
N.ValRetypes a b c -> wrap3 "val-retypes" (top a) (top b) (top c)
|
||||
N.Reshapes a b c -> wrap3 "reshapes" (top a) (top b) (top c)
|
||||
N.ValReshapes a b c -> wrap3 "val-reshapes" (top a) (top b) (top c)
|
||||
N.ValOf a b -> wrap2 "valof" (top a) (top b)
|
||||
N.Sub (N.Node _ (N.SubPlain b)) a -> wrap2 "sub" (top a) (top b)
|
||||
N.Sub (N.Node _ (N.SubFromFor b c)) a -> wrap3 "sub-from-for" (top a) (top b) (top c)
|
||||
N.Sub (N.Node _ (N.SubFrom b)) a -> wrap2 "sub-from" (top a) (top b)
|
||||
N.Sub (N.Node _ (N.SubFor b)) a -> wrap2 "sub-for" (top a) (top b)
|
||||
N.CaseExps a b -> wrap2 "case-exps" (List $ map top a) (top b)
|
||||
N.Else a -> wrap "else" (top a)
|
||||
N.For a b c -> wrap3 "for" (top a) (top b) (top c)
|
||||
N.Conv a b -> wrap2 "conv" (top a) (top b)
|
||||
N.Round a b -> wrap2 "round" (top a) (top b)
|
||||
N.Trunc a b -> wrap2 "trunc" (top a) (top b)
|
||||
N.DyadicOp o a b -> wrap2 (dyadicName o) (top a) (top b)
|
||||
N.MonadicOp o a -> wrap (monadicName o) (top a)
|
||||
N.MostPos a -> wrap "mostpos" (top a)
|
||||
N.MostNeg a -> wrap "mostneg" (top a)
|
||||
N.Size a -> wrap "size" (top a)
|
||||
N.Call a b -> wrapl1 "call" (top a) (map top b)
|
||||
N.BytesIn a -> wrap "bytesin" (top a)
|
||||
N.OffsetOf a b -> wrap2 "offsetof" (top a) (top b)
|
||||
N.Guard a b -> wrap2 "guard" (top a) (top b)
|
||||
N.CondGuard a b -> wrap2 "cond" (top a) (top b)
|
||||
N.Choice a b -> wrap2 "choice" (top a) (top b)
|
||||
N.Val a -> wrap "val" (top a)
|
||||
N.ChanOf a -> wrap "chan" (top a)
|
||||
N.PortOf a -> wrap "port" (top a)
|
||||
N.Timer -> Item "timer"
|
||||
N.Array a b -> wrap2 "array" (top a) (top b)
|
||||
N.ArrayUnsized a -> wrap "array-unsized" (top a)
|
||||
N.Counted a b -> wrap2 "::" (top a) (top b)
|
||||
N.Bool -> Item "bool"
|
||||
N.Byte -> Item "byte"
|
||||
N.Int -> Item "int"
|
||||
N.Int16 -> Item "int16"
|
||||
N.Int32 -> Item "int32"
|
||||
N.Int64 -> Item "int64"
|
||||
N.Real32 -> Item "real32"
|
||||
N.Real64 -> Item "real64"
|
||||
N.Any -> Item "any"
|
||||
N.TypedLit a b -> wrap2 "typed-literal" (top a) (top b)
|
||||
N.LitReal a -> wrap "real-literal" (Item a)
|
||||
N.LitInt a -> wrap "integer-literal" (Item a)
|
||||
N.LitHex a -> wrap "hex-literal" (Item a)
|
||||
N.LitByte a -> wrap "byte-literal" (Item ("'" ++ a ++ "'"))
|
||||
N.LitString a -> wrap "string-literal" (Item ("\"" ++ a ++ "\""))
|
||||
N.LitArray a -> wrapl "array-literal" (map top a)
|
||||
N.True -> Item "true"
|
||||
N.False -> Item "false"
|
||||
N.Name a -> wrap "name" (Item a)
|
||||
_ -> error $ "Unsupported node: " ++ (show node)
|
||||
where top = nodeToSExp
|
||||
wrap name arg = List [Item name, arg]
|
||||
wrap2 name arg1 arg2 = List [Item name, arg1, arg2]
|
||||
wrap3 name arg1 arg2 arg3 = List [Item name, arg1, arg2, arg3]
|
||||
wrap4 name arg1 arg2 arg3 arg4 = List [Item name, arg1, arg2, arg3, arg4]
|
||||
wrapl name args = List ((Item name) : args)
|
||||
wrapl1 name arg1 args = List ((Item name) : arg1 : args)
|
||||
wrapl2 name arg1 arg2 args = List ((Item name) : arg1 : arg2 : args)
|
||||
|
||||
nodeToSOccam :: N.Node -> SExp
|
||||
nodeToSOccam (N.Node meta node)
|
||||
= case node of
|
||||
N.Decl a b -> wrap2 ":" (top a) (top b)
|
||||
N.Alt a -> wrapl "alt" (map top a)
|
||||
N.AltRep a b -> wrap2 "alt" (top a) (top b)
|
||||
N.PriAlt a -> wrapl "pri-alt" (map top a)
|
||||
N.PriAltRep a b -> wrap2 "pri-alt" (top a) (top b)
|
||||
N.In a (N.Node _ (N.InSimple b)) -> wrapl1 "?" (top a) (map top b)
|
||||
N.Variant a b -> wrap2 "variant" (top a) (top b)
|
||||
N.In a (N.Node _ (N.InCase b)) -> wrapl1 "?case" (top a) (map top b)
|
||||
N.In a (N.Node _ (N.InTag b)) -> wrap2 "?case-tag" (top a) (top b)
|
||||
N.In a (N.Node _ (N.InAfter b)) -> wrap2 "?after" (top a) (top b)
|
||||
N.Out a b -> wrapl1 "!" (top a) (map top b)
|
||||
N.OutCase a b c -> wrapl2 "!case" (top a) (top b) (map top c)
|
||||
N.ExpList a -> List (map top a)
|
||||
N.Assign a b -> wrap2 ":=" (List $ map top a) (top b)
|
||||
N.If a -> wrapl "if" (map top a)
|
||||
N.IfRep a b -> wrap2 "if" (top a) (top b)
|
||||
N.While a b -> wrap2 "while" (top a) (top b)
|
||||
N.Par a -> wrapl "par" (map top a)
|
||||
N.ParRep a b -> wrap2 "par" (top a) (top b)
|
||||
N.PriPar a -> wrapl "pri-par" (map top a)
|
||||
N.PriParRep a b -> wrap2 "pri-par" (top a) (top b)
|
||||
N.PlacedPar a -> wrapl "placed-par" (map top a)
|
||||
N.PlacedParRep a b -> wrap2 "placed-par" (top a) (top b)
|
||||
N.Processor a b -> wrap2 "processor" (top a) (top b)
|
||||
N.Skip -> Item "skip"
|
||||
N.Stop -> Item "stop"
|
||||
N.Case a b -> wrapl1 "case" (top a) (map top b)
|
||||
N.Seq a -> wrapl "seq" (map top a)
|
||||
N.SeqRep a b -> wrap2 "seq" (top a) (top b)
|
||||
N.ProcCall a b -> List ((top a) : (map top b))
|
||||
N.MainProcess -> Item "main"
|
||||
N.Vars a b -> List ((top a) : (map top b))
|
||||
N.Is a b -> wrap2 "is" (top a) (top b)
|
||||
N.IsType a b c -> wrap3 "is" (top a) (top b) (top c)
|
||||
N.ValIs a b -> wrap2 "val-is" (top a) (top b)
|
||||
N.ValIsType a b c -> wrap3 "val-is" (top a) (top b) (top c)
|
||||
N.Place a b -> wrap2 "place-at" (top a) (top b)
|
||||
N.DataType a b -> wrap2 "data-type" (top a) (top b)
|
||||
N.Record a -> wrapl "record" (map top a)
|
||||
N.PackedRecord a -> wrapl "packed-record" (map top a)
|
||||
N.Fields a b -> List ((top a) : (map top b))
|
||||
N.Protocol a b -> wrapl1 "protocol" (top a) (map top b)
|
||||
N.TaggedProtocol a b -> wrapl1 "protocol" (top a) (map top b)
|
||||
N.Tag a b -> List ((top a) : (map top b))
|
||||
N.Formals a b -> List ((top a) : (map top b))
|
||||
N.Proc a b c -> wrap3 "proc" (top a) (List $ map top b) (top c)
|
||||
N.Func a b c d -> wrap4 "function" (top a) (List $ map top b) (List $ map top c) (top d)
|
||||
N.FuncIs a b c d -> wrap4 "function-is" (top a) (List $ map top b) (List $ map top c) (top d)
|
||||
N.Retypes a b c -> wrap3 "retypes" (top a) (top b) (top c)
|
||||
N.ValRetypes a b c -> wrap3 "val-retypes" (top a) (top b) (top c)
|
||||
N.Reshapes a b c -> wrap3 "reshapes" (top a) (top b) (top c)
|
||||
N.ValReshapes a b c -> wrap3 "val-reshapes" (top a) (top b) (top c)
|
||||
N.ValOf a b -> wrap2 "valof" (top a) (top b)
|
||||
N.Sub (N.Node _ (N.SubPlain b)) a -> wrap2 "sub" (top a) (top b)
|
||||
N.Sub (N.Node _ (N.SubFromFor b c)) a -> wrap3 "sub-from-for" (top a) (top b) (top c)
|
||||
N.Sub (N.Node _ (N.SubFrom b)) a -> wrap2 "sub-from" (top a) (top b)
|
||||
N.Sub (N.Node _ (N.SubFor b)) a -> wrap2 "sub-for" (top a) (top b)
|
||||
N.CaseExps a b -> l2 (List $ map top a) (top b)
|
||||
N.Else a -> wrap "else" (top a)
|
||||
N.For a b c -> wrap3 "for" (top a) (top b) (top c)
|
||||
N.Conv a b -> wrap2 "conv" (top a) (top b)
|
||||
N.Round a b -> wrap2 "round" (top a) (top b)
|
||||
N.Trunc a b -> wrap2 "trunc" (top a) (top b)
|
||||
N.DyadicOp o a b -> wrap2 (dyadicName o) (top a) (top b)
|
||||
N.MonadicOp o a -> wrap (monadicName o) (top a)
|
||||
N.MostPos a -> wrap "mostpos" (top a)
|
||||
N.MostNeg a -> wrap "mostneg" (top a)
|
||||
N.Size a -> wrap "size" (top a)
|
||||
N.Call a b -> wrapl1 "call" (top a) (map top b)
|
||||
N.BytesIn a -> wrap "bytesin" (top a)
|
||||
N.OffsetOf a b -> wrap2 "offsetof" (top a) (top b)
|
||||
N.Guard a b -> List [top a, top b]
|
||||
N.CondGuard a b -> wrap2 "cond" (top a) (top b)
|
||||
N.Choice a b -> List [top a, top b]
|
||||
N.Val a -> wrap "val" (top a)
|
||||
N.ChanOf a -> wrap "chan" (top a)
|
||||
N.PortOf a -> wrap "port" (top a)
|
||||
N.Timer -> Item "timer"
|
||||
N.Array a b -> wrap2 "array" (top a) (top b)
|
||||
N.ArrayUnsized a -> wrap "array" (top a)
|
||||
N.Counted a b -> wrap2 "::" (top a) (top b)
|
||||
N.Bool -> Item "bool"
|
||||
N.Byte -> Item "byte"
|
||||
N.Int -> Item "int"
|
||||
N.Int16 -> Item "int16"
|
||||
N.Int32 -> Item "int32"
|
||||
N.Int64 -> Item "int64"
|
||||
N.Real32 -> Item "real32"
|
||||
N.Real64 -> Item "real64"
|
||||
N.Any -> Item "any"
|
||||
N.TypedLit a b -> l2 (top a) (top b)
|
||||
N.LitReal a -> Item a
|
||||
N.LitInt a -> Item a
|
||||
N.LitHex a -> Item a
|
||||
N.LitByte a -> Item ("'" ++ a ++ "'")
|
||||
N.LitString a -> Item ("\"" ++ a ++ "\"")
|
||||
N.LitArray a -> List (map top a)
|
||||
N.True -> Item "true"
|
||||
N.False -> Item "false"
|
||||
N.Name a -> Item a
|
||||
_ -> error $ "Unsupported node: " ++ (show node)
|
||||
where top = nodeToSOccam
|
||||
wrap name arg = List [Item name, arg]
|
||||
wrap2 name arg1 arg2 = List [Item name, arg1, arg2]
|
||||
wrap3 name arg1 arg2 arg3 = List [Item name, arg1, arg2, arg3]
|
||||
wrap4 name arg1 arg2 arg3 arg4 = List [Item name, arg1, arg2, arg3, arg4]
|
||||
wrapl name args = List ((Item name) : args)
|
||||
wrapl1 name arg1 args = List ((Item name) : arg1 : args)
|
||||
wrapl2 name arg1 arg2 args = List ((Item name) : arg1 : arg2 : args)
|
||||
l2 arg1 arg2 = List [arg1, arg2]
|
||||
|
||||
|
|
@ -1,21 +0,0 @@
|
|||
all: writeup.dvi writeup.pdf fco-pres.dvi fco-pres.pdf
|
||||
|
||||
LATEX = latex -interaction=nonstopmode
|
||||
|
||||
writeup.dvi: writeup.tex the.bib
|
||||
rm -f writeup.bbl
|
||||
$(LATEX) writeup.tex
|
||||
bibtex writeup
|
||||
$(LATEX) writeup.tex
|
||||
$(LATEX) writeup.tex
|
||||
rm -f writeup.aux writeup.bbl writeup.blg writeup.log writeup.toc
|
||||
|
||||
fco-pres.dvi: fco-pres.tex
|
||||
$(LATEX) fco-pres.tex
|
||||
$(LATEX) fco-pres.tex
|
||||
$(LATEX) fco-pres.tex
|
||||
rm -f fco-pres.aux fco-pres.log fco-pres.toc
|
||||
|
||||
%.pdf: %.dvi
|
||||
dvipdf $<
|
||||
|
||||
|
|
@ -1,85 +0,0 @@
|
|||
%==============================================================================
|
||||
% PPRadam.sty by Adam Sampson <ats@offog.org> -- based on:
|
||||
% Prosper -- (PPRframes.sty) Style file
|
||||
% A LaTeX class for creating slides
|
||||
% Author: Frederic Goualard (Frederic.Goualard@irin.univ-nantes.fr)
|
||||
% Institut de Recherche en Informatique de Nantes
|
||||
% University of Nantes, France
|
||||
%
|
||||
% Copyright (c) 2000 Frederic Goualard
|
||||
% All rights reserved.
|
||||
%
|
||||
% Permission is hereby granted, without written agreement and without
|
||||
% license or royalty fees, to use, copy, modify, and distribute this
|
||||
% software and its documentation for any purpose, provided that the
|
||||
% above copyright notice and the following two paragraphs appear in
|
||||
% all copies of this software.
|
||||
%
|
||||
% IN NO EVENT SHALL THE AUTHOR BE LIABLE TO ANY PARTY FOR DIRECT, INDIRECT,
|
||||
% SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OF
|
||||
% THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE AUTHOR HAS BEEN ADVISED
|
||||
% OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
%
|
||||
%
|
||||
% THE AUTHOR SPECIFICALLY DISCLAIMS ANY WARRANTIES,
|
||||
% INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
|
||||
% AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS
|
||||
% ON AN "AS IS" BASIS, AND THE AUTHOR HAS NO OBLIGATION TO
|
||||
% PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
|
||||
%
|
||||
% CVSId : $Id: PPRadam.sty,v 1.1 2005/09/13 18:47:50 azz Exp $
|
||||
%==============================================================================
|
||||
\NeedsTeXFormat{LaTeX2e}[1995/12/01]
|
||||
\ProvidesPackage{PPRadam}[2006/09/15]
|
||||
\typeout{`Adam' style for prosper ---}
|
||||
\typeout{(c) 2000 Frederic Goualard, IRIN, France, 2005, 2006 Adam Sampson}
|
||||
\typeout{CVSId: $Id: PPRadam.sty,v 1.1 2005/09/13 18:47:50 azz Exp $}
|
||||
\typeout{ }
|
||||
|
||||
\RequirePackage{semhelv}
|
||||
\RequirePackage{amssymb}
|
||||
|
||||
% Chargement des fichiers de pstricks (on teste les noms en vigueur pour
|
||||
% gérer les différentes versions de pstricks).
|
||||
\IfFileExists{pst-grad}{\RequirePackage{pst-grad}}{\RequirePackage{gradient}}
|
||||
|
||||
\newgray{gris1}{.40}
|
||||
\newgray{gris2}{.85}
|
||||
\newgray{gris3}{.30}
|
||||
\newgray{gris4}{.25}
|
||||
\newgray{gris5}{.90}
|
||||
|
||||
\FontTitle{\usefont{T1}{phv}{b}{sl}\fontsize{14.4pt}{12pt}\selectfont}{%
|
||||
\usefont{T1}{phv}{b}{sl}\fontsize{14.4pt}{12pt}\selectfont}
|
||||
\FontText{\usefont{T1}{phv}{m}{n}\fontsize{13pt}{12pt}\selectfont}{%
|
||||
\usefont{T1}{phv}{m}{n}\fontsize{13pt}{12pt}\selectfont}
|
||||
|
||||
\def\labelitemi{\ensuremath{\blacktriangleright}}
|
||||
|
||||
\myitem{1}{\ensuremath{\blacktriangleright}}
|
||||
\myitem{2}{\ensuremath{\blacktriangleright}}
|
||||
\myitem{3}{\ensuremath{\blacktriangleright}}
|
||||
|
||||
\newcommand{\slidetitle}[1]{%
|
||||
\rput[rb](11.6,3.6){%
|
||||
\parbox{9cm}{\begin{flushright}\fontTitle{#1}\end{flushright}}}}
|
||||
|
||||
\LogoPosition{-.7,-.1}
|
||||
|
||||
\def\TWRFrame#1{%
|
||||
\psframe[linestyle=none,fillstyle=gradient,gradangle=90,
|
||||
gradbegin=black,gradend=gris2,gradmidpoint=0.7]%
|
||||
(-1.2,7)(11.6,7.1)
|
||||
\PutLogo % Mandatory
|
||||
{#1}}
|
||||
|
||||
\NewSlideStyle[115mm]{t}{5.3,3.0}{TWRFrame}
|
||||
\PDFCroppingBox{10 40 594 820}
|
||||
|
||||
|
||||
\endinput
|
||||
|
||||
%%% Local Variables:
|
||||
%%% mode: latex
|
||||
%%% TeX-master: t
|
||||
%%% End:
|
||||
|
|
@ -1,650 +0,0 @@
|
|||
\documentclass[adam,pdf,slideColor]{prosper}
|
||||
\usepackage{graphicx}
|
||||
\usepackage{pifont}
|
||||
\usepackage{xspace}
|
||||
\usepackage{alltt}
|
||||
\def\occampi{{occam-\Pisymbol{psy}{112}}\xspace}
|
||||
\def\picalculus{{\Pisymbol{psy}{112}-calculus}\xspace}
|
||||
\definecolor{Red}{rgb}{0.6,0.0,0.0}
|
||||
\definecolor{Green}{rgb}{0.0,0.6,0.0}
|
||||
\definecolor{Blue}{rgb}{0.0,0.0,0.6}
|
||||
\definecolor{Purple}{rgb}{0.6,0.0,0.6}
|
||||
\definecolor{Brown}{rgb}{0.5,0.5,0.0}
|
||||
\def\keyword#1{{\color{Green}#1}}
|
||||
\def\operator#1{{\color{Purple}#1}}
|
||||
\def\highlight#1{{\color{Brown}#1}}
|
||||
|
||||
\Logo(-1.0,7.3){\includegraphics[width=3cm]{kent.eps}}
|
||||
|
||||
\title{Exploring nanopass compilation in Haskell}
|
||||
\author{Adam Sampson}
|
||||
\email{{\tt ats1@kent.ac.uk}}
|
||||
\institution{University of Kent\\ {\tt http://www.cs.kent.ac.uk/}}
|
||||
\slideCaption{FCO}
|
||||
|
||||
\begin{document}
|
||||
|
||||
\maketitle
|
||||
|
||||
\begin{slide}{Why?}
|
||||
\begin{itemize}
|
||||
\item We've been looking at using Scheme
|
||||
\begin{itemize}
|
||||
\item Popular in the States, less so over here
|
||||
\item Good libraries for compilation
|
||||
\end{itemize}
|
||||
\item Lots of Haskell users in the lab already
|
||||
\begin{itemize}
|
||||
\item \ldots including all our undergrads
|
||||
\item Also heavily used for compiler work
|
||||
\end{itemize}
|
||||
\item Should we use Haskell instead?
|
||||
\end{itemize}
|
||||
\end{slide}
|
||||
|
||||
\begin{slide}{What I've been doing}
|
||||
\begin{itemize}
|
||||
\item Building bits of FCO: a nanopass occam compiler in Haskell
|
||||
\begin{itemize}
|
||||
\item Functional Compiler for occam
|
||||
\end{itemize}
|
||||
\item This is an exploration -- a ``spike solution''
|
||||
\item Checking that all the things we want to do are possible
|
||||
\item Warning: may contain traces of handwaving
|
||||
\item I'll assume some knowledge of occam and Haskell; if anything's
|
||||
not clear, please shout
|
||||
\end{itemize}
|
||||
\end{slide}
|
||||
|
||||
\begin{slide}{Haskell}
|
||||
\begin{itemize}
|
||||
\item Mature purely-functional language
|
||||
\item Open spec; several implementations
|
||||
\item Powerful static type system
|
||||
\item Built-in pattern matching
|
||||
\item Good support for monadic programming
|
||||
\item Lazy evaluation
|
||||
\item Supports lightweight concurrency
|
||||
\item Nice syntax (for occam programmers)
|
||||
\item Lots of cool recent work (some of which I'll show later)
|
||||
\item See the ``History of Haskell'' HoPL paper
|
||||
\end{itemize}
|
||||
\end{slide}
|
||||
|
||||
\begin{slide}{Existing work}
|
||||
\begin{itemize}
|
||||
\item occam2.1 language spec -- with a BNF syntax
|
||||
\item 42 -- the model for this, in Scheme
|
||||
\item occ21 -- the only full existing implementation, in C
|
||||
\item JHC -- Haskell to C, in Haskell
|
||||
\item Pugs -- Perl 6 to various, in Haskell
|
||||
\item (Also GHC, Mincaml and a few others)
|
||||
\end{itemize}
|
||||
\end{slide}
|
||||
|
||||
\begin{slide}{A nanopass refresher}
|
||||
\begin{itemize}
|
||||
\item Parse language into AST
|
||||
\item Do many small passes over the AST
|
||||
\begin{itemize}
|
||||
\item Checks
|
||||
\item Annotations
|
||||
\item Transformations
|
||||
\end{itemize}
|
||||
\item Output
|
||||
\end{itemize}
|
||||
\end{slide}
|
||||
|
||||
\begin{slide}{FCO's target}
|
||||
\begin{itemize}
|
||||
\item Translate occam to idiomatic C
|
||||
\begin{itemize}
|
||||
\item Use CIF for concurrency
|
||||
\item Bugbear: calculating stack usage
|
||||
\end{itemize}
|
||||
\item Whole-program compilation
|
||||
\begin{itemize}
|
||||
\item Allows whole-program optimisations and checks
|
||||
\item Can still do separate parsing/checks/early passes; just do final
|
||||
translation at ``link time''
|
||||
\end{itemize}
|
||||
\item FCO is not finished, but I believe the approach is sound
|
||||
\end{itemize}
|
||||
\end{slide}
|
||||
|
||||
\begin{slide}{Challenges}
|
||||
\begin{itemize}
|
||||
\item Parsing
|
||||
\item Data structures
|
||||
\item Writing transformations
|
||||
\item Driver and IO
|
||||
\item Extensibility
|
||||
\item Debugging and tracing
|
||||
\end{itemize}
|
||||
\end{slide}
|
||||
|
||||
\begin{slide}{Parsing}
|
||||
\begin{itemize}
|
||||
\item 42 hasn't tackled this yet
|
||||
\item occam2.1 has some oddities:
|
||||
\begin{itemize}
|
||||
\item Lots of lookahead needed
|
||||
\item Indentation-based syntax
|
||||
\item Odd line-continuation rules
|
||||
\item Ambiguities
|
||||
\item Left-recursive productions
|
||||
\end{itemize}
|
||||
\item occ21's parser keeps lots of state; we don't want to do that
|
||||
\end{itemize}
|
||||
\end{slide}
|
||||
|
||||
\begin{slide}{Parsing by passes}
|
||||
\begin{itemize}
|
||||
\item Break down ``parsing'' into several passes:
|
||||
\begin{itemize}
|
||||
\item Execute (some) preprocessor instructions
|
||||
\item Detect and rejoin continuation lines
|
||||
\item Convert indentation changes to tokens
|
||||
\item \ldots then just use a regular parser
|
||||
\item Resolve ambiguities later
|
||||
\end{itemize}
|
||||
\item (\verb|occamdoc| does much of this already)
|
||||
\end{itemize}
|
||||
\end{slide}
|
||||
|
||||
\begin{slide}{Parsing by Parsec}
|
||||
\begin{itemize}
|
||||
\item A combinator-based parsing library for Haskell
|
||||
\item Productions look pretty much like BNF, e.g.:
|
||||
\begin{verbatim}
|
||||
specification = declaration
|
||||
<|> abbreviation
|
||||
<|> definition
|
||||
sequence = do { sSEQ ; eol ; indent ;
|
||||
ps <- many1 process ;
|
||||
...
|
||||
\end{verbatim}
|
||||
\item Uses Prolog-style backtracking and cuts -- no lookahead problems
|
||||
\item All done using monads
|
||||
\end{itemize}
|
||||
\end{slide}
|
||||
|
||||
\begin{slide}{Monads}
|
||||
\begin{itemize}
|
||||
\item A data type that wraps a value
|
||||
\item A monadic function can return a value and/or change the wrapper
|
||||
\item For example:
|
||||
\begin{itemize}
|
||||
\item \verb|State| monad contains a user-defined state value
|
||||
\item \verb|IO| monad has ``state of the world'' (so IO functions
|
||||
can interact with the world)
|
||||
\item \verb|Parser| monad (from Parsec) keeps track of file location,
|
||||
backtracking, etc.
|
||||
\end{itemize}
|
||||
\end{itemize}
|
||||
\end{slide}
|
||||
|
||||
\begin{slide}{Monad combinators}
|
||||
\begin{itemize}
|
||||
\item Combinators let you chain monadic functions together
|
||||
\item Each monad defines how the ``bind'' operator (a standard
|
||||
combinator) works -- e.g. pass state through, backtrack upon
|
||||
failure, etc.
|
||||
\item Haskell has special syntax (\verb|do| blocks) for bind
|
||||
\item Monads can define their own combinators (e.g. \verb,<|>, in Parsec)
|
||||
\end{itemize}
|
||||
\end{slide}
|
||||
|
||||
\begin{slide}{Monad example}
|
||||
\begin{itemize}
|
||||
\item Function in \verb|State| monad that returns unique ID
|
||||
\item The \verb|get| and \verb|put| functions come from the monad
|
||||
\item \verb|return| wraps a value in the monad
|
||||
\item \verb|do| block chains the three functions together
|
||||
\end{itemize}
|
||||
\begin{verbatim}
|
||||
-- Define our own monad based on State.
|
||||
-- The state is a single Int.
|
||||
type UniqueState t = State Int t
|
||||
|
||||
-- This returns an Int in our monad.
|
||||
getID :: UniqueState Int
|
||||
getID = do counter <- get
|
||||
put (counter + 1)
|
||||
return counter
|
||||
\end{verbatim}
|
||||
\end{slide}
|
||||
|
||||
\begin{slide}{Ambiguities}
|
||||
\begin{itemize}
|
||||
\item Two ambiguities in occam 2.1 syntax as specified in the
|
||||
manual
|
||||
\item \verb|c ! x ; y|
|
||||
\begin{itemize}
|
||||
\item Is \verb|x| a tag or a variable name?
|
||||
\end{itemize}
|
||||
\item \verb|foo[x]|
|
||||
\begin{itemize}
|
||||
\item Is this an array element, or\ldots
|
||||
\item \ldots is this retyping the array literal \verb|[x]| to the
|
||||
user-defined type \verb|foo|?
|
||||
\item You can't retype an array -- fix the grammar to reflect this
|
||||
\end{itemize}
|
||||
\item Any more? What about \occampi?
|
||||
\end{itemize}
|
||||
\end{slide}
|
||||
|
||||
\begin{slide}{Data structures}
|
||||
\begin{itemize}
|
||||
\item Represent an AST node
|
||||
\item Metadata
|
||||
\begin{itemize}
|
||||
\item Source position
|
||||
\item Annotations from passes
|
||||
\end{itemize}
|
||||
\item In occ21 and 42, a record for each node type
|
||||
\item In Haskell, I've tried two approaches
|
||||
\end{itemize}
|
||||
\end{slide}
|
||||
|
||||
\begin{slide}{Data structures: ``parse tree''}
|
||||
\begin{itemize}
|
||||
\item A catch-all \verb|Node| ADT
|
||||
\item \verb|Meta| contains metadata
|
||||
\begin{verbatim}
|
||||
data Node = (Meta, NodeType)
|
||||
|
||||
data NodeType = Seq [Node]
|
||||
| AltGuard Node Node
|
||||
| Name String
|
||||
| ...
|
||||
\end{verbatim}
|
||||
\item Pattern matching's easy
|
||||
\item Straightforward to write traversal code
|
||||
\item This feels a bit non-Haskell-ish
|
||||
\end{itemize}
|
||||
\end{slide}
|
||||
|
||||
\begin{slide}{Data structures: ``AST''}
|
||||
\begin{itemize}
|
||||
\item One ADT per production (with simplifications)
|
||||
\begin{verbatim}
|
||||
data Process = Seq Meta [Process]
|
||||
| Alt Meta [AltGrd]
|
||||
| Assign [Var] ExpList
|
||||
| Skip Meta | ...
|
||||
|
||||
data AltGrd = AltGrd Meta Guard Process
|
||||
| ...
|
||||
\end{verbatim}
|
||||
\item This is what other compilers do
|
||||
\item \ldots but writing code to process it is harder
|
||||
\item (I'll come back to this later)
|
||||
\end{itemize}
|
||||
\end{slide}
|
||||
|
||||
\begin{slide}{Transformations}
|
||||
\begin{itemize}
|
||||
\item Walk over the tree, finding interesting bits of it and Doing
|
||||
Stuff to them
|
||||
\item Some bits are purely functional; some must carry state
|
||||
\item Checks and annotations are just transformations that don't
|
||||
change the tree
|
||||
\item 42 does this using PLT's pattern-matching library
|
||||
\item Can we use Haskell's built-in pattern-matching?
|
||||
\end{itemize}
|
||||
\end{slide}
|
||||
|
||||
\begin{slide}{Pattern-matching}
|
||||
\begin{itemize}
|
||||
\item Yes! At least, it's trivial for the \verb|Node| data structure:
|
||||
\begin{verbatim}
|
||||
myPass n = case n of
|
||||
Seq ps -> doSeq (map myPass ps)
|
||||
Name s -> doName s
|
||||
...
|
||||
\end{verbatim}
|
||||
\item Writing the boilerplate like that for every pass is rather
|
||||
boring (and hard to extend), though
|
||||
\end{itemize}
|
||||
\end{slide}
|
||||
|
||||
\begin{slide}{Base passes}
|
||||
\begin{itemize}
|
||||
\item Rather than direct recursion, have a
|
||||
``base pass'' function
|
||||
\begin{verbatim}
|
||||
basePass top n = case n of
|
||||
Seq ps -> Seq (map top ps)
|
||||
Name s -> Name s
|
||||
\end{verbatim}
|
||||
\item Then every pass can use that:
|
||||
\begin{verbatim}
|
||||
doStuff n = case n of
|
||||
Thing a -> doThing (pt a)
|
||||
otherwise -> pt a
|
||||
where pt = basePass doStuff
|
||||
\end{verbatim}
|
||||
\item Slightly fancier glue for error handling, etc.
|
||||
\end{itemize}
|
||||
\end{slide}
|
||||
|
||||
\begin{slide}{Generated base passes}
|
||||
\begin{itemize}
|
||||
\item No need to write the base passes by hand
|
||||
\item Generate them automatically from the data type definition (using
|
||||
Template Haskell, or simpler approaches)
|
||||
\item Can generate several base passes for different subsets of the
|
||||
allowed productions
|
||||
\end{itemize}
|
||||
\end{slide}
|
||||
|
||||
\begin{slide}{The bad news}
|
||||
\begin{itemize}
|
||||
\item However, this all only works because we're restricted to one
|
||||
data type
|
||||
\item And complicated passes get very messy\ldots
|
||||
\item How do we do this for the ``AST'' data types?
|
||||
\item We'd need to write \emph{generic} functions that would work on
|
||||
several data types
|
||||
\item Fortunately\ldots
|
||||
\end{itemize}
|
||||
\end{slide}
|
||||
|
||||
\begin{slide}{Scrap Your Boilerplate}
|
||||
\begin{itemize}
|
||||
\item The ``SYB'' Generics package lets you turn:
|
||||
\begin{verbatim}
|
||||
foo :: Process -> Process
|
||||
\end{verbatim}
|
||||
into:
|
||||
\begin{verbatim}
|
||||
foo :: Typeable a => a -> a
|
||||
\end{verbatim}
|
||||
\ldots a function you can apply to any \verb|Typeable| type
|
||||
\item A \emph{really} cute hack to provide introspection and dynamic
|
||||
typing (\verb|cast|) in Haskell
|
||||
\end{itemize}
|
||||
\end{slide}
|
||||
|
||||
\begin{slide}{An aside on typeclasses}
|
||||
\begin{itemize}
|
||||
\item Typeclasses are really nothing like OO classes
|
||||
\item A typeclass is an interface: a set of functions
|
||||
\begin{itemize}
|
||||
\item The \verb|Show| typeclass provides the \verb|show| function
|
||||
\item \verb|Eq| provides equality tests
|
||||
\item \verb|Typeable| provides ``what's the type of this value?''
|
||||
\end{itemize}
|
||||
\item If a type is an instance of a typeclass, then it has
|
||||
implementations of all that typeclass's functions for that type
|
||||
\item The Haskell compiler can ``derive'' instances of the built-in
|
||||
typeclasses (including \verb|Typeable| and \verb|Data|) automatically
|
||||
\end{itemize}
|
||||
\end{slide}
|
||||
|
||||
\begin{slide}{Scrap More Boilerplate}
|
||||
\begin{itemize}
|
||||
\item These functions do not automatically recurse
|
||||
\item Instead, you get \verb|gmapT| -- ``generic map'', which peers
|
||||
carefully at the value's type, and maps across all the type
|
||||
constructor arguments
|
||||
\item For example:
|
||||
\end{itemize}
|
||||
\begin{verbatim}
|
||||
data Thing = Thing Foo Bar Baz
|
||||
deriving (Typeable, Data)
|
||||
v :: Thing -- some Thing
|
||||
t :: Typeable a => a -> a -- a transform
|
||||
f = gmap t v
|
||||
f' (Thing x y z) = Thing (t x) (t y) (t z)
|
||||
\end{verbatim}
|
||||
\begin{itemize}
|
||||
\item \verb|f| and \verb|f'| are equivalent -- but f is itself generic.
|
||||
\end{itemize}
|
||||
\end{slide}
|
||||
|
||||
\begin{slide}{Scrap The Whole Boiler}
|
||||
\begin{itemize}
|
||||
\item Using this, you can write a function that'll recurse across an
|
||||
entire data structure, applying the transform wherever it can
|
||||
\item \ldots and, actually, they give it to you -- \verb|everywhere|
|
||||
\item You also get functions to extend a generic transform with a
|
||||
type-specific case
|
||||
\begin{verbatim}
|
||||
doAny = doGen `extT` doPar
|
||||
`extT` doSeq ...
|
||||
\end{verbatim}
|
||||
\item There are monadic and query (i.e. returning a result rather than
|
||||
doing a transformation) versions of all these facilities too
|
||||
\end{itemize}
|
||||
\end{slide}
|
||||
|
||||
\begin{slide}{Scrapping My Boilerplate}
|
||||
\begin{itemize}
|
||||
\item By making \verb|Node| derive \verb|Data|, we can do away with
|
||||
the base passes in favour of generic functions
|
||||
\item This works for any set of ADTs
|
||||
\item For example:
|
||||
\begin{verbatim}
|
||||
doName :: Name -> Name
|
||||
doName (Name s) =
|
||||
Name [if c == '.' then '_' else c
|
||||
| c <- s]
|
||||
|
||||
cIshNamesPass = everywhere (mkT doName)
|
||||
\end{verbatim}
|
||||
\item This can be applied to a \verb|Name|, \verb|Process|,
|
||||
\verb|Declaration|, etc. and works recursively
|
||||
\end{itemize}
|
||||
\end{slide}
|
||||
|
||||
\begin{slide}{Scrap Your Boilerstate}
|
||||
\begin{itemize}
|
||||
\item Passes that need state can use the \verb|State| monad
|
||||
\item For example, tracking variable scope
|
||||
\item I have a marvellous example of this but this slide is too small
|
||||
to contain it -- see the real code
|
||||
\item The ``unique names'' pass is rather more concise in FCO than
|
||||
in 42 owing to the use of generics
|
||||
\end{itemize}
|
||||
\end{slide}
|
||||
|
||||
\begin{slide}{Driver and IO}
|
||||
\begin{itemize}
|
||||
\item The code that sets up and runs all the bits of the compiler, and
|
||||
interacts with the OS
|
||||
\item Dead easy in Haskell -- very good OS interfacing
|
||||
\item Worth cribbing from for \occampi's standard libraries\ldots
|
||||
\item We have lists of passes to apply (like 42)
|
||||
\item Passes are functions from one tree to another
|
||||
\item The tree is pretty-printed after each pass (in debug mode)
|
||||
\end{itemize}
|
||||
\end{slide}
|
||||
|
||||
\begin{slide}{Extensibility}
|
||||
\begin{itemize}
|
||||
\item Want to be able to add:
|
||||
\begin{itemize}
|
||||
\item New AST node types
|
||||
\item New passes
|
||||
\end{itemize}
|
||||
\item Also accessibility, really
|
||||
\begin{itemize}
|
||||
\item Undergrads should be able to write extensions
|
||||
\end{itemize}
|
||||
\end{itemize}
|
||||
\end{slide}
|
||||
|
||||
\begin{slide}{Extensibility problems}
|
||||
\begin{itemize}
|
||||
\item Slotting in new passes is pretty trivial
|
||||
\item Creating new types of nodes is harder
|
||||
\item You can't extend an ADT
|
||||
\item More generally, transformations can't replace a value with a
|
||||
different type of value
|
||||
\item Several ways we could get around this\ldots
|
||||
\end{itemize}
|
||||
\end{slide}
|
||||
|
||||
\begin{slide}{Extensibility: ``plan ahead''}
|
||||
\begin{itemize}
|
||||
\item We could\ldots
|
||||
\item Include everything you could ever possibly want in your data
|
||||
types ahead of time
|
||||
\item Doable with \verb|Node|
|
||||
\begin{itemize}
|
||||
\item Early version of FCO extracted comment annotations in
|
||||
the \verb|Node| definition to decide which passes each node type was
|
||||
valid in
|
||||
\item Metaprogramming -- you can do it (Template Haskell), but it's a
|
||||
bit experimental\ldots
|
||||
\end{itemize}
|
||||
\item Really nasty with lots of ADTs
|
||||
\end{itemize}
|
||||
\end{slide}
|
||||
|
||||
\begin{slide}{Extensibility: ``whatEVERRRRR''}
|
||||
\begin{itemize}
|
||||
\item We could\ldots
|
||||
\item Use a very general data type
|
||||
\begin{verbatim}
|
||||
data Node = Node String Meta [Node]
|
||||
\end{verbatim}
|
||||
\item Emulating dynamic typing
|
||||
\item So why use a statically-typed language?
|
||||
\end{itemize}
|
||||
\end{slide}
|
||||
|
||||
\begin{slide}{Extensibility: ``from time to time''}
|
||||
\begin{itemize}
|
||||
\item We could\ldots
|
||||
\item Have several sets of ADTs
|
||||
\item When we need to change the language, have a big transformation
|
||||
pass between them
|
||||
\item This is what JHC/Pugs do (and what FCO does currently)
|
||||
\item Not really nanopass any more
|
||||
\begin{itemize}
|
||||
\item The transformation passes aren't necessarily entirely mechanical
|
||||
\end{itemize}
|
||||
\item Awkward to extend
|
||||
\end{itemize}
|
||||
\end{slide}
|
||||
|
||||
\begin{slide}{Extensibility: ``deep magic''}
|
||||
\begin{itemize}
|
||||
\item We could\ldots
|
||||
\item Use typeclasses and existential types (a la \verb|HList|)
|
||||
\item Doable but very messy
|
||||
\item Could require generating class instances automatically (using
|
||||
DrIFT or similar) as ``glue''
|
||||
\item Not clear how this interacts with generics
|
||||
\item Makes pattern-matching awkward (impossible?)
|
||||
\end{itemize}
|
||||
\end{slide}
|
||||
|
||||
\begin{slide}{Extensibility: the big worry}
|
||||
\begin{itemize}
|
||||
\item I feel like I'm fighting the type system\ldots
|
||||
\item Is the nanopass approach fundamentally incompatible with static
|
||||
typing?
|
||||
\item Or, alternately, is the Haskell type system insufficiently
|
||||
powerful to express it cleanly?
|
||||
\begin{itemize}
|
||||
\item Given the Haskell type system is one of the most powerful out
|
||||
there, these two are essentially equivalent
|
||||
\end{itemize}
|
||||
\item Is there some clean approach to this that I'm not seeing?
|
||||
\end{itemize}
|
||||
\end{slide}
|
||||
|
||||
\begin{slide}{Debugging}
|
||||
\begin{itemize}
|
||||
\item Even with static typing, many programs do not work right first
|
||||
time \verb|:-)|
|
||||
\item Haskell lacks debugging facilities
|
||||
\item Lazy evaluation can make debugging harder
|
||||
\item At the very least, we need tracing (as 42 has) -- ``\verb|printf|
|
||||
debugging''
|
||||
\item To do that, you need to use another monad
|
||||
\end{itemize}
|
||||
\end{slide}
|
||||
|
||||
\begin{slide}{Monad transformers}
|
||||
\begin{itemize}
|
||||
\item Much of our code will be running in a monad already
|
||||
\item \ldots but if you want to use more than one monad?
|
||||
\item Monad transformers let you ``stack up'' monads (e.g. State
|
||||
around IO)
|
||||
\item Getting at actions in the ``inner'' monads is slightly awkward
|
||||
(\verb|liftM|)
|
||||
\item \ldots and we want tracing, plus error-handling, plus the monads
|
||||
each pass needs -- perhaps four stacked monads in some code
|
||||
\item Lots of wrapper functions
|
||||
\begin{verbatim}
|
||||
trace' = liftM . liftM . liftM . trace
|
||||
\end{verbatim}
|
||||
\end{itemize}
|
||||
\end{slide}
|
||||
|
||||
\begin{slide}{Tracing}
|
||||
\begin{itemize}
|
||||
\item Awkward to insert tracing into monadic code
|
||||
\item \ldots but it's much more awkward to trace (or support failure
|
||||
in) functional code, because you have to first make it monadic
|
||||
\item Can't be hidden with wrappers
|
||||
\item \ldots so, in practice, everything becomes monadic
|
||||
\item A downside of the purely functional approach
|
||||
\end{itemize}
|
||||
\end{slide}
|
||||
|
||||
\begin{slide}{Conclusions}
|
||||
\begin{itemize}
|
||||
\item Haskell's a really elegant language\ldots
|
||||
\item \ldots but I don't think it's suited to this particular problem
|
||||
\item A number of useful things have come out of FCO, though\ldots
|
||||
\end{itemize}
|
||||
\end{slide}
|
||||
|
||||
\begin{slide}{Lessons}
|
||||
\begin{itemize}
|
||||
\item Decomposing the parser makes it simpler
|
||||
\item Use a backtracking parser
|
||||
\item Look at the full language
|
||||
\begin{itemize}
|
||||
\item Subtleties can require big changes
|
||||
\item Can test on real code
|
||||
\end{itemize}
|
||||
\item Take advantage of generic/introspective programming (perhaps
|
||||
with Scheme record annotations)
|
||||
\item Consider doing occam-to-C translation
|
||||
\begin{itemize}
|
||||
\item At a higher level than the VM
|
||||
\end{itemize}
|
||||
\end{itemize}
|
||||
\end{slide}
|
||||
|
||||
\begin{slide}{And finally}
|
||||
\begin{itemize}
|
||||
\item Any questions?
|
||||
\end{itemize}
|
||||
\end{slide}
|
||||
|
||||
\begin{slide}{References}
|
||||
\begin{itemize}
|
||||
\item The code's on my web site: \\
|
||||
\verb|http://offog.org/darcs/research/fco/|
|
||||
\item Wikibooks Haskell tutorial: \\
|
||||
\verb|http://en.wikibooks.org/wiki/Haskell|
|
||||
\item History of Haskell: \\
|
||||
{\tiny \verb|http://haskell.org/haskellwiki/History_of_Haskell|}
|
||||
\item JHC: \\
|
||||
\verb|http://repetae.net/john/computer/jhc/|
|
||||
\item Pugs: \\
|
||||
\verb|http://www.pugscode.org/|
|
||||
\item Scrap Your Boilerplate: \\
|
||||
\verb|http://www.cs.vu.nl/boilerplate/|
|
||||
\end{itemize}
|
||||
\end{slide}
|
||||
|
||||
\end{document}
|
||||
BIN
fco/doc/kent.eps
BIN
fco/doc/kent.eps
Binary file not shown.
|
|
@ -1,14 +0,0 @@
|
|||
@Article{syb1,
|
||||
author = "Ralf L{\"a}mmel and Simon {Peyton Jones}",
|
||||
title = "Scrap your boilerplate:
|
||||
a practical design pattern for generic programming",
|
||||
journal = "ACM SIG{\-}PLAN Notices",
|
||||
publisher = "ACM Press",
|
||||
volume = "38",
|
||||
number = "3",
|
||||
pages = "26--37",
|
||||
month = mar,
|
||||
year = "2003",
|
||||
note = "Proceedings of the ACM SIGPLAN Workshop
|
||||
on Types in Language Design and Implementation (TLDI~2003)"
|
||||
}
|
||||
|
|
@ -1,209 +0,0 @@
|
|||
\documentclass[a4paper,12pt]{article}
|
||||
|
||||
\usepackage{times}
|
||||
\usepackage{a4wide}
|
||||
\usepackage{xspace}
|
||||
|
||||
\def\occam{{\sffamily occam}\xspace}
|
||||
\def\occampi{{\sffamily occam-\Pisymbol{psy}{112}}\xspace}
|
||||
|
||||
\begin{document}
|
||||
|
||||
\title{Compiling \occam using Haskell}
|
||||
\author{Adam Sampson}
|
||||
\maketitle
|
||||
|
||||
\section{Introduction}
|
||||
|
||||
This is the ongoing story of FCO, a functional compiler for \occam.
|
||||
FCO is a spike solution (albeit a fairly elaborate one): the aim is to
|
||||
implement just enough of a compiler in Haskell to tell us whether
|
||||
using it for a proper compiler would be a sensible idea.
|
||||
|
||||
The result is that my goal is fairly modest: FCO translates an \occam 2.1
|
||||
subset into ANSI C, using CIF for concurrency facilities. It should
|
||||
support enough of the \occam language to do commstime and q7-ats1.
|
||||
|
||||
By design, FCO is a whole-program compiler: it does not support separate
|
||||
compilation of libraries. The downside is that you need to have the
|
||||
AST for the entire program, including the standard library, available at
|
||||
code-generation time; the major upside for now is that it's much easier
|
||||
to write. I believe that the whole-program strategy may be worth
|
||||
pursuing in a production compiler, since it would also allow
|
||||
whole-program optimisations and specialisations; it need not cause
|
||||
horrendous performance problems, since libraries can still be parsed and
|
||||
usage-checked ahead of time.
|
||||
|
||||
I'll assume the reader has some knowledge of both \occam and Haskell; if
|
||||
there's anything that's not clear, please let me know. I'll also assume
|
||||
the reader has access to the source of FCO while reading this document.
|
||||
|
||||
I would throroughly recommend the Haskell history paper (cite) -- it
|
||||
explains many of the design decisions behind Haskell, and it's an
|
||||
excellent overview of the features available in the language.
|
||||
|
||||
\section{Why Haskell?}
|
||||
|
||||
Why should we consider Haskell as an option for an implementation
|
||||
language? Like Scheme, it's a popular, mature, well-documented
|
||||
functional language, it's used heavily by people who're into programming
|
||||
language research, and it's been used to implement a number of solid
|
||||
compilers for other languages. The result is that there are a number of
|
||||
useful libraries that we can take advantage of.
|
||||
|
||||
There's lots of Haskell experience in the department already. It's the
|
||||
only language other than Java that our undergrads are guaranteed to have
|
||||
experience with, which might be useful for student projects.
|
||||
|
||||
Haskell also has some similarities with \occam: it has an
|
||||
indentation-based syntax, it makes a point of distinguishing between
|
||||
side-effecting and functional code, it emphasises compile-time safety
|
||||
checks, and it has excellent support for lightweight concurrency. \occam
|
||||
may therefore be of interest to some Haskell programmers.
|
||||
|
||||
\section{Existing work}
|
||||
|
||||
42 -- \occam to ETC, Scheme
|
||||
|
||||
JHC -- Haskell to C, Haskell
|
||||
|
||||
Pugs -- Perl 6 to various, Haskell
|
||||
|
||||
GHC -- probably not!
|
||||
|
||||
Mincaml -- ML subset to assembler, ML
|
||||
|
||||
\section{Technologies}
|
||||
|
||||
\subsection{Monads}
|
||||
|
||||
Failure support for free.
|
||||
|
||||
\subsection{SYB Generics}
|
||||
|
||||
\cite{syb1}
|
||||
|
||||
\label{gen-par-prob} Using generics with parametric types confuses the
|
||||
hell out of the typechecker; you can work around this by giving explicit
|
||||
instances of the types you want to use, but it's not very nice.
|
||||
(This is a downside of using a statically-typed language; code that's
|
||||
obviously correct sometimes needs very non-obvious type declarations, or
|
||||
can't be statically typed at all.)
|
||||
|
||||
There's also Strafunski. (Which differs how?)
|
||||
|
||||
And HSXML. Actually looks more useful -- but would require using DrIFT
|
||||
to generate instances of the classes.
|
||||
http://article.gmane.org/gmane.comp.lang.haskell.general/13589
|
||||
|
||||
\subsection{Parsec}
|
||||
|
||||
Parsec is a combinator-based parsing library, which means that you're
|
||||
essentially writing productions that look like BNF with variable
|
||||
bindings, and the library takes care of matching and backtracking as
|
||||
appropriate. Parsec's dead easy to use.
|
||||
|
||||
The parsing operations are actually operations in the \verb|Parser t|
|
||||
monad.
|
||||
|
||||
\section{Parsing}
|
||||
|
||||
The parser is based on the grammar from the \occam 2.1 manual, with a
|
||||
number of alterations:
|
||||
|
||||
\begin{itemize}
|
||||
|
||||
\item I took a leaf out of Haskell's book for handling the
|
||||
indentation-based syntax: a preprocessor analyses the indentation and
|
||||
adds explicit markers for "indent", "outdent" and "end of significant
|
||||
line" that the parser can match later. The preprocessor's a bit limited
|
||||
at the moment; it doesn't handle continuation lines or inline
|
||||
\verb|VALOF|.
|
||||
|
||||
\item The original compiler assumes you're keeping track of what's in
|
||||
scope while you're parsing, which we don't want to do. This makes some
|
||||
things ambiguous, and some productions in the grammar turn out to be
|
||||
identical if you don't know what type things are (for example, you can't
|
||||
tell the difference between channels, ports and timers at parse time, so
|
||||
the FCO grammar handles them all with a single set of productions).
|
||||
|
||||
(I think it'd be possible to simulate the behaviour of the original
|
||||
compiler by using the GenParser monad rather than Parser, since that
|
||||
lets you keep state. I'm pretty sure we wouldn't want to track scope
|
||||
this way, but it might turn out not to be too painful to handle
|
||||
indentation directly in the parser.)
|
||||
|
||||
\item Left-recursive productions (those that parse subscripts) don't
|
||||
work; I split each into two productions, one which parses everything
|
||||
that isn't left-recursive in the original grammar, and one which parses
|
||||
the first followed by one or more subscripts.
|
||||
|
||||
\item The original grammar would parse \verb|x[y]| as a conversion of
|
||||
the array literal \verb|[y]| to type \verb|x|, which isn't legal \occam.
|
||||
I split the \verb|operand| production into a version that didn't include
|
||||
\verb|table| and a version that did, so \verb|conversion| can now
|
||||
explicitly match an operand that isn't an array literal.
|
||||
|
||||
\item Similarly, you can't tell at parse time whether in \verb|c ! a; b|
|
||||
or \verb|x[a]| whether \verb|a| is a variable or a tag -- I'll have to
|
||||
fix this up in a later pass.
|
||||
|
||||
\item I rewrote the production for lists of formal arguments, since the
|
||||
original one's specified as lists of lists of arguments which might be
|
||||
typed, and that doesn't work correctly in Parsec when written in the
|
||||
obvious way. (It should be possible to express it more elegantly with a
|
||||
bit more work.)
|
||||
|
||||
\end{itemize}
|
||||
|
||||
The parser was the first bit of FCO I wrote, and partly as a result my
|
||||
Haskell coding style in the parser is especially poor; the Pugs parser,
|
||||
also using Parsec, is a much better example. (But theirs doesn't parse
|
||||
\occam, obviously.)
|
||||
|
||||
\section{Data structures}
|
||||
|
||||
I've experimented with two different ways of encoding the abstract
|
||||
syntax tree in FCO.
|
||||
|
||||
\subsection{Parse tree}
|
||||
|
||||
\subsection{AST}
|
||||
|
||||
My first version of the AST types included a parametric
|
||||
\verb|Structured t| type used to represent things that could include
|
||||
replicators and specifications, such as \verb|IF| and \verb|ALT|
|
||||
processes; I couldn't combine generic operations over these with others,
|
||||
though (see \ref{gen-par-prob}).
|
||||
|
||||
Some things are simplified in the AST when compared with the grammar:
|
||||
channels are just variables, for example.
|
||||
|
||||
Need to pass metadata through to the AST.
|
||||
|
||||
\section{Generic strategies}
|
||||
|
||||
Need to walk over the tree, tracking state.
|
||||
|
||||
Unique naming comes out nicer in Haskell than in Scheme, since I can
|
||||
just use monads and generic transformations, and don't need to write out
|
||||
all the productions again just to add an extra argument.
|
||||
|
||||
Generics appear to work better in GHC 6.6 than GHC 6.4, since some
|
||||
restrictions on the types of mutually recursive functions have been
|
||||
lifted. (Check this against release notes.)
|
||||
|
||||
\section{C generation}
|
||||
|
||||
\section{Future work}
|
||||
|
||||
The obvious bit of future work is writing the full compiler that this
|
||||
was a prototype of.
|
||||
|
||||
Turns out I quite like Haskell -- and there are tools provided with GHC
|
||||
to parse Haskell. If we wrote a Haskell concurrency library (CSP-style),
|
||||
we should investigate writing an \occam-style usage checker for it.
|
||||
|
||||
\bibliographystyle{unsrt}
|
||||
\bibliography{the}
|
||||
\end{document}
|
||||
|
|
@ -1,70 +0,0 @@
|
|||
-- Demonstrate how to do unique naming.
|
||||
|
||||
import Control.Monad.State
|
||||
import Data.Generics
|
||||
import Data.List
|
||||
|
||||
--
|
||||
|
||||
data Name = Name String
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
|
||||
data Direction = Input Name | Output Name
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
|
||||
data Process = Declare Name Process | Use Direction | Seq [Process]
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
|
||||
--
|
||||
|
||||
type UniqueState = (Int, [(String, String)])
|
||||
type UniqueM t = State UniqueState t
|
||||
|
||||
uniquelyName :: Process -> Process
|
||||
uniquelyName p = evalState (doAny p) (0, [])
|
||||
|
||||
doAny :: Data t => t -> UniqueM t
|
||||
doAny = doGeneric `extM` doName `extM` doProcess
|
||||
|
||||
doGeneric :: Data t => t -> UniqueM t
|
||||
doGeneric = gmapM doAny
|
||||
|
||||
doProcess :: Process -> UniqueM Process
|
||||
doProcess p = case p of
|
||||
Declare (Name n) _ -> do
|
||||
(count, vars) <- get
|
||||
put (count + 1, (n, n ++ "." ++ show count) : vars)
|
||||
p' <- doGeneric p
|
||||
(count', _) <- get
|
||||
put (count', vars)
|
||||
return p'
|
||||
otherwise -> doGeneric p
|
||||
|
||||
doName :: Name -> UniqueM Name
|
||||
doName (Name s) = do
|
||||
(count, vars) <- get
|
||||
let s' = case lookup s vars of
|
||||
Just n -> n
|
||||
Nothing -> error $ "Name " ++ s ++ " not declared before use"
|
||||
return $ Name s'
|
||||
|
||||
--
|
||||
|
||||
demo :: Process -> IO ()
|
||||
demo p = do
|
||||
putStrLn $ show p
|
||||
let p' = uniquelyName p
|
||||
putStrLn $ show p'
|
||||
putStrLn ""
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
demo $ Declare (Name "foo") (Use (Input (Name "foo")))
|
||||
demo $ Declare (Name "a") (Seq [Use (Input (Name "a")),
|
||||
Use (Output (Name "a"))])
|
||||
demo $ Declare (Name "a") (Declare (Name "b") (Seq [Use (Input (Name "a")),
|
||||
Use (Input (Name "b")),
|
||||
Declare (Name "b") (Seq [Use (Input (Name "a")),
|
||||
Use (Input (Name "b"))])]))
|
||||
|
||||
|
||||
|
|
@ -1,430 +0,0 @@
|
|||
;; soccam2.1 syntax definition -- based on occam2.1 syntax
|
||||
|
||||
;; Sample translation:
|
||||
;;
|
||||
;; PROC graphics.plex ([num.sprites]CHAN OF SPRITE in, [num.sprites]CHAN OF BOOL in.req, CHAN OF GRAPHICS.COMMAND out, CHAN OF BOOL req)
|
||||
;; [num.sprites][max.graphic]BYTE lump:
|
||||
;; [num.sprites]INT lump.len, x, y, col:
|
||||
;; WHILE TRUE
|
||||
;; SEQ
|
||||
;; BOOL b:
|
||||
;; req ? b
|
||||
;; PAR i = 0 FOR num.sprites
|
||||
;; SEQ
|
||||
;; in.req[i] ! TRUE
|
||||
;; in[i] ? lump.len[i]::lump[i] ; x[i] ; y[i] ; col[i]
|
||||
;; SEQ i = 0 FOR num.sprites
|
||||
;; out ! sprite ; lump.len[i]::lump[i] ; x[i] ; y[i] ; col[i]
|
||||
;; out ! flip
|
||||
;; :
|
||||
;;
|
||||
;; becomes:
|
||||
;;
|
||||
;; (proc graphics.plex (((array num.sprites (chan-of sprite)) in)
|
||||
;; ((array num.sprites (chan-of bool)) in.req)
|
||||
;; ((chan-of graphics.command) out)
|
||||
;; ((chan-of bool) req))
|
||||
;; (: ((array num.sprites (array max.graphic byte)) lump)
|
||||
;; (: ((array num.sprites int) lump.len x y col)
|
||||
;; (while true
|
||||
;; (seq
|
||||
;; (: (bool b) (? req b))
|
||||
;; (par (for i 0 num.sprites)
|
||||
;; (seq
|
||||
;; (! (sub in.req i) true)
|
||||
;; (? (sub in i) ((:: (sub lump.len i) (sub lump i)) (sub x i) (sub y i) (sub col i)))))
|
||||
;; (seq (for i 0 num.sprites)
|
||||
;; (! out (sprite (:: (sub lump.len i) (sub lump i)) (sub x i) (sub y i) (sub col i))))
|
||||
;; (! out flip))))))
|
||||
|
||||
;; deprecate non-specifier forms in this
|
||||
<abbreviation> :=
|
||||
(is <name> <variable>)
|
||||
(is <specifier> <name> <variable>)
|
||||
(val-is <name> <expression>)
|
||||
(val-is <specifier> <name> <expression>)
|
||||
(is <name> <channel>)
|
||||
(is <specifier> <name> <channel>)
|
||||
(is <name> (<channel>+)) ;; is this really only 1d?
|
||||
(is <specifier> <name> (<channel>+))
|
||||
(is <name> <timer>)
|
||||
(is <specifier> <name> <timer>)
|
||||
(is <name> <port>)
|
||||
(is <specifier> <name> <port>)
|
||||
|
||||
<actual> :=
|
||||
<variable>
|
||||
<channel>
|
||||
<timer>
|
||||
<port>
|
||||
<expression>
|
||||
|
||||
<allocation> :=
|
||||
(place-at <name> <expression>)
|
||||
|
||||
<alternation> :=
|
||||
(alt <alternative>+)
|
||||
(alt <replicator> <alternative>)
|
||||
(pri-alt <alternative>+)
|
||||
(pri-alt <replicator> <alternative>)
|
||||
|
||||
<alternative> :=
|
||||
<guarded.alternative>
|
||||
<alternation>
|
||||
(?case <channel> <variant>+)
|
||||
(cond <boolean> (?case <channel> <variant>+))
|
||||
(: <specification> <alternative>)
|
||||
|
||||
<assignment> :=
|
||||
(:= <variable-list> <expression-list>)
|
||||
|
||||
<base> :=
|
||||
<expression>
|
||||
|
||||
<boolean> :=
|
||||
<expression>
|
||||
|
||||
<byte> :=
|
||||
'<character>'
|
||||
|
||||
<case.expression> :=
|
||||
<expression>
|
||||
|
||||
<case.input> :=
|
||||
(?case <channel> <variant>+)
|
||||
|
||||
;; unsure about "sub" -- the subscript forms could be generalised
|
||||
<channel> :=
|
||||
<name>
|
||||
(sub <channel> <expression>)
|
||||
(sub-from-for <channel> <base> <count>)
|
||||
(sub-from <channel> <base>)
|
||||
(sub-for <channel> <count>)
|
||||
|
||||
<channel.type> :=
|
||||
(chan-of <protocol>)
|
||||
(array <expression> <channel.type>)
|
||||
|
||||
;; occam2.1 syntax doesn't define <character>, which can include * escapes
|
||||
|
||||
<choice> :=
|
||||
<guarded.choice>
|
||||
<conditional>
|
||||
(: <specification> <choice>)
|
||||
|
||||
<conditional> :=
|
||||
(if <choice>+)
|
||||
(if <replicator> <choice>)
|
||||
|
||||
<conversion> :=
|
||||
(conv <data.type> <operand>)
|
||||
(round <data.type> <operand>)
|
||||
(trunc <data.type> <operand>)
|
||||
|
||||
<count> :=
|
||||
<expression>
|
||||
|
||||
<data.type> :=
|
||||
bool
|
||||
byte
|
||||
int
|
||||
int16
|
||||
int32
|
||||
int64
|
||||
real32
|
||||
real64
|
||||
<name>
|
||||
(array <expression> <data.type>)
|
||||
(array <data.type) ;; not in occam2.1 syntax?
|
||||
|
||||
<declaration> :=
|
||||
(<data.type> <name>+)
|
||||
(<channel.type> <name>+)
|
||||
(<timer.type> <name>+)
|
||||
(<port.type> <name>+)
|
||||
|
||||
;; deprecate reshapes?
|
||||
<definition> :=
|
||||
(data-type <name> <data.type>)
|
||||
(data-type <name> <structured.type>)
|
||||
(protocol <name> <simple.protocol>)
|
||||
(protocol <name> <sequential.protocol>)
|
||||
(protocol <name> (<tagged-protocol>+))
|
||||
(proc <name> (<formal>*) <process>)
|
||||
(function (<data.type>+) <function-header> <value.process>)
|
||||
(function-is (<data.type>+) <function-header> <expression.list>)
|
||||
(retypes <specifier> <name> <variable>)
|
||||
(val-retypes <specifier> <name> <expression>)
|
||||
(retypes <specifier> <name> <channel>)
|
||||
(retypes <specifier> <name> <port>)
|
||||
(reshapes <specifier> <name> <variable>)
|
||||
(val-reshapes <specifier> <name> <expression>)
|
||||
(reshapes <specifier> <name> <channel>)
|
||||
(reshapes <specifier> <name> <port>)
|
||||
|
||||
<delayed.input> :=
|
||||
(?after <timer> <expression>)
|
||||
|
||||
<dyadic.operator> :=
|
||||
+
|
||||
-
|
||||
*
|
||||
/
|
||||
mod ;; was \
|
||||
rem
|
||||
plus
|
||||
minus
|
||||
times
|
||||
bitand ;; also /\
|
||||
bitor ;; also \/
|
||||
bitxor ;; was ><
|
||||
and
|
||||
or
|
||||
=
|
||||
<> ;; probably want != or something
|
||||
<
|
||||
>
|
||||
>=
|
||||
<=
|
||||
after
|
||||
|
||||
<exponent> :=
|
||||
+<digits>
|
||||
-<digits>
|
||||
|
||||
<expression> :=
|
||||
<operand>
|
||||
(<monadic.operator> <operand>)
|
||||
(<dyadic.operator> <operand> <operand>)
|
||||
(mostpos <data.type>)
|
||||
(mostneg <data.type>)
|
||||
(size <data.type>)
|
||||
<conversion>
|
||||
|
||||
;; This is an oddity in the syntax, since it has to allow for multi-valued results from functions.
|
||||
<expression.list> :=
|
||||
(<expression>+)
|
||||
(call <name> <expression>*) ;; eww, but necessary?
|
||||
value-process>
|
||||
|
||||
<field.name> :=
|
||||
<name>
|
||||
|
||||
<formal> :=
|
||||
(<specifier> <name>+)
|
||||
(val <specifier> <name>+)
|
||||
|
||||
;; Yuck -- this bit of the syntax really doesn't work nicely for soccam.
|
||||
<function.header> :=
|
||||
<name> (<formal>*)
|
||||
|
||||
<guard> :=
|
||||
<input>
|
||||
(cond <boolean> <input>)
|
||||
(cond <boolean> skip)
|
||||
|
||||
<guarded.alternative> :=
|
||||
(<guard> <process>)
|
||||
|
||||
<guarded.choice> :=
|
||||
(<bool-exp> <process>)
|
||||
|
||||
<input> :=
|
||||
(? <channel> <input.item>+)
|
||||
(?case <channel> <tagged.list>)
|
||||
<timer.input>
|
||||
<delayed.input>
|
||||
(? <port> <variable>)
|
||||
|
||||
<input.item> :=
|
||||
<variable>
|
||||
(:: <variable> <variable>)
|
||||
|
||||
<integer> :=
|
||||
<digits>
|
||||
#<hex.digits>
|
||||
|
||||
<literal> :=
|
||||
<integer>
|
||||
<byte>
|
||||
<real>
|
||||
(<data.type> <integer>)
|
||||
(<data.type> <byte>)
|
||||
(<data.type> <real>)
|
||||
true
|
||||
false
|
||||
|
||||
<loop> :=
|
||||
(while <boolean> <process>)
|
||||
|
||||
<monadic.operator> :=
|
||||
-
|
||||
bitnot ;; also ~
|
||||
not
|
||||
size
|
||||
|
||||
<operand> :=
|
||||
<variable>
|
||||
<literal>
|
||||
<table>
|
||||
<expression> ;; rather than (expression)
|
||||
<value.process>
|
||||
(call <name> <expression>*) ;; eww, as above
|
||||
(sub <operand> <expression>) ;; nothing explicit for field names? I guess they're treated as arrays
|
||||
(bytesin <operand>)
|
||||
(bytesin <data.type>)
|
||||
(offsetof <name> <field.name>)
|
||||
|
||||
<option> :=
|
||||
((<case.expression>+) <process>)
|
||||
(else <process>)
|
||||
(: <specification> <option>)
|
||||
|
||||
<output> :=
|
||||
(! <channel> <output.item>+)
|
||||
(!case <channel> (<tag> <output.item>*))
|
||||
(! <port> <expression>)
|
||||
|
||||
<output.item> :=
|
||||
<expression>
|
||||
(:: <expression> <expression>)
|
||||
|
||||
<parallel> :=
|
||||
(par <process>+)
|
||||
(par <replicator> <process>)
|
||||
(pri-par <process>+)
|
||||
(pri-par <replicator> <process>)
|
||||
<placedpar>
|
||||
|
||||
<placedpar> :=
|
||||
(placed-par <placedpar>+)
|
||||
(placed-par <replicator> <placedpar>)
|
||||
(processor <expression> <process>)
|
||||
|
||||
<port> :=
|
||||
<name>
|
||||
(sub <port> <expression>)
|
||||
(sub-from-for <port> <base> <count>)
|
||||
(sub-from <port> <base>)
|
||||
(sub-for <port> <count>)
|
||||
|
||||
<port.type> :=
|
||||
(port-of <data.type>)
|
||||
(array <expression> <port.type>)
|
||||
|
||||
<proc.instance> :=
|
||||
(<name> <actual>*)
|
||||
|
||||
<process> :=
|
||||
<assignment>
|
||||
<input>
|
||||
<output>
|
||||
skip
|
||||
stop
|
||||
<sequence>
|
||||
<conditional>
|
||||
<selection>
|
||||
<loop>
|
||||
<parallel>
|
||||
<alternation>
|
||||
<case.input>
|
||||
<proc.instance>
|
||||
(: <specification> <process>)
|
||||
(: <allocation> <process>)
|
||||
|
||||
<protocol> :=
|
||||
<name>
|
||||
<simple.protocol>
|
||||
|
||||
<real> :=
|
||||
<digits>.<digits>
|
||||
<digits>.<digits>e<exponent>
|
||||
|
||||
<replicator> :=
|
||||
(for <name> <base> <count>)
|
||||
|
||||
<selection> :=
|
||||
(case <selector> <option>+)
|
||||
|
||||
<selector> :=
|
||||
<expression>
|
||||
|
||||
<sequence> :=
|
||||
(seq <process>+)
|
||||
(seq <replicator> <process>)
|
||||
|
||||
<sequential.protocol> :=
|
||||
(<simple.protocol>+)
|
||||
|
||||
<simple.protocol> :=
|
||||
<data.type>
|
||||
any ;; deprecate
|
||||
(:: <data.type> <data.type>)
|
||||
|
||||
<specification> :=
|
||||
<declaration>
|
||||
<abbreviation>
|
||||
<definition>
|
||||
|
||||
<specifier> :=
|
||||
<data.type>
|
||||
<channel.type>
|
||||
<timer.type>
|
||||
<port.type>
|
||||
(array <specifier>)
|
||||
(array <expression> <specifier>)
|
||||
|
||||
<structured.type> :=
|
||||
(record (<data.type> <field.name>+)+)
|
||||
(packed-record (<data.type> <field.name>+)+)
|
||||
|
||||
<table> :=
|
||||
<string>
|
||||
(<string> <name>) ;; this is literals of named types, e.g. "foo"(FILENAME)
|
||||
(<expression>+)
|
||||
(sub <table> <expression>)
|
||||
(sub-from-for <table> <base> <count>)
|
||||
(sub-from <table> <base>)
|
||||
(sub-for <table> <count>)
|
||||
|
||||
<tag> :=
|
||||
<name>
|
||||
|
||||
<tagged.list> :=
|
||||
(<tag> <input.item>*)
|
||||
|
||||
<tagged.protocol> :=
|
||||
(<tag> <sequential.protocol>*)
|
||||
|
||||
<timer.input> :=
|
||||
(? <timer> <variable>)
|
||||
|
||||
<timer> :=
|
||||
<name>
|
||||
(sub <timer> <expression>)
|
||||
(sub-from-for <timer> <base> <count>)
|
||||
(sub-from <timer> <base>)
|
||||
(sub-for <timer> <count>)
|
||||
|
||||
<timer.type> :=
|
||||
timer
|
||||
(array <expression> <timer.type>) ;; nope, I don't know why you'd want an array of timers either
|
||||
|
||||
<value.process> :=
|
||||
(valof <process> <expression.list>)
|
||||
(: <specification> <value.process>)
|
||||
|
||||
<variable> :=
|
||||
<name>
|
||||
(sub <variable> <expression>)
|
||||
(sub-from-for <variable> <base> <count>)
|
||||
(sub-from <variable> <base>)
|
||||
(sub-for <variable> <count>)
|
||||
|
||||
<variable.list> :=
|
||||
(<variable>+)
|
||||
|
||||
<variant> :=
|
||||
(<tagged.list> <process>)
|
||||
(: <specification> <variant>)
|
||||
|
||||
|
|
@ -1,13 +0,0 @@
|
|||
PROC main ()
|
||||
INT a, b:
|
||||
VAL INT c IS 42:
|
||||
VAL INT d IS a + b:
|
||||
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
|
||||
:
|
||||
|
|
@ -1,221 +0,0 @@
|
|||
-- This file aims to exercise every bit of occam2.1 syntax.
|
||||
-- As such, it should compile (with loads of warnings), but not actually do anything when run.
|
||||
|
||||
-- Still to check: line continuation rules.
|
||||
|
||||
PROC test.syntax ()
|
||||
INT x, y, a, b:
|
||||
[10]INT xs:
|
||||
BOOL la, lb, lc:
|
||||
BYTE bb:
|
||||
REAL32 f:
|
||||
CHAN OF INT c:
|
||||
[10]CHAN OF INT cs:
|
||||
[10][10]CHAN OF INT css:
|
||||
PROTOCOL P
|
||||
CASE
|
||||
foo
|
||||
bar
|
||||
:
|
||||
CHAN OF P cc:
|
||||
DATA TYPE R
|
||||
RECORD
|
||||
INT a:
|
||||
INT b:
|
||||
:
|
||||
|
||||
SEQ
|
||||
-- abbreviation
|
||||
xx IS x:
|
||||
SKIP
|
||||
INT xx IS x:
|
||||
SKIP
|
||||
VAL xx IS x:
|
||||
SKIP
|
||||
VAL INT xx IS x:
|
||||
SKIP
|
||||
|
||||
-- allocation
|
||||
[2]INT q:
|
||||
-- Doesn't work in KRoC.
|
||||
PLACE q AT 12345:
|
||||
SKIP
|
||||
|
||||
-- alternation
|
||||
ALT
|
||||
c ? x
|
||||
SKIP
|
||||
TRUE & SKIP
|
||||
SKIP
|
||||
ALT i = 0 FOR 10
|
||||
cs[i] ? xs[i]
|
||||
SKIP
|
||||
PRI ALT
|
||||
c ? x
|
||||
SKIP
|
||||
TRUE & SKIP
|
||||
SKIP
|
||||
PRI ALT i = 0 FOR 10
|
||||
cs[i] ? xs[i]
|
||||
SKIP
|
||||
xx IS x:
|
||||
ALT
|
||||
TRUE & SKIP
|
||||
SKIP
|
||||
|
||||
-- alternative
|
||||
ALT
|
||||
TRUE & cc ? CASE
|
||||
foo
|
||||
SKIP
|
||||
bar
|
||||
STOP
|
||||
cc ? CASE
|
||||
foo
|
||||
SKIP
|
||||
bar
|
||||
STOP
|
||||
|
||||
-- assignment
|
||||
x := y
|
||||
x, y := a, b
|
||||
|
||||
-- byte
|
||||
bb := 'x'
|
||||
|
||||
-- caseInput
|
||||
cc ? CASE
|
||||
foo
|
||||
SKIP
|
||||
bar
|
||||
STOP
|
||||
|
||||
-- channel
|
||||
css[4][2] ? x
|
||||
cs[4] ? x
|
||||
c ? x
|
||||
[cs FROM 1 FOR 2][1] ? x
|
||||
[cs FROM 0][4] ? x
|
||||
[cs FOR 2][1] ? x
|
||||
|
||||
-- channelType
|
||||
CHAN OF INT q:
|
||||
[10]CHAN OF INT qs:
|
||||
SKIP
|
||||
|
||||
-- character
|
||||
bb := 'x'
|
||||
bb := '*c'
|
||||
bb := '*#FF'
|
||||
|
||||
-- occamChoice
|
||||
INT x:
|
||||
IF
|
||||
TRUE
|
||||
SKIP
|
||||
|
||||
-- conditional
|
||||
IF
|
||||
TRUE
|
||||
SKIP
|
||||
FALSE
|
||||
STOP
|
||||
IF i = 0 FOR 42
|
||||
xs[i] = 11
|
||||
STOP
|
||||
|
||||
-- conversion
|
||||
x := INT bb
|
||||
f := REAL32 ROUND x
|
||||
f := REAL32 TRUNC x
|
||||
|
||||
-- dataType
|
||||
BOOL a:
|
||||
BYTE a:
|
||||
INT a:
|
||||
INT16 a:
|
||||
INT32 a:
|
||||
INT64 a:
|
||||
REAL32 a:
|
||||
REAL64 a:
|
||||
[10]INT a:
|
||||
R a:
|
||||
SKIP
|
||||
|
||||
-- declaration
|
||||
INT a:
|
||||
INT a, b, c:
|
||||
SKIP
|
||||
|
||||
-- definition
|
||||
DATA TYPE T1 IS INT:
|
||||
DATA TYPE T2
|
||||
RECORD
|
||||
INT x:
|
||||
:
|
||||
PROTOCOL P1 IS INT; INT:
|
||||
PROTOCOL P2 IS ANY:
|
||||
PROTOCOL P3
|
||||
CASE
|
||||
foo
|
||||
:
|
||||
PROC p1 (INT x)
|
||||
SKIP
|
||||
:
|
||||
INT FUNCTION f1 (VAL INT x) IS x:
|
||||
INT FUNCTION f2 (VAL INT x)
|
||||
VALOF
|
||||
SKIP
|
||||
RESULT x
|
||||
:
|
||||
INT xx RETYPES x:
|
||||
INT xx RESHAPES x:
|
||||
VAL INT xx RETYPES x:
|
||||
VAL INT xx RESHAPES x:
|
||||
SKIP
|
||||
|
||||
-- dyadicOperator
|
||||
x := a + b
|
||||
x := a - b
|
||||
x := a * b
|
||||
x := a / b
|
||||
x := a \ b
|
||||
x := a REM b
|
||||
x := a PLUS b
|
||||
x := a MINUS b
|
||||
x := a TIMES b
|
||||
x := lb /\ lc
|
||||
x := lb \/ lc
|
||||
x := lb >< lc
|
||||
x := lb BITAND lc
|
||||
x := lb BITOR lc
|
||||
la := lb AND lc
|
||||
la := lb OR lc
|
||||
la := a = b
|
||||
la := a <> b
|
||||
la := a < b
|
||||
la := a > b
|
||||
la := a <= b
|
||||
la := a >= b
|
||||
la := a AFTER b
|
||||
|
||||
-- occamExponent
|
||||
f := 1.2345e+67
|
||||
f := 1.2345e-67
|
||||
|
||||
-- expression
|
||||
x := -a
|
||||
x := MOSTPOS INT
|
||||
x := MOSTNEG INT
|
||||
x := SIZE INT
|
||||
x := a + b
|
||||
|
||||
-- expressionList
|
||||
INT, INT FUNCTION twofunc (VAL INT x, y) IS x, y:
|
||||
a, b := twofunc (x, y)
|
||||
a, b := x, y
|
||||
|
||||
-- real
|
||||
f := 1.2345e+67
|
||||
f := 1.2345
|
||||
:
|
||||
|
|
@ -1,25 +0,0 @@
|
|||
PROTOCOL MYPROTO
|
||||
CASE
|
||||
tag1
|
||||
tag2
|
||||
:
|
||||
PROC n ()
|
||||
CHAN OF INT c1:
|
||||
CHAN OF MYPROTO c2:
|
||||
BOOL b:
|
||||
ALT
|
||||
c1 ? x
|
||||
STOP
|
||||
b & c1 ? x
|
||||
STOP
|
||||
c2 ? CASE
|
||||
tag1
|
||||
STOP
|
||||
tag2
|
||||
STOP
|
||||
b & c2 ? CASE
|
||||
tag1
|
||||
STOP
|
||||
tag2
|
||||
STOP
|
||||
:
|
||||
|
|
@ -1,43 +0,0 @@
|
|||
-- Some ambiguities in the occam2.1 syntax as specified.
|
||||
|
||||
PROC x ()
|
||||
SEQ
|
||||
[10]INT a:
|
||||
INT b, r:
|
||||
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:
|
||||
SEQ
|
||||
-- Permitted by the syntax but not by the language: you can't do a data
|
||||
-- type conversion on an array (perhaps specifically to resolve this
|
||||
-- ambiguity!).
|
||||
r := a[b]
|
||||
|
||||
PROTOCOL P
|
||||
CASE
|
||||
a; INT
|
||||
:
|
||||
CHAN OF P c:
|
||||
INT b:
|
||||
SEQ
|
||||
c ! a; b
|
||||
|
||||
PROTOCOL P IS INT; INT:
|
||||
CHAN OF P c:
|
||||
INT a, b:
|
||||
SEQ
|
||||
c ! a; b
|
||||
:
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -1,89 +0,0 @@
|
|||
-- commstime, from the KRoC distribution
|
||||
|
||||
#USE "course.lib"
|
||||
|
||||
--{{{ PROC seq.delta (CHAN INT in?, out.0!, out.1!)
|
||||
PROC seq.delta (CHAN INT in?, out.0!, out.1!)
|
||||
WHILE TRUE
|
||||
INT n:
|
||||
SEQ
|
||||
in ? n
|
||||
out.0 ! n
|
||||
out.1 ! n
|
||||
:
|
||||
--}}}
|
||||
|
||||
--{{{ PROC consume (VAL INT n.loops, CHAN INT in?, CHAN BYTE out!)
|
||||
PROC consume (VAL INT n.loops, CHAN INT in?, CHAN BYTE out!)
|
||||
TIMER tim:
|
||||
INT t0, t1:
|
||||
INT value:
|
||||
SEQ
|
||||
--{{{ warm-up loop
|
||||
VAL INT warm.up IS 16:
|
||||
SEQ i = 0 FOR warm.up
|
||||
in ? value
|
||||
--}}}
|
||||
WHILE TRUE
|
||||
SEQ
|
||||
tim ? t0
|
||||
--{{{ bench-mark loop
|
||||
SEQ i = 0 FOR n.loops
|
||||
in ? value
|
||||
--}}}
|
||||
tim ? t1
|
||||
--{{{ report
|
||||
VAL INT microsecs IS t1 MINUS t0:
|
||||
VAL INT64 nanosecs IS 1000 * (INT64 microsecs):
|
||||
SEQ
|
||||
out.string ("Last value received = ", 0, out!)
|
||||
out.int (value, 0, out!)
|
||||
out.string ("*c*n", 0, out!)
|
||||
out.string ("Time = ", 0, out!)
|
||||
out.int (microsecs, 0, out!)
|
||||
out.string (" microsecs*c*n", 0, out!)
|
||||
out.string ("Time per loop = ", 0, out!)
|
||||
out.int (INT (nanosecs/(INT64 n.loops)), 0, out!)
|
||||
out.string (" nanosecs*c*n", 0, out!)
|
||||
out.string ("Context switch = ", 0, out!)
|
||||
out.int (INT ((nanosecs/(INT64 n.loops))/4), 0, out!)
|
||||
out.string (" nanosecs*c*n*n", 0, out!)
|
||||
--}}}
|
||||
:
|
||||
--}}}
|
||||
|
||||
--{{{ PROC comms.time (CHAN BYTE keyboard?, screen!, error!)
|
||||
PROC comms.time (CHAN BYTE keyboard?, screen!, error!)
|
||||
|
||||
BOOL use.seq.delta:
|
||||
|
||||
SEQ
|
||||
|
||||
--{{{ announce
|
||||
SEQ
|
||||
out.string ("*c*nCommstime in occam ...*c*n*n", 0, screen!)
|
||||
out.string ("Using the SEQ-output version of the delta process*c*n", 0, screen!)
|
||||
out.string ("yields a more accurate measure of context-switch time*c*n*n", 0, screen!)
|
||||
out.string ("Using the PAR-output version carries an extra overhead*c*n", 0, screen!)
|
||||
out.string ("of one process startup/shutdown per Commstime loop*c*n*n", 0, screen!)
|
||||
out.string ("By comparing **loop** times between the SEQ and PAR versions,*c*n", 0, screen!)
|
||||
out.string ("the process startup/shutdown overhead may be deduced*c*n*n", 0, screen!)
|
||||
--}}}
|
||||
|
||||
ask.bool ("Sequential delta? ", use.seq.delta, keyboard?, screen!)
|
||||
out.string ("*nCommstime starting ...*c*n*n", 0, screen!)
|
||||
|
||||
CHAN INT a, b, c, d:
|
||||
PAR
|
||||
prefix (0, b?, a!)
|
||||
IF
|
||||
use.seq.delta
|
||||
seq.delta (a?, c!, d!) -- the one defined above
|
||||
TRUE
|
||||
delta (a?, c!, d!) -- the one that does a parallel output
|
||||
succ (c?, b!)
|
||||
consume (1000000, d?, screen!)
|
||||
|
||||
:
|
||||
--}}}
|
||||
|
||||
|
|
@ -1,21 +0,0 @@
|
|||
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)
|
||||
:
|
||||
|
|
@ -1,20 +0,0 @@
|
|||
-- test 1
|
||||
|
||||
-- this here is a comment
|
||||
|
||||
PROC graphics.plex ([num.sprites]CHAN OF SPRITE in, [num.sprites]CHAN OF BOOL in.req, CHAN OF GRAPHICS.COMMAND out, CHAN OF BOOL req)
|
||||
[num.sprites][max.graphic]BYTE lump:
|
||||
[num.sprites]INT lump.len, x, y, col:
|
||||
WHILE TRUE
|
||||
SEQ
|
||||
BOOL b: -- I never much liked that variable
|
||||
req ? b
|
||||
PAR i = 0 FOR num.sprites
|
||||
SEQ
|
||||
in.req[i] ! TRUE
|
||||
in[i] ? lump.len[i]::lump[i] ; x[i] ; y[i] ; col[i]
|
||||
SEQ i = 0 FOR num.sprites
|
||||
out ! sprite ; lump.len[i]::lump[i] ; x[i] ; y[i] ; col[i]
|
||||
out ! flip
|
||||
:
|
||||
|
||||
|
|
@ -1,6 +0,0 @@
|
|||
PROC test.simple (CHAN OF BYTE in, out, err)
|
||||
SEQ
|
||||
out ! 'h'
|
||||
out ! 'i'
|
||||
out ! '*n'
|
||||
:
|
||||
|
|
@ -1,9 +0,0 @@
|
|||
PROC other (CHAN OF INT c)
|
||||
SKIP
|
||||
:
|
||||
|
||||
PROC foo ()
|
||||
[10]CHAN OF INT xs:
|
||||
PAR i = 0 FOR SIZE xs
|
||||
other (xs[i])
|
||||
:
|
||||
|
|
@ -1,11 +0,0 @@
|
|||
PROC test.syntax ()
|
||||
[1000][1000]CHAN OF INT css:
|
||||
[1000]CHAN OF INT cs:
|
||||
SEQ
|
||||
-- channel
|
||||
css[111][222] ? x
|
||||
cs[333] ? x
|
||||
[cs FROM 444 FOR 11][555] ? x
|
||||
[cs FROM 666][77] ? x
|
||||
[cs FOR 888][99] ? x
|
||||
:
|
||||
|
|
@ -1,5 +0,0 @@
|
|||
PROC main ()
|
||||
SEQ
|
||||
SKIP
|
||||
STOP
|
||||
:
|
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue
Block a user