diff --git a/fco2/AST.hs b/AST.hs similarity index 100% rename from fco2/AST.hs rename to AST.hs diff --git a/fco2/CompState.hs b/CompState.hs similarity index 100% rename from fco2/CompState.hs rename to CompState.hs diff --git a/fco2/Errors.hs b/Errors.hs similarity index 100% rename from fco2/Errors.hs rename to Errors.hs diff --git a/fco2/EvalConstants.hs b/EvalConstants.hs similarity index 100% rename from fco2/EvalConstants.hs rename to EvalConstants.hs diff --git a/fco2/EvalLiterals.hs b/EvalLiterals.hs similarity index 100% rename from fco2/EvalLiterals.hs rename to EvalLiterals.hs diff --git a/fco2/GenerateC.hs b/GenerateC.hs similarity index 100% rename from fco2/GenerateC.hs rename to GenerateC.hs diff --git a/fco2/Indentation.hs b/Indentation.hs similarity index 100% rename from fco2/Indentation.hs rename to Indentation.hs diff --git a/fco2/Intrinsics.hs b/Intrinsics.hs similarity index 100% rename from fco2/Intrinsics.hs rename to Intrinsics.hs diff --git a/fco2/LANGUAGE b/LANGUAGE similarity index 100% rename from fco2/LANGUAGE rename to LANGUAGE diff --git a/fco2/Main.hs b/Main.hs similarity index 100% rename from fco2/Main.hs rename to Main.hs diff --git a/fco2/Makefile b/Makefile similarity index 100% rename from fco2/Makefile rename to Makefile diff --git a/fco2/Metadata.hs b/Metadata.hs similarity index 100% rename from fco2/Metadata.hs rename to Metadata.hs diff --git a/fco2/Parse.hs b/Parse.hs similarity index 100% rename from fco2/Parse.hs rename to Parse.hs diff --git a/fco2/Pass.hs b/Pass.hs similarity index 100% rename from fco2/Pass.hs rename to Pass.hs diff --git a/fco2/PrettyShow.hs b/PrettyShow.hs similarity index 100% rename from fco2/PrettyShow.hs rename to PrettyShow.hs diff --git a/fco2/SYNTAX b/SYNTAX similarity index 100% rename from fco2/SYNTAX rename to SYNTAX diff --git a/fco2/SimplifyExprs.hs b/SimplifyExprs.hs similarity index 100% rename from fco2/SimplifyExprs.hs rename to SimplifyExprs.hs diff --git a/fco2/SimplifyProcs.hs b/SimplifyProcs.hs similarity index 100% rename from fco2/SimplifyProcs.hs rename to SimplifyProcs.hs diff --git a/fco2/SimplifyTypes.hs b/SimplifyTypes.hs similarity index 100% rename from fco2/SimplifyTypes.hs rename to SimplifyTypes.hs diff --git a/fco2/TLP.hs b/TLP.hs similarity index 100% rename from fco2/TLP.hs rename to TLP.hs diff --git a/fco2/TODO b/TODO similarity index 100% rename from fco2/TODO rename to TODO diff --git a/fco2/Types.hs b/Types.hs similarity index 100% rename from fco2/Types.hs rename to Types.hs diff --git a/fco2/Unnest.hs b/Unnest.hs similarity index 100% rename from fco2/Unnest.hs rename to Unnest.hs diff --git a/fco2/Utils.hs b/Utils.hs similarity index 100% rename from fco2/Utils.hs rename to Utils.hs diff --git a/fco/AST.hs b/fco/AST.hs deleted file mode 100644 index 1ac4365..0000000 --- a/fco/AST.hs +++ /dev/null @@ -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) - diff --git a/fco/ASTPasses.hs b/fco/ASTPasses.hs deleted file mode 100644 index 9d2cc33..0000000 --- a/fco/ASTPasses.hs +++ /dev/null @@ -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] - diff --git a/fco/COutput.hs b/fco/COutput.hs deleted file mode 100644 index 0c54111..0000000 --- a/fco/COutput.hs +++ /dev/null @@ -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 \n" - - doName :: A.Name -> String - doName (A.Name _ n) = n - - doUserType :: A.Type -> String - doUserType (A.UserType (A.Name _ n)) = "usertype_" ++ n - - doType :: A.Type -> String - doType (A.Val t) = "const " ++ (doType t) - doType A.Bool = "int8_t" - doType A.Byte = "uint8_t" - doType A.Int = "int32_t" - doType A.Int16 = "int16_t" - doType A.Int32 = "int32_t" - doType A.Int64 = "int64_t" - doType A.Real32 = "float" - doType A.Real64 = "double" - doType u@(A.UserType _) = doUserType u - doType t = unimp t - - doVariable :: A.Variable -> String - doVariable (A.Variable _ n) = doName n - - doLiteralRepr :: A.LiteralRepr -> String - doLiteralRepr r = case r of - A.IntLiteral _ s -> s - - doLiteral :: A.Literal -> String - doLiteral (A.Literal _ t r) = doLiteralRepr r - - doFunction :: A.ValueProcess -> String - doFunction (A.ValOfSpec _ s p) = doSpecification s ++ doFunction p - doFunction (A.ValOf _ p el) = doProcess p ++ "return " ++ doExpressionListOne el ++ ";\n" - -- FIXME handle multi-value return - - makeDecl :: A.Type -> A.Name -> String - makeDecl t n = doType t ++ " " ++ doName n - - makeFormals :: [(A.Type, A.Name)] -> String - makeFormals fs = "(" ++ concatWith ", " [makeDecl t n | (t, n) <- fs] ++ ")" - - doSpecification :: A.Specification -> String - doSpecification s@(n, st) = case st of - A.Declaration _ t -> makeDecl t n ++ ";\n" - A.Proc _ fs p -> "void " ++ doName n ++ " " ++ makeFormals fs ++ " {\n" ++ doProcess p ++ "}\n" - A.Function _ [r] fs vp -> doType r ++ " " ++ doName n ++ " " ++ makeFormals fs ++ " {\n" ++ doFunction vp ++ "}\n" - _ -> unimp s - - doProcSpec :: A.Process -> String - doProcSpec p = doP [] p - where - doP :: [A.Specification] -> A.Process -> String - doP ss (A.ProcSpec _ s p) = doP (ss ++ [s]) p - doP ss p = "{\n" ++ concat (map doSpecification ss) ++ doProcess p ++ "}\n" - - doActuals :: [A.Expression] -> String - doActuals es = "(" ++ concatWith ", " (map doExpression es) ++ ")" - - doFunctionCall :: A.Name -> [A.Expression] -> String - doFunctionCall n as = (doName n) ++ " " ++ doActuals as - - doMonadic :: A.MonadicOp -> A.Expression -> String - doMonadic o a = case o of - A.MonadicSubtr -> "-" ++ doExpression a - - doDyadic :: A.DyadicOp -> A.Expression -> A.Expression -> String - doDyadic o a b = bracketed $ case o of - -- FIXME Ops ought to be runtime-checked using inline functions - A.Add -> doExpression a ++ " + " ++ doExpression b - A.Subtr -> doExpression a ++ " - " ++ doExpression b - A.Mul -> doExpression a ++ " * " ++ doExpression b - A.Div -> doExpression a ++ " / " ++ doExpression b - - doExpression :: A.Expression -> String - doExpression e = case e of - A.Monadic _ o a -> doMonadic o a - A.Dyadic _ o a b -> doDyadic o a b - A.ExprVariable _ v -> doVariable v - A.ExprLiteral _ l -> doLiteral l - - doExpressionListOne :: A.ExpressionList -> String - doExpressionListOne e = case e of - A.FunctionCallList _ n as -> doFunctionCall n as - A.ExpressionList _ [e] -> doExpression e - - doAssign :: A.Process -> String - doAssign a = case a of - A.Assign _ [v] el -> (doVariable v) ++ " = " ++ (doExpressionListOne el) ++ ";\n" - - doProcess :: A.Process -> String - doProcess s@(A.ProcSpec _ _ _) = doProcSpec s - doProcess a@(A.Assign _ _ _) = doAssign a - doProcess (A.Skip _) = "/* SKIP */;\n" - doProcess (A.Stop _) = "SetErr ();\n" - doProcess (A.Main _) = "/* MAIN-PROCESS */\n"; - doProcess (A.Seq _ ps) = concatWith "" (map doProcess ps) - doProcess (A.ProcCall _ n as) = doName n ++ " " ++ doActuals as ++ ";\n" - doProcess n = unimp n - diff --git a/fco/Main.hs b/fco/Main.hs deleted file mode 100644 index b96eb16..0000000 --- a/fco/Main.hs +++ /dev/null @@ -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" - diff --git a/fco/Makefile b/fco/Makefile deleted file mode 100644 index d803f87..0000000 --- a/fco/Makefile +++ /dev/null @@ -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 - diff --git a/fco/Metadata.hs b/fco/Metadata.hs deleted file mode 100644 index fde8249..0000000 --- a/fco/Metadata.hs +++ /dev/null @@ -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 - diff --git a/fco/PT.hs b/fco/PT.hs deleted file mode 100644 index a10aaa7..0000000 --- a/fco/PT.hs +++ /dev/null @@ -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) - diff --git a/fco/PTPasses.hs b/fco/PTPasses.hs deleted file mode 100644 index 8d765c5..0000000 --- a/fco/PTPasses.hs +++ /dev/null @@ -1,8 +0,0 @@ --- Passes across the parse tree - -module PTPasses (ptPasses) where - -import qualified PT as P - -ptPasses = [] - diff --git a/fco/PTToAST.hs b/fco/PTToAST.hs deleted file mode 100644 index c125b9c..0000000 --- a/fco/PTToAST.hs +++ /dev/null @@ -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 - diff --git a/fco/Parse.hs b/fco/Parse.hs deleted file mode 100644 index 00ee5fe..0000000 --- a/fco/Parse.hs +++ /dev/null @@ -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 - diff --git a/fco/Pass.hs b/fco/Pass.hs deleted file mode 100644 index 142fc40..0000000 --- a/fco/Pass.hs +++ /dev/null @@ -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' - diff --git a/fco/PrettyShow.hs b/fco/PrettyShow.hs deleted file mode 100644 index 1c77ea8..0000000 --- a/fco/PrettyShow.hs +++ /dev/null @@ -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 - diff --git a/fco/SExpression.hs b/fco/SExpression.hs deleted file mode 100644 index 8c6c6be..0000000 --- a/fco/SExpression.hs +++ /dev/null @@ -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] - diff --git a/fco/doc/Makefile b/fco/doc/Makefile deleted file mode 100644 index ec88534..0000000 --- a/fco/doc/Makefile +++ /dev/null @@ -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 $< - diff --git a/fco/doc/PPRadam.sty b/fco/doc/PPRadam.sty deleted file mode 100644 index ae2cb67..0000000 --- a/fco/doc/PPRadam.sty +++ /dev/null @@ -1,85 +0,0 @@ -%============================================================================== -% PPRadam.sty by Adam Sampson -- 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: diff --git a/fco/doc/fco-pres.tex b/fco/doc/fco-pres.tex deleted file mode 100644 index cf69bf8..0000000 --- a/fco/doc/fco-pres.tex +++ /dev/null @@ -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} diff --git a/fco/doc/kent.eps b/fco/doc/kent.eps deleted file mode 100644 index 61cf7ff..0000000 Binary files a/fco/doc/kent.eps and /dev/null differ diff --git a/fco/doc/the.bib b/fco/doc/the.bib deleted file mode 100644 index fd501c0..0000000 --- a/fco/doc/the.bib +++ /dev/null @@ -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)" -} diff --git a/fco/doc/writeup.tex b/fco/doc/writeup.tex deleted file mode 100644 index 524851e..0000000 --- a/fco/doc/writeup.tex +++ /dev/null @@ -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} diff --git a/fco/experiments/UniqueNaming.hs b/fco/experiments/UniqueNaming.hs deleted file mode 100644 index 3d171bd..0000000 --- a/fco/experiments/UniqueNaming.hs +++ /dev/null @@ -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"))])])) - - diff --git a/fco/soccam-2.1-spec.txt b/fco/soccam-2.1-spec.txt deleted file mode 100644 index 390ba6c..0000000 --- a/fco/soccam-2.1-spec.txt +++ /dev/null @@ -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 - := - (is ) - (is ) - (val-is ) - (val-is ) - (is ) - (is ) - (is (+)) ;; is this really only 1d? - (is (+)) - (is ) - (is ) - (is ) - (is ) - - := - - - - - - - := - (place-at ) - - := - (alt +) - (alt ) - (pri-alt +) - (pri-alt ) - - := - - - (?case +) - (cond (?case +)) - (: ) - - := - (:= ) - - := - - - := - - - := - '' - - := - - - := - (?case +) - -;; unsure about "sub" -- the subscript forms could be generalised - := - - (sub ) - (sub-from-for ) - (sub-from ) - (sub-for ) - - := - (chan-of ) - (array ) - -;; occam2.1 syntax doesn't define , which can include * escapes - - := - - - (: ) - - := - (if +) - (if ) - - := - (conv ) - (round ) - (trunc ) - - := - - - := - bool - byte - int - int16 - int32 - int64 - real32 - real64 - - (array ) - (array := - ( +) - ( +) - ( +) - ( +) - -;; deprecate reshapes? - := - (data-type ) - (data-type ) - (protocol ) - (protocol ) - (protocol (+)) - (proc (*) ) - (function (+) ) - (function-is (+) ) - (retypes ) - (val-retypes ) - (retypes ) - (retypes ) - (reshapes ) - (val-reshapes ) - (reshapes ) - (reshapes ) - - := - (?after ) - - := - + - - - * - / - mod ;; was \ - rem - plus - minus - times - bitand ;; also /\ - bitor ;; also \/ - bitxor ;; was >< - and - or - = - <> ;; probably want != or something - < - > - >= - <= - after - - := - + - - - - := - - ( ) - ( ) - (mostpos ) - (mostneg ) - (size ) - - -;; This is an oddity in the syntax, since it has to allow for multi-valued results from functions. - := - (+) - (call *) ;; eww, but necessary? - value-process> - - := - - - := - ( +) - (val +) - -;; Yuck -- this bit of the syntax really doesn't work nicely for soccam. - := - (*) - - := - - (cond ) - (cond skip) - - := - ( ) - - := - ( ) - - := - (? +) - (?case ) - - - (? ) - - := - - (:: ) - - := - - # - - := - - - - ( ) - ( ) - ( ) - true - false - - := - (while ) - - := - - - bitnot ;; also ~ - not - size - - := - - - - ;; rather than (expression) - - (call *) ;; eww, as above - (sub ) ;; nothing explicit for field names? I guess they're treated as arrays - (bytesin ) - (bytesin ) - (offsetof ) - -
:= - - ( ) ;; this is literals of named types, e.g. "foo"(FILENAME) - (+) - (sub
) - (sub-from-for
) - (sub-from
) - (sub-for
) - - := - - - := - ( *) - - := - ( *) - - := - (? ) - - := - - (sub ) - (sub-from-for ) - (sub-from ) - (sub-for ) - - := - timer - (array ) ;; nope, I don't know why you'd want an array of timers either - - := - (valof ) - (: ) - - := - - (sub ) - (sub-from-for ) - (sub-from ) - (sub-for ) - - := - (+) - - := - ( ) - (: ) - diff --git a/fco/testcases/abbreviation.occ b/fco/testcases/abbreviation.occ deleted file mode 100644 index d34cead..0000000 --- a/fco/testcases/abbreviation.occ +++ /dev/null @@ -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 -: diff --git a/fco/testcases/allsyntax.occ b/fco/testcases/allsyntax.occ deleted file mode 100644 index f959982..0000000 --- a/fco/testcases/allsyntax.occ +++ /dev/null @@ -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 -: diff --git a/fco/testcases/altguards.occ b/fco/testcases/altguards.occ deleted file mode 100644 index 9ee273c..0000000 --- a/fco/testcases/altguards.occ +++ /dev/null @@ -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 -: diff --git a/fco/testcases/ambiguous.occ b/fco/testcases/ambiguous.occ deleted file mode 100644 index 54f98a4..0000000 --- a/fco/testcases/ambiguous.occ +++ /dev/null @@ -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 -: - diff --git a/fco/testcases/ats1-q7.occ b/fco/testcases/ats1-q7.occ deleted file mode 100644 index 3816166..0000000 --- a/fco/testcases/ats1-q7.occ +++ /dev/null @@ -1,1364 +0,0 @@ --- CO516 q7: Adam Sampson vim:et:ts=2:foldmethod=marker --- Dining Frogger^WPhilosophers --- This will be a lot more readable in a folding editor (I use VIM). --- Tiny text version. - ---#INCLUDE "consts.inc" ---#USE "course.lib" - ---{{{ Constants - ---{{{ Screen size --- The size of the screen -VAL INT screen.width IS 80: -VAL INT screen.height IS 24: ---}}} - ---{{{ Locations of sprites -VAL INT table.x IS 36: -VAL INT table.y IS 14: -VAL []INT forks.x IS [2, 3, 8, 9, 5]: -VAL []INT forks.y IS [3, 1, 1, 3, 4]: -VAL []INT phils.x IS [-2, -2, 4, 12, 9]: -VAL []INT phils.y IS [4, -1, -3, 1, 5]: -VAL INT security.x IS 60: -VAL INT security.y IS 19: ---}}} - ---{{{ General tweaks --- Set this to false to reduce the gore level a bit. -VAL BOOL adult.mode IS TRUE: --- Set this to false to make the philosophers really, really stupid (as --- opposed to merely very stupid). -VAL BOOL avoid.cars IS TRUE: ---}}} - ---{{{ Philosopher timing controls -VAL INT think.time IS 5000000: -VAL INT eat.time IS 10000000: -VAL INT sleep.time IS 10000000: -VAL INT balloon.hide.time IS 1000000: -VAL INT dead.time IS 3000000: ---}}} - ---{{{ RNG seed --- My birthday, used as an offset to seed the RNG with. -VAL INT adams.birthday IS 250981: ---}}} - ---{{{ Sprite numbers --- The number of sprites -VAL INT num.targets IS 1: -VAL INT base.targets IS 0: -VAL INT num.philosophers IS 5: -VAL INT base.philosophers IS (base.targets + num.targets): -VAL INT num.cars IS 6: -VAL INT base.cars IS (base.philosophers + num.philosophers): -VAL INT num.forks IS num.philosophers: -VAL INT base.forks IS (base.cars + num.cars): -VAL INT num.security IS 1: -VAL INT base.security IS (base.forks + num.forks): -VAL INT num.statics IS 4 + num.philosophers: -VAL INT base.statics IS (base.security + num.security): -VAL INT num.handcuffs IS num.philosophers: -VAL INT base.handcuffs IS (base.statics + num.statics): -VAL INT num.scores IS num.philosophers: -VAL INT base.scores IS (base.handcuffs + num.handcuffs): -VAL INT num.balloons IS 1 + num.philosophers: -VAL INT base.balloons IS (base.scores + num.scores): -VAL INT num.texts IS 2: -VAL INT base.texts IS (base.balloons + num.balloons): -VAL INT num.sprites IS (base.texts + num.texts): ---}}} - ---{{{ Numbers for the coords channels -VAL INT coords.base.forks IS 0: -VAL INT coords.base.balloons IS (coords.base.forks + num.forks): -VAL INT num.coords IS (coords.base.balloons + num.balloons): ---}}} - ---{{{ The bottom-of-screen message -VAL []BYTE bottom.message IS "Adam Sampson *'s Dining Philosophers model, with apologies to the designers of Frogger. -=- Keys: -=- [i] turn off invulnerability for the philosophers -=- Philosopher speed: [q] insane [w] normal [e] snail*'s pace -=- [1-5] tell the security guard to allow 1-5 philosophers in -=- Car speed: [r] 90mph [t] 60mpg [y] 30mph -=- [6-9] select philosopher to control, [hjkl] move selected philosopher, [SPACE] return philosopher to autopilot -=- The numbers by the philosophers show the number of lives left and the number of meals eaten -=- philosophy courtesy of Hobbes*' Leviathan -=- greetings to everyone on UKCIRC :)": ---}}} - ---{{{ Autogenerated brain tables --- This is generated by a seperate program from some input text. --- I've included it inline to make it easier to submit this, but I don't --- suggest trying to read it by hand. - -VAL [20]BYTE brain.words IS "!begin!endJavasucks.": -VAL [3]INT brain.links IS [2,3,1]: -VAL [4]INT brain.wordpos IS [0,6,10,14]: -VAL [4]INT brain.wordlen IS [6,4,4,6]: -VAL [4]INT brain.linkpos IS [0,1,1,2]: -VAL [4]INT brain.linklen IS [1,0,1,1]: ---}}} - ---}}} - ---{{{ Protocols - ---{{{ Graphics - ---{{{ PROTOCOL SPRITE --- The maximum length of a sprite graphic. -VAL INT max.graphic IS 1024: - --- A sprite: graphic to draw (' ' is transparent, '*n' moves to a new line); --- x; y; colour -PROTOCOL SPRITE IS INT::[]BYTE ; INT ; INT ; INT: ---}}} - ---{{{ PROTOCOL GRAPHICS.COMMAND --- A protocol for sending graphics fragments at the screen.buffer -PROTOCOL GRAPHICS.COMMAND - CASE - sprite; INT::[]BYTE ; INT ; INT ; INT - flip - quit -: ---}}} - ---}}} - ---{{{ Collision detection - ---{{{ PROTOCOL COORDS --- A protocol for reporting philosopher coordinates. -PROTOCOL COORDS IS INT ; INT: ---}}} - ---{{{ PROTOCOL COLLISION.TEST --- A protocol for specifying collision tests: x, y, radius. -PROTOCOL COLLISION.TEST IS INT ; INT ; INT: ---}}} - ---}}} - ---{{{ Object control and reporting - ---{{{ PROTOCOL PHILOSOPHER.CONTROL -PROTOCOL PHILOSOPHER.CONTROL - CASE - set.lives ; INT - set.delay ; INT - enable.autopilot ; BOOL - move ; INT ; INT -: ---}}} - ---{{{ PROTOCOL PHILOSOPHER.STATUS --- A protocol for reporting philosopher actions. -PROTOCOL PHILOSOPHER.STATUS - CASE - thinking - queueing - waiting - eating - sleeping -: ---}}} - ---{{{ PROTOCOL FORK.STATUS --- A protocol for reporting fork status. -PROTOCOL FORK.STATUS - CASE - picked.up.left - picked.up.right - put.down -: ---}}} - ---{{{ PROTOCOL SECURITY.CONTROL -PROTOCOL SECURITY.CONTROL - CASE - set.max ; INT -: ---}}} - ---{{{ PROTOCOL SECURITY.STATUS --- A protocol for reporting security guard status. -PROTOCOL SECURITY.STATUS - CASE - queue.size; INT; INT -: ---}}} - ---{{{ PROTOCOL DRIVER.CONTROL -PROTOCOL DRIVER.CONTROL - CASE - set.delay ; INT -: ---}}} - ---{{{ PROTOCOL BALLOON.CONTROL -PROTOCOL BALLOON.CONTROL - CASE - string; [10]BYTE - hide -: ---}}} - ---{{{ PROTOCOL SCORES.REPORT --- Number of lives; score. -PROTOCOL SCORES.REPORT IS INT ; INT: ---}}} - ---{{{ PROTOCOL TARGET.CONTROL -PROTOCOL TARGET.CONTROL - CASE - position; INT; INT - hide -: ---}}} - ---}}} - ---}}} - ---{{{ ANSI terminal utilites - ---{{{ ANSI colours -VAL INT col.red IS 31: -VAL INT col.green IS 32: -VAL INT col.yellow IS 33: -VAL INT col.blue IS 34: -VAL INT col.purple IS 35: -VAL INT col.cyan IS 36: -VAL INT col.white IS 37: ---}}} - ---{{{ PROC set.colour -PROC set.colour (VAL INT colour, CHAN OF BYTE out) - SEQ - out ! ESCAPE - out ! '[' - out.int (colour, 0, out) - out ! 'm' -: ---}}} - ---{{{ PROC hide.cursor -PROC hide.cursor (CHAN OF BYTE out) - SEQ - -- This is an xterm-specific escape sequence. - -- It works in xterm and rxvt, but not in gnome-terminal or aterm, - -- and then only when the window has focus -- but it does make it look - -- much nicer. - out ! ESCAPE - out ! '[' - out ! '?' - out ! '2' - out ! '5' - out ! 'l' -: ---}}} - ---}}} - ---{{{ General utilities - ---{{{ PROC sleep --- Sleep for a given period. -PROC sleep (VAL INT delay) - TIMER tim: - INT t: - SEQ - tim ? t - tim ? AFTER t PLUS delay -: ---}}} - ---}}} - ---{{{ Text generation - ---{{{ PROTOCOL LINE -VAL INT max.text IS 1024: -PROTOCOL LINE IS INT::[]BYTE: ---}}} - ---{{{ PROC philosophy.generator --- This is a Markov-chain text generator. -PROC philosophy.generator (CHAN OF LINE output) - [max.text]BYTE buf: - INT bufpos, seed: - VAL INT num.words IS SIZE brain.wordpos: - SEQ - seed := adams.birthday - WHILE TRUE - INT word, next, len: - SEQ - bufpos := 0 - next, seed := random(brain.linklen[0], seed) - word := brain.links[next] - BOOL full: - SEQ - full := FALSE - WHILE (NOT full) AND (word <> 1) - SEQ - len := brain.wordlen[word] - full := ((bufpos + len) + 1) >= (SIZE buf) - IF - NOT full - SEQ - copy.string ([brain.words FROM brain.wordpos[word] FOR len], [buf FROM bufpos FOR len]) - bufpos := bufpos + len - buf[bufpos] := ' ' - bufpos := bufpos + 1 - next, seed := random(brain.linklen[word], seed) - word := brain.links[brain.linkpos[word] + next] - TRUE - SKIP - make.string (buf, bufpos) - output ! bufpos::buf -: ---}}} - ---{{{ PROC scroll.text --- Scroll text to the screen while it's supplied; pause while it isn't. -VAL INT scroll.buf.size IS 4 * max.text: -PROC scroll.text (VAL INT delay, VAL INT width, CHAN OF LINE in, CHAN OF LINE out) - [scroll.buf.size]BYTE buf: - INT used: - [max.text]BYTE disp: - [max.text]BYTE line: - INT len: - TIMER tim: - INT t: - SEQ - len := -1 - SEQ i = 0 FOR width - buf[i] := '*#00' - make.string (buf, width) - used := width - make.string (disp, 0) - tim ? t - WHILE TRUE - PRI ALT - (len < 0) & in ? len::line - SKIP - tim ? AFTER t PLUS delay - INT w: - SEQ - IF - (len >= 0) AND (((SIZE buf) - used) >= len) - SEQ - make.string (line, len) - copy.string ([line FROM 0 FOR len], [buf FROM used FOR len]) - used := used + len - len := -1 - TRUE - SKIP - IF - used <= 0 - SEQ - make.string (buf, width) - used := width - TRUE - SKIP - IF - used < width - w := used - TRUE - w := width - copy.string ([buf FROM 0 FOR w], [disp FROM 0 FOR w]) - make.string (disp, w) - out ! width::disp - SEQ i = 0 FOR used - 1 - buf[i] := buf[i + 1] - used := used - 1 - tim ? t -: ---}}} - ---{{{ PROC repeat.text --- Used to scroll the same message over and over again. -PROC repeat.text (VAL []BYTE text, CHAN OF LINE out) - WHILE TRUE - out ! (SIZE text)::text -: ---}}} - ---}}} - ---{{{ The (instrumented) secure college - ---{{{ PROC philosopher -PROC philosopher (CHAN OF BOOL left, right, down, up, CHAN OF PHILOSOPHER.STATUS philosophish, CHAN OF BOOL ack, VAL INT init.seed) - INT seed, rand: - BOOL b: - SEQ - seed := init.seed - WHILE TRUE - SEQ - philosophish ! thinking - ack ? b - rand, seed := random(think.time, seed) - sleep (rand) - philosophish ! queueing - ack ? b - down ! TRUE - philosophish ! waiting - ack ? b - PAR - left ! TRUE - right ! TRUE - philosophish ! eating - ack ? b - rand, seed := random(eat.time, seed) - sleep (rand) - PAR - left ! TRUE - right ! TRUE - up ! TRUE - -- It's a hard life being a philosopher. - philosophish ! sleeping - ack ? b - rand, seed := random(sleep.time, seed) - sleep (rand) -: ---}}} - ---{{{ PROC fork -PROC fork (CHAN OF BOOL left, right, CHAN OF FORK.STATUS forkish) - WHILE TRUE - ALT - BOOL any: - left ? any -- philosopher left picks up fork - SEQ - forkish ! picked.up.left - left ? any -- philosopher left puts down fork - forkish ! put.down - BOOL any: - right ? any -- philosopher right picks up fork - SEQ - forkish ! picked.up.right - right ? any -- philosopher right puts down fork - forkish ! put.down -: ---}}} - ---{{{ PROC security -PROC security ([]CHAN OF BOOL down, up, CHAN OF SECURITY.CONTROL control, CHAN OF SECURITY.STATUS securitish) - INT max: - INT n.sat.down: - SEQ - max := 4 - n.sat.down := 0 - WHILE TRUE - SEQ - securitish ! queue.size ; n.sat.down ; max - PRI ALT - control ? CASE - set.max ; max - SKIP - ALT i = 0 FOR 5 - ALT - --{{{ philosopher wanting to sit down - BOOL any: - (n.sat.down < max) & down[i] ? any -- don't allow max at a time - n.sat.down := n.sat.down + 1 - --}}} - --{{{ philosopher wanting to stand up - BOOL any: - up[i] ? any -- always allow this - n.sat.down := n.sat.down - 1 - --}}} -: ---}}} - ---{{{ PROC secure.college -PROC secure.college ([num.philosophers]CHAN OF PHILOSOPHER.STATUS philosophish, [num.philosophers]CHAN OF BOOL philosophish.ack, [num.forks]CHAN OF FORK.STATUS forkish, CHAN OF SECURITY.STATUS securitish, CHAN OF SECURITY.CONTROL security.control) - [5]CHAN OF BOOL left, right, up, down: - PAR - security (down, up, security.control, securitish) - PAR i = 0 FOR num.philosophers - PAR - philosopher (left[i], right[i], down[i], up[i], philosophish[i], philosophish.ack[i], i + adams.birthday) - fork (left[i], right[(i+1)\5], forkish[i]) -: ---}}} - ---}}} - ---{{{ Car control - ---{{{ PROC mindless.driver --- A driver that moves the car at a variable speed. A future enhancement would --- be to make the driving protocol include the Y coordinate as well, so that we --- could make cars swerve and overtake... -PROC mindless.driver (VAL INT initial.delay, VAL INT width, CHAN OF DRIVER.CONTROL control, CHAN OF INT out) - TIMER tim: - INT t, delay: - SEQ - delay := initial.delay - WHILE TRUE - SEQ i = 0 FOR width - SEQ - out ! i - tim ? t - PRI ALT - control ? CASE - set.delay ; delay - SKIP - tim ? AFTER t PLUS delay - SKIP -: ---}}} - ---}}} - ---{{{ Animation - ---{{{ PROC three.digits --- Format a three-digit number into a buffer. -PROC three.digits (VAL INT n, [3]BYTE buf) - IF - n < 0 - [buf FOR 3] := " " - TRUE - SEQ - buf[0] := '0' + (BYTE ((n / 100) \ 10)) - buf[1] := '0' + (BYTE ((n / 10) \ 10)) - buf[2] := '0' + (BYTE (n \ 10)) -: ---}}} - ---{{{ PROC animate.scores -PROC animate.scores (VAL INT x, y, CHAN OF SCORES.REPORT in, CHAN OF SPRITE out) - [7]BYTE msg: - INT lives, score: - SEQ - copy.string (" *n ", msg) - WHILE TRUE - SEQ - out ! (SIZE msg)::msg ; x ; y ; col.white - in ? lives ; score - three.digits (lives, [msg FROM 0 FOR 3]) - three.digits (score, [msg FROM 4 FOR 3]) -: ---}}} - ---{{{ PROC animate.static -PROC animate.static (VAL INT x, y, col, VAL []BYTE item, CHAN OF SPRITE out) - out ! (SIZE item)::item ; x ; y ; col -: ---}}} - ---{{{ PROC animate.car -PROC animate.car (VAL INT x, y, CHAN OF INT in, CHAN OF COORDS coords, CHAN OF SPRITE out) - INT pos: - SEQ - pos := 0 - WHILE TRUE - SEQ - coords ! x + pos ; y - out ! 14::"/###\_*n`O--O-*'" ; x + pos ; y ; col.white - in ? pos -: ---}}} - ---{{{ PROC animate.security -PROC animate.security (VAL INT x, y, CHAN OF SECURITY.STATUS in, CHAN OF BALLOON.CONTROL balloon, CHAN OF SPRITE out) - [11]BYTE sid: - [10]BYTE msg: - SEQ - copy.string (" Q *n-U-*n/ \", sid) - copy.string ("n/n diners", msg) - WHILE TRUE - SEQ - out ! (SIZE sid)::sid ; x ; y ; col.green - in ? CASE - INT queue, max: - queue.size ; queue ; max - SEQ - msg[0] := '0' + (BYTE queue) - msg[2] := '0' + (BYTE max) - balloon ! string ; msg -: ---}}} - ---{{{ PROC animate.philosopher -PROC animate.philosopher (VAL INT num, home.x, home.y, table.x, table.y, CHAN OF PHILOSOPHER.STATUS in, CHAN OF BOOL ack, CHAN OF COORDS coords.report, CHAN OF COLLISION.TEST collision.request, CHAN OF BOOL collision.reply, CHAN OF BALLOON.CONTROL balloon, CHAN OF SCORES.REPORT scores, CHAN OF PHILOSOPHER.CONTROL control, CHAN OF TARGET.CONTROL targeting, CHAN OF BOOL cuffs, CHAN OF SPRITE out) - INT x, y, dest.x, dest.y, lives, score, move.delay: - [11]BYTE phil: - [10]BYTE msg: - BOOL moving, legs, alive, autopilot: - SEQ - move.delay := 100000 - alive := TRUE - -- Philosophers are invunerable to start with. - lives := -1 - score := 0 - moving := FALSE - legs := FALSE - autopilot := TRUE - copy.string (" o *n-#-*n/ \", phil) - -- Slightly tricky, since it needs to match the keys used to select - -- the philosophers. - IF - num < 4 - phil[5] := '6' + (BYTE num) - TRUE - phil[5] := '0' - x, y := home.x, home.y - dest.x, dest.y := x, y - WHILE alive - BOOL collide: - SEQ - coords.report ! x ; y - collision.request ! x ; y ; 0 - collision.reply ? collide - IF - collide - -- Run over the philosopher. - VAL []BYTE splat IS "-=#%%#.*n==%#%#%*n-=#%##*'": - SEQ - copy.string ("Ouch!", msg) - balloon ! string ; msg - IF - adult.mode - SEQ - out ! (SIZE splat)::splat ; x ; y ; col.red - sleep (dead.time) - TRUE - SKIP - IF - lives = 1 - SEQ - -- Out of lives -- game over, dude, game over... - lives := 0 - alive := FALSE - lives > 0 - lives := lives - 1 - TRUE - -- Lives count is negative, so infinite lives mode. - SKIP - TRUE - SKIP - scores ! lives ; score - IF - alive - INT col: - SEQ - IF - autopilot - col := col.red - TRUE - col := col.white - out ! (SIZE phil)::phil ; x ; y ; col - IF - (((dest.x = x) AND (dest.y = y)) AND moving) - SEQ - ack ! TRUE - moving := FALSE - [phil FROM 8 FOR 3] := "/ \" - TRUE - TIMER tim: - INT t: - SEQ - tim ? t - PRI ALT - -- Get control signals. - control ? CASE - set.lives ; lives - SKIP - set.delay ; move.delay - SKIP - enable.autopilot ; autopilot - IF - autopilot - targeting ! hide - TRUE - SKIP - INT dx, dy: - move ; dx ; dy - SEQ - x, y := x + dx, y + dy - IF - x < 0 - x := 0 - x >= (screen.width - 3) - x := (screen.width - 3) - y < 0 - y := 0 - y >= (screen.height - 3) - y := (screen.height - 3) - TRUE - SKIP - -- Get a status update from the model. - in ? CASE - thinking - SEQ - copy.string ("Hmmm...", msg) - balloon ! string ; msg - phil[1] := '/' - ack ! TRUE - queueing - SEQ - copy.string ("I*'m hungry", msg) - balloon ! string ; msg - phil[1] := '!' - cuffs ! TRUE - ack ! TRUE - waiting - SEQ - copy.string ("Need forks", msg) - balloon ! string ; msg - phil[1] := '**' - dest.x, dest.y := table.x, table.y - cuffs ! FALSE - moving := TRUE - eating - SEQ - copy.string ("Delicious!", msg) - balloon ! string ; msg - phil[1] := 'O' - score := score + 1 - ack ! TRUE - sleeping - SEQ - copy.string ("I*'m tired.", msg) - balloon ! string ; msg - phil[1] := 'z' - dest.x, dest.y := home.x, home.y - moving := TRUE - -- Get a timeout. - tim ? AFTER t PLUS move.delay - IF - moving - -- Work out which way to move and do it. - INT dx, dy: - SEQ - IF - dest.x > x - dx := 1 - dest.x < x - dx := -1 - TRUE - dx := 0 - IF - dest.y > y - dy := 1 - dest.y < y - dy := -1 - TRUE - dy := 0 - -- This is a hack to make the philosophers head home in - -- a more sensibly froggy way. - IF - (dy < 0) AND (NOT (dx = 0)) - dy := 0 - TRUE - SKIP - -- Attempt to avoid collisions. Not that this works - -- very well, since the tactic is essentially to - -- stand still if you're about to be hit by a car. - collision.request ! x + dx ; y + dy ; 3 - collision.reply ? collide - IF - (avoid.cars AND collide) - SEQ - copy.string ("Mind out..", msg) - balloon ! string ; msg - autopilot - x, y := x + dx, y + dy - TRUE - -- Not on autopilot, so don't move. - SKIP - -- Animate the philosopher's legs. - IF - legs - [phil FROM 8 FOR 3] := " |\" - TRUE - [phil FROM 8 FOR 3] := "/| " - legs := NOT legs - TRUE - -- Not moving -- animate the philosopher's head. - IF - -- Sleeping. - phil[1] = 'z' - phil[1] := 'Z' - phil[1] = 'Z' - phil[1] := 'z' - -- Thinking (head spinning) - phil[1] = '/' - phil[1] := '-' - phil[1] = '-' - phil[1] := '\' - phil[1] = '\' - phil[1] := '|' - phil[1] = '|' - phil[1] := '/' - -- Eating (head throbbing) - phil[1] = '.' - phil[1] := 'o' - phil[1] = 'o' - phil[1] := 'O' - phil[1] = 'O' - phil[1] := '0' - phil[1] = '0' - phil[1] := '.' - -- Waiting (head "shaking") - phil[1] = '<' - phil[1] := '!' - phil[1] = '!' - phil[1] := '>' - phil[1] = '>' - phil[1] := 'i' - phil[1] = 'i' - phil[1] := '<' - TRUE - SKIP - IF - autopilot - SKIP - TRUE - targeting ! position ; dest.x ; dest.y - TRUE - SKIP -: ---}}} - ---{{{ PROC animate.fork -PROC animate.fork (VAL INT num, table.x, table.y, CHAN OF FORK.STATUS in, CHAN OF INT coords.request, CHAN OF COORDS coords.reply, CHAN OF SPRITE out) - INT x, y: - SEQ - x, y := table.x, table.y - WHILE TRUE - SEQ - out ! 1::"Y" ; x ; y ; col.yellow - in ? CASE - picked.up.left - SEQ - coords.request ! num - coords.reply ? x ; y - y := y + 1 - picked.up.right - SEQ - coords.request ! ((num + 1) \ num.philosophers) - coords.reply ? x ; y - x := x + 2 - y := y + 1 - put.down - x, y := table.x, table.y -: ---}}} - ---{{{ PROC animate.text -PROC animate.text (VAL INT x, y, col, CHAN OF LINE in, CHAN OF SPRITE out) - [max.text]BYTE buf: - INT len: - SEQ - len := 0 - make.string (buf, 0) - WHILE TRUE - SEQ - out ! len::buf ; x ; y ; col - in ? len::buf -: ---}}} - ---{{{ PROC animate.balloon -PROC animate.balloon (VAL INT person, CHAN OF BALLOON.CONTROL in, CHAN OF INT coords.request, CHAN OF COORDS coords.reply, CHAN OF SPRITE out) - INT x, y: - BOOL shown: - [38]BYTE loon: - TIMER tim: - INT t: - SEQ - shown := FALSE - copy.string (",----------.*n| |*n/----------*'", loon) - WHILE TRUE - SEQ - coords.request ! person - coords.reply ? x ; y - x := x + 2 - y := y - 3 - -- This is necessary so that we can still see the "thinking" balloon. - IF - y < 0 - y := 0 - TRUE - SKIP - IF - shown - out ! (SIZE loon)::loon ; x ; y ; col.cyan - TRUE - out ! 0::"" ; x ; y ; col.cyan - tim ? t - PRI ALT - in ? CASE - string ; [loon FROM 14 FOR 10] - SEQ - shown := TRUE - -- Replace any spaces with nulls, so the sign isn't transparent - SEQ i = 14 FOR 10 - IF - loon[i] = ' ' - loon[i] := '*#00' - TRUE - SKIP - hide - shown := FALSE - tim ? AFTER t PLUS balloon.hide.time - -- Pop down the balloon after a while. - shown := FALSE -: ---}}} - ---{{{ PROC animate.target -PROC animate.target (CHAN OF TARGET.CONTROL in, CHAN OF SPRITE out) - INT x, y: - VAL []BYTE target IS ",-.*n| |*n`-*'": - SEQ - x, y := -10, -10 - WHILE TRUE - SEQ - out ! (SIZE target)::target ; x ; y ; col.blue - in ? CASE - position ; x ; y - SKIP - hide - x, y := -10, -10 -: ---}}} - ---{{{ PROC animate.handcuffs -PROC animate.handcuffs (VAL INT x, y, CHAN OF BOOL in, CHAN OF SPRITE out) - BOOL shown: - VAL []BYTE cuffs IS "-o o-": - SEQ - shown := FALSE - WHILE TRUE - SEQ - IF - shown - out ! (SIZE cuffs)::cuffs ; x ; y ; col.green - TRUE - out ! 0::"" ; x ; y ; col.green - in ? shown -: ---}}} - ---}}} - ---{{{ Target control multiplexer - ---{{{ PROC target.plex --- All of the philosophers generate targeting information; this combines them --- into one. -PROC target.plex ([num.philosophers]CHAN OF TARGET.CONTROL in, CHAN OF TARGET.CONTROL out) - WHILE TRUE - ALT i = 0 FOR num.philosophers - in[i] ? CASE - INT x, y: - position ; x ; y - out ! position ; x ; y - hide - out ! hide -: ---}}} - ---}}} - ---{{{ Collision detection - ---{{{ PROC position.tracker --- This process keeps track of the positions of all the philosophers (and the --- security guard), so that other sprites can find out where they need to draw --- themselves. -PROC position.tracker ([num.philosophers]CHAN OF COORDS incoming.reports, [num.coords]CHAN OF INT coords.requests, [num.coords]CHAN OF COORDS coords.replies) - [num.philosophers + 1]INT xs, ys: - SEQ - xs[num.philosophers], ys[num.philosophers] := security.x, security.y - SEQ i = 0 FOR num.philosophers - xs[i], ys[i] := 0, 0 - WHILE TRUE - PRI ALT - ALT i = 0 FOR num.coords - INT phil: - coords.requests[i] ? phil - coords.replies[i] ! xs[phil] ; ys[phil] - ALT i = 0 FOR num.philosophers - incoming.reports[i] ? xs[i] ; ys[i] - SKIP -: ---}}} - ---{{{ PROC collision.detector --- Process to detect when philosophers get run over by cars. -PROC collision.detector ([num.cars]CHAN OF COORDS in, [num.philosophers]CHAN OF COLLISION.TEST requests, [num.philosophers]CHAN OF BOOL replies) - [num.cars]INT x, y: - SEQ - SEQ i = 0 FOR num.cars - x[i], y[i] := 0, 0 - WHILE TRUE - PRI ALT - ALT i = 0 FOR num.philosophers - INT px, py, r: - requests[i] ? px ; py ; r - BOOL rep: - SEQ - rep := FALSE - SEQ j = 0 FOR num.cars - VAL INT cx IS x[j] + 6: - VAL INT cy IS y[j] + 1: - IF - (((cx + r) >= px) AND ((cx - r) <= (px + 2))) AND (((cy + r) >= py) AND ((cy - r) <= (py + 3))) - rep := TRUE - TRUE - SKIP - replies[i] ! rep - ALT i = 0 FOR num.cars - in[i] ? x[i] ; y[i] - SKIP -: ---}}} - ---}}} - ---{{{ Double-buffered screen output code - ---{{{ PROC sprite.mem.cell --- This holds the information for a particular sprite -- the animator writes --- into it, and the screen stuff reads from it. -PROC sprite.mem.cell (CHAN OF SPRITE in, CHAN OF SPRITE out, CHAN OF BOOL req) - [max.graphic]BYTE lump: - INT lump.len, x, y, col: - SEQ - lump.len := 0 - make.string (lump, 0) - x, y := 0, 0 - col := 0 - WHILE TRUE - PRI ALT - BOOL b: - req ? b - out ! lump.len::lump ; x ; y ; col - in ? lump.len::lump ; x ; y ; col - SKIP -: ---}}} - ---{{{ PROC graphics.plex --- This is slightly misnamed, since it's not a conventional occamy multiplexer; --- it makes requests to each of the mem cells in turn. -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 -: ---}}} - ---{{{ PROC update.requester --- Send periodic update requests to the plexer. -PROC update.requester (VAL INT delay, CHAN OF BOOL out) - WHILE TRUE - SEQ - out ! TRUE - sleep (delay) -: ---}}} - ---{{{ PROC clear.buffer -PROC clear.buffer ([screen.height][screen.width]BYTE screen, [screen.height][screen.width]INT colour) - SEQ y = 0 FOR screen.height - SEQ x = 0 FOR screen.width - SEQ - screen[y][x] := ' ' - colour[y][x] := 0 -: ---}}} - ---{{{ PROC screen.buffer --- Optimised double-buffered screen renderer. This is the only bit of code that --- knows how to talk to the terminal. -PROC screen.buffer (CHAN OF GRAPHICS.COMMAND in, CHAN OF BYTE out) - [2][screen.height][screen.width]BYTE screen: - [2][screen.height][screen.width]INT colour: - INT current, prev.x, prev.y, prev.col: - SEQ - hide.cursor (out) - erase.screen (out) - current := 0 - prev.x, prev.y := -1, -1 - prev.col := -1 - clear.buffer (screen[0], colour[0]) - clear.buffer (screen[1], colour[1]) - WHILE TRUE - in ? CASE - [max.graphic]BYTE lump: - INT lumpsize, x, y, col, origx: - sprite ; lumpsize::lump ; x ; y ; col - SEQ - origx := x - SEQ i = 0 FOR lumpsize - IF - lump[i] = '*n' - SEQ - x := origx - y := y + 1 - lump[i] = ' ' - -- Spaces are "transparent" - x := x + 1 - TRUE - SEQ - -- Nulls are non-transparent spaces. - IF - lump[i] = '*#00' - lump[i] := ' ' - TRUE - SKIP - IF - (((x >= 0) AND (x < screen.width)) AND ((y >= 0) AND (y < screen.height))) - SEQ - screen[current][y][x] := lump[i] - colour[current][y][x] := col - TRUE - SKIP - x := x + 1 - flip - SEQ - SEQ y = 0 FOR screen.height - SEQ x = 0 FOR screen.width - IF - NOT ((screen[current][y][x] = screen[1 - current][y][x]) AND (colour[current][y][x] = colour[1 - current][y][x])) - INT col IS colour[current][y][x]: - SEQ - -- Only bother with colour changes and cursor moves - -- if they're really necessary. (Minimises the number - -- of control sequences sent -- since I tested this over - -- a laggy ssh connection, this is well worth the effort.) - IF - col = prev.col - SKIP - TRUE - set.colour (col, out) - IF - (x = (prev.x + 1)) AND (y = prev.y) - SKIP - TRUE - goto.x.y (x + 1, y + 1, out) - out ! screen[current][y][x] - prev.x, prev.y, prev.col := x, y, col - TRUE - SKIP - current := 1 - current - clear.buffer (screen[current], colour[current]) - out ! FLUSH -: ---}}} - ---{{{ PROC sprite.renderer --- Wrapper process around all the above. -PROC sprite.renderer (VAL INT delay, [num.sprites]CHAN OF SPRITE sprites, CHAN OF BYTE out) - [num.sprites]CHAN OF SPRITE memory.sprites: - [num.sprites]CHAN OF BOOL sprite.reqs: - CHAN OF BOOL graphics.tick: - CHAN OF GRAPHICS.COMMAND graphics.feed: - PAR - PAR i = 0 FOR num.sprites - sprite.mem.cell (sprites[i], memory.sprites[i], sprite.reqs[i]) - update.requester (delay, graphics.tick) - graphics.plex (memory.sprites, sprite.reqs, graphics.feed, graphics.tick) - screen.buffer (graphics.feed, out) -: ---}}} - ---}}} - ---{{{ Keyboard control - ---{{{ PROC keyboard.controller -PROC keyboard.controller (CHAN OF BYTE in, [num.philosophers]CHAN OF PHILOSOPHER.CONTROL philosopher.controls, [num.cars]CHAN OF DRIVER.CONTROL driver.controls, CHAN OF SECURITY.CONTROL security.control) - BYTE b: - INT under.control: - SEQ - under.control := -1 - WHILE TRUE - SEQ - in ? b - IF - -- i: give all the philosophers 5 lives. - b = 'i' - SEQ i = 0 FOR num.philosophers - philosopher.controls[i] ! set.lives ; 5 - -- s: speed up all the philosophers a lot. - b = 'q' - SEQ i = 0 FOR num.philosophers - philosopher.controls[i] ! set.delay ; 10000 - -- m: set normal speed for the philosophers. - b = 'w' - SEQ i = 0 FOR num.philosophers - philosopher.controls[i] ! set.delay ; 100000 - -- w: slow down the philosophers a lot. - b = 'e' - SEQ i = 0 FOR num.philosophers - philosopher.controls[i] ! set.delay ; 500000 - -- 0-5: set security max - (b >= '1') AND (b <= '5') - security.control ! set.max ; (INT (b - '0')) - -- f: fast cars - b = 'r' - SEQ i = 0 FOR num.cars - driver.controls[i] ! set.delay ; 10000 - -- g: medium cars - b = 't' - SEQ i = 0 FOR num.cars - driver.controls[i] ! set.delay ; 100000 - -- h: slow cars - b = 'y' - SEQ i = 0 FOR num.cars - driver.controls[i] ! set.delay ; 1000000 - -- abcde: set philosopher to control - ((b >= '6') AND (b <= '9')) OR (b = '0') - SEQ - IF - under.control >= 0 - philosopher.controls[under.control] ! enable.autopilot ; TRUE - TRUE - SKIP - IF - b = '0' - under.control := 4 - TRUE - under.control := (INT (b - '6')) - philosopher.controls[under.control] ! enable.autopilot ; FALSE - -- space: stop controlling philosopher - b = ' ' - IF - under.control >= 0 - SEQ - philosopher.controls[under.control] ! enable.autopilot ; TRUE - under.control := -1 - TRUE - SKIP - -- hjkl: move philosophers - under.control >= 0 - INT dx, dy: - SEQ - IF - b = 'h' - dx, dy := -1, 0 - b = 'j' - dx, dy := 0, 1 - b = 'k' - dx, dy := 0, -1 - b = 'l' - dx, dy := 1, 0 - TRUE - SKIP - philosopher.controls[under.control] ! move ; dx ; dy - TRUE - SKIP -: ---}}} - ---}}} - ---{{{ PROC q7 -PROC q7 (CHAN OF BYTE keyboard, screen, error) - [num.cars]CHAN OF INT drivings: - [num.cars]CHAN OF COORDS car.coords: - [num.philosophers]CHAN OF COLLISION.TEST car.requests: - [num.philosophers]CHAN OF BOOL car.replies: - [num.sprites]CHAN OF SPRITE sprites: - [num.philosophers]CHAN OF COORDS position.reports: - [num.coords]CHAN OF INT position.requests: - [num.coords]CHAN OF COORDS position.replies: - [num.philosophers]CHAN OF PHILOSOPHER.STATUS philosophish: - [num.philosophers]CHAN OF PHILOSOPHER.CONTROL philosopher.controls: - [num.cars]CHAN OF DRIVER.CONTROL driver.controls: - CHAN OF SECURITY.CONTROL security.control: - [num.philosophers]CHAN OF BOOL philosophish.ack: - [num.forks]CHAN OF FORK.STATUS forkish: - [num.philosophers]CHAN OF SCORES.REPORT scores: - CHAN OF SECURITY.STATUS securitish: - CHAN OF BALLOON.CONTROL security.balloon: - CHAN OF LINE bottom.scrolled, bottom.text, random.philosophy, scrolled.philosophy: - [num.philosophers]CHAN OF BALLOON.CONTROL philosopher.balloons: - [num.philosophers]CHAN OF TARGET.CONTROL targeting: - [num.philosophers]CHAN OF BOOL cuffage: - CHAN OF TARGET.CONTROL all.targeting: - PAR - -- I don't use error, but this stops KRoC warning me about it. - error ! FLUSH - - -- The original college itself. - secure.college (philosophish, philosophish.ack, forkish, securitish, security.control) - - -- Process collecting input from the keyboard. - keyboard.controller (keyboard, philosopher.controls, driver.controls, security.control) - - -- The collision detection system. - position.tracker (position.reports, position.requests, position.replies) - collision.detector (car.coords, car.requests, car.replies) - - -- The cars. - PAR i = 0 FOR num.cars - PAR - mindless.driver (10000 * (i + 2), 90, driver.controls[i], drivings[i]) - animate.car (-5, 4 + (2 * (i \ 3)), drivings[i], car.coords[i], sprites[base.cars + i]) - - -- The philosophers. - PAR i = 0 FOR num.philosophers - PAR - animate.philosopher (i, 6 + (16 * i), 1, table.x + phils.x[i], table.y + phils.y[i], philosophish[i], philosophish.ack[i], position.reports[i], car.requests[i], car.replies[i], philosopher.balloons[i], scores[i], philosopher.controls[i], targeting[i], cuffage[i], sprites[base.philosophers + i]) - animate.handcuffs (5 + (16 * i), 2, cuffage[i], sprites[base.handcuffs + i]) - - -- The forks. - PAR i = 0 FOR num.forks - animate.fork (i, table.x + forks.x[i], table.y + forks.y[i], forkish[i], position.requests[coords.base.forks + i], position.replies[coords.base.forks + i], sprites[base.forks + i]) - - -- The security guard. - animate.security (security.x, security.y, securitish, security.balloon, sprites[base.security]) - - -- The furniture. - animate.static (table.x, table.y, col.blue, " /~~~~~~\*n / \*n/ \*n\ /*n \ /*n \______/", sprites[base.statics]) - animate.static (0, 0, col.green, " ,-----. ,-----. ,-----. ,-----. ,-----.*n | | | | | | | | | |*n | | | | | | | | | |*n----*' `---------*' `---------*' `---------*' `---------*' `----", sprites[base.statics + 1]) - - -- The thought balloons. - animate.balloon (num.philosophers, security.balloon, position.requests[coords.base.balloons + num.philosophers], position.replies[coords.base.balloons + num.philosophers], sprites[base.balloons + num.philosophers]) - PAR i = 0 FOR num.philosophers - animate.balloon (i, philosopher.balloons[i], position.requests[coords.base.balloons + i], position.replies[coords.base.balloons + i], sprites[base.balloons + i]) - - -- The philosophers' scores. - PAR i = 0 FOR num.scores - PAR - animate.scores (12 + (16 * i), 1, scores[i], sprites[base.scores + i]) - animate.static (11 + (16 * i), 1, col.green, "L*nS", sprites[base.statics + (4 + i)]) - - -- The credits/instructions text. - repeat.text (bottom.message, bottom.text) - scroll.text (100000, 80, bottom.text, bottom.scrolled) - animate.text (0, 23, col.white, bottom.scrolled, sprites[base.texts]) - - -- The random philosophy text. - animate.static (0, 22, col.yellow, "{", sprites[base.statics + 2]) - animate.static (79, 22, col.yellow, "}", sprites[base.statics + 3]) - philosophy.generator (random.philosophy) - scroll.text (50000, 78, random.philosophy, scrolled.philosophy) - animate.text (1, 22, col.yellow, scrolled.philosophy, sprites[base.texts + 1]) - - -- The navigation target (the blue thing that appears when you're - -- controlling a philosopher). - target.plex (targeting, all.targeting) - animate.target (all.targeting, sprites[base.targets]) - - -- The process that renders all the sprites. - sprite.renderer (90000, sprites, screen) -: ---}}} - diff --git a/fco/testcases/commstime.occ b/fco/testcases/commstime.occ deleted file mode 100644 index 66131d5..0000000 --- a/fco/testcases/commstime.occ +++ /dev/null @@ -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!) - -: ---}}} - diff --git a/fco/testcases/expressions.occ b/fco/testcases/expressions.occ deleted file mode 100644 index 74616f9..0000000 --- a/fco/testcases/expressions.occ +++ /dev/null @@ -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) -: diff --git a/fco/testcases/graphicsplex.occ b/fco/testcases/graphicsplex.occ deleted file mode 100644 index 69d0dfa..0000000 --- a/fco/testcases/graphicsplex.occ +++ /dev/null @@ -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 -: - diff --git a/fco/testcases/hi.occ b/fco/testcases/hi.occ deleted file mode 100644 index 6a040f4..0000000 --- a/fco/testcases/hi.occ +++ /dev/null @@ -1,6 +0,0 @@ -PROC test.simple (CHAN OF BYTE in, out, err) - SEQ - out ! 'h' - out ! 'i' - out ! '*n' -: diff --git a/fco/testcases/reppar.occ b/fco/testcases/reppar.occ deleted file mode 100644 index 57a1c2f..0000000 --- a/fco/testcases/reppar.occ +++ /dev/null @@ -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]) -: diff --git a/fco/testcases/slicing.occ b/fco/testcases/slicing.occ deleted file mode 100644 index 0bd6126..0000000 --- a/fco/testcases/slicing.occ +++ /dev/null @@ -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 -: diff --git a/fco/testcases/trivial.occ b/fco/testcases/trivial.occ deleted file mode 100644 index 122b453..0000000 --- a/fco/testcases/trivial.occ +++ /dev/null @@ -1,5 +0,0 @@ -PROC main () - SEQ - SKIP - STOP -: diff --git a/fco2/kroc-wrapper-c.c b/kroc-wrapper-c.c similarity index 100% rename from fco2/kroc-wrapper-c.c rename to kroc-wrapper-c.c diff --git a/fco2/kroc-wrapper.occ b/kroc-wrapper.occ similarity index 100% rename from fco2/kroc-wrapper.occ rename to kroc-wrapper.occ diff --git a/fco2/testcases/_assert.occ b/testcases/_assert.occ similarity index 100% rename from fco2/testcases/_assert.occ rename to testcases/_assert.occ diff --git a/fco2/testcases/_bad_array_types.occ b/testcases/_bad_array_types.occ similarity index 100% rename from fco2/testcases/_bad_array_types.occ rename to testcases/_bad_array_types.occ diff --git a/fco2/testcases/_bad_assign.occ b/testcases/_bad_assign.occ similarity index 100% rename from fco2/testcases/_bad_assign.occ rename to testcases/_bad_assign.occ diff --git a/fco2/testcases/_bad_assign2.occ b/testcases/_bad_assign2.occ similarity index 100% rename from fco2/testcases/_bad_assign2.occ rename to testcases/_bad_assign2.occ diff --git a/fco2/testcases/_bad_conversion.occ b/testcases/_bad_conversion.occ similarity index 100% rename from fco2/testcases/_bad_conversion.occ rename to testcases/_bad_conversion.occ diff --git a/fco2/testcases/_bad_conversion2.occ b/testcases/_bad_conversion2.occ similarity index 100% rename from fco2/testcases/_bad_conversion2.occ rename to testcases/_bad_conversion2.occ diff --git a/fco2/testcases/_bad_datatype.occ b/testcases/_bad_datatype.occ similarity index 100% rename from fco2/testcases/_bad_datatype.occ rename to testcases/_bad_datatype.occ diff --git a/fco2/testcases/_bad_literal.occ b/testcases/_bad_literal.occ similarity index 100% rename from fco2/testcases/_bad_literal.occ rename to testcases/_bad_literal.occ diff --git a/fco2/testcases/_bad_proto.occ b/testcases/_bad_proto.occ similarity index 100% rename from fco2/testcases/_bad_proto.occ rename to testcases/_bad_proto.occ diff --git a/fco2/testcases/_bad_proto2.occ b/testcases/_bad_proto2.occ similarity index 100% rename from fco2/testcases/_bad_proto2.occ rename to testcases/_bad_proto2.occ diff --git a/fco2/testcases/_bad_retype.occ b/testcases/_bad_retype.occ similarity index 100% rename from fco2/testcases/_bad_retype.occ rename to testcases/_bad_retype.occ diff --git a/fco2/testcases/_bad_retype2.occ b/testcases/_bad_retype2.occ similarity index 100% rename from fco2/testcases/_bad_retype2.occ rename to testcases/_bad_retype2.occ diff --git a/fco2/testcases/_bad_retype3.occ b/testcases/_bad_retype3.occ similarity index 100% rename from fco2/testcases/_bad_retype3.occ rename to testcases/_bad_retype3.occ diff --git a/fco2/testcases/_bad_retype4.occ b/testcases/_bad_retype4.occ similarity index 100% rename from fco2/testcases/_bad_retype4.occ rename to testcases/_bad_retype4.occ diff --git a/fco2/testcases/_bad_retype5.occ b/testcases/_bad_retype5.occ similarity index 100% rename from fco2/testcases/_bad_retype5.occ rename to testcases/_bad_retype5.occ diff --git a/fco2/testcases/_bad_retype6.occ b/testcases/_bad_retype6.occ similarity index 100% rename from fco2/testcases/_bad_retype6.occ rename to testcases/_bad_retype6.occ diff --git a/fco2/testcases/_bad_string_cont.occ b/testcases/_bad_string_cont.occ similarity index 100% rename from fco2/testcases/_bad_string_cont.occ rename to testcases/_bad_string_cont.occ diff --git a/fco2/testcases/_bad_string_cont2.occ b/testcases/_bad_string_cont2.occ similarity index 100% rename from fco2/testcases/_bad_string_cont2.occ rename to testcases/_bad_string_cont2.occ diff --git a/fco2/testcases/_bad_tlp.occ b/testcases/_bad_tlp.occ similarity index 100% rename from fco2/testcases/_bad_tlp.occ rename to testcases/_bad_tlp.occ diff --git a/fco2/testcases/_bad_tlp2.occ b/testcases/_bad_tlp2.occ similarity index 100% rename from fco2/testcases/_bad_tlp2.occ rename to testcases/_bad_tlp2.occ diff --git a/fco2/testcases/_bad_tlp3.occ b/testcases/_bad_tlp3.occ similarity index 100% rename from fco2/testcases/_bad_tlp3.occ rename to testcases/_bad_tlp3.occ diff --git a/fco2/testcases/_call_int.occ b/testcases/_call_int.occ similarity index 100% rename from fco2/testcases/_call_int.occ rename to testcases/_call_int.occ diff --git a/fco2/testcases/_fish.occ b/testcases/_fish.occ similarity index 100% rename from fco2/testcases/_fish.occ rename to testcases/_fish.occ diff --git a/fco2/testcases/_two_skips.occ b/testcases/_two_skips.occ similarity index 100% rename from fco2/testcases/_two_skips.occ rename to testcases/_two_skips.occ diff --git a/fco2/testcases/_unknown_proc.occ b/testcases/_unknown_proc.occ similarity index 100% rename from fco2/testcases/_unknown_proc.occ rename to testcases/_unknown_proc.occ diff --git a/fco2/testcases/abbrev.occ b/testcases/abbrev.occ similarity index 100% rename from fco2/testcases/abbrev.occ rename to testcases/abbrev.occ diff --git a/fco2/testcases/actuals.occ b/testcases/actuals.occ similarity index 100% rename from fco2/testcases/actuals.occ rename to testcases/actuals.occ diff --git a/fco2/testcases/alt.occ b/testcases/alt.occ similarity index 100% rename from fco2/testcases/alt.occ rename to testcases/alt.occ diff --git a/fco2/testcases/args.occ b/testcases/args.occ similarity index 100% rename from fco2/testcases/args.occ rename to testcases/args.occ diff --git a/fco2/testcases/array-arg.occ b/testcases/array-arg.occ similarity index 100% rename from fco2/testcases/array-arg.occ rename to testcases/array-arg.occ diff --git a/fco2/testcases/array-context.occ b/testcases/array-context.occ similarity index 100% rename from fco2/testcases/array-context.occ rename to testcases/array-context.occ diff --git a/fco2/testcases/arraylit.occ b/testcases/arraylit.occ similarity index 100% rename from fco2/testcases/arraylit.occ rename to testcases/arraylit.occ diff --git a/fco2/testcases/arrays.occ b/testcases/arrays.occ similarity index 100% rename from fco2/testcases/arrays.occ rename to testcases/arrays.occ diff --git a/fco2/testcases/assign-array.occ b/testcases/assign-array.occ similarity index 100% rename from fco2/testcases/assign-array.occ rename to testcases/assign-array.occ diff --git a/fco2/testcases/assign.occ b/testcases/assign.occ similarity index 100% rename from fco2/testcases/assign.occ rename to testcases/assign.occ diff --git a/fco2/testcases/ats1-q7.occ b/testcases/ats1-q7.occ similarity index 100% rename from fco2/testcases/ats1-q7.occ rename to testcases/ats1-q7.occ diff --git a/fco2/testcases/booleanop.occ b/testcases/booleanop.occ similarity index 100% rename from fco2/testcases/booleanop.occ rename to testcases/booleanop.occ diff --git a/fco2/testcases/case.occ b/testcases/case.occ similarity index 100% rename from fco2/testcases/case.occ rename to testcases/case.occ diff --git a/fco2/testcases/chan-retypes.occ b/testcases/chan-retypes.occ similarity index 100% rename from fco2/testcases/chan-retypes.occ rename to testcases/chan-retypes.occ diff --git a/fco2/testcases/chanany.occ b/testcases/chanany.occ similarity index 100% rename from fco2/testcases/chanany.occ rename to testcases/chanany.occ diff --git a/fco2/testcases/checkindex.occ b/testcases/checkindex.occ similarity index 100% rename from fco2/testcases/checkindex.occ rename to testcases/checkindex.occ diff --git a/fco2/testcases/checksize.occ b/testcases/checksize.occ similarity index 100% rename from fco2/testcases/checksize.occ rename to testcases/checksize.occ diff --git a/fco2/testcases/commstime-mini.occ b/testcases/commstime-mini.occ similarity index 100% rename from fco2/testcases/commstime-mini.occ rename to testcases/commstime-mini.occ diff --git a/fco2/testcases/const-expr.occ b/testcases/const-expr.occ similarity index 100% rename from fco2/testcases/const-expr.occ rename to testcases/const-expr.occ diff --git a/fco2/testcases/constants.occ b/testcases/constants.occ similarity index 100% rename from fco2/testcases/constants.occ rename to testcases/constants.occ diff --git a/fco2/testcases/conversions.occ b/testcases/conversions.occ similarity index 100% rename from fco2/testcases/conversions.occ rename to testcases/conversions.occ diff --git a/fco2/testcases/course.occ b/testcases/course.occ similarity index 100% rename from fco2/testcases/course.occ rename to testcases/course.occ diff --git a/fco2/testcases/datatype-const.occ b/testcases/datatype-const.occ similarity index 100% rename from fco2/testcases/datatype-const.occ rename to testcases/datatype-const.occ diff --git a/fco2/testcases/datatype-formals.occ b/testcases/datatype-formals.occ similarity index 100% rename from fco2/testcases/datatype-formals.occ rename to testcases/datatype-formals.occ diff --git a/fco2/testcases/datatype.occ b/testcases/datatype.occ similarity index 100% rename from fco2/testcases/datatype.occ rename to testcases/datatype.occ diff --git a/fco2/testcases/datatype2.occ b/testcases/datatype2.occ similarity index 100% rename from fco2/testcases/datatype2.occ rename to testcases/datatype2.occ diff --git a/fco2/testcases/empties.occ b/testcases/empties.occ similarity index 100% rename from fco2/testcases/empties.occ rename to testcases/empties.occ diff --git a/fco2/testcases/expressions.occ b/testcases/expressions.occ similarity index 100% rename from fco2/testcases/expressions.occ rename to testcases/expressions.occ diff --git a/fco2/testcases/hello.occ b/testcases/hello.occ similarity index 100% rename from fco2/testcases/hello.occ rename to testcases/hello.occ diff --git a/fco2/testcases/idfunc.occ b/testcases/idfunc.occ similarity index 100% rename from fco2/testcases/idfunc.occ rename to testcases/idfunc.occ diff --git a/fco2/testcases/incase.occ b/testcases/incase.occ similarity index 100% rename from fco2/testcases/incase.occ rename to testcases/incase.occ diff --git a/fco2/testcases/include.inc b/testcases/include.inc similarity index 100% rename from fco2/testcases/include.inc rename to testcases/include.inc diff --git a/fco2/testcases/include.occ b/testcases/include.occ similarity index 100% rename from fco2/testcases/include.occ rename to testcases/include.occ diff --git a/fco2/testcases/include2.occ b/testcases/include2.occ similarity index 100% rename from fco2/testcases/include2.occ rename to testcases/include2.occ diff --git a/fco2/testcases/includeproc.inc b/testcases/includeproc.inc similarity index 100% rename from fco2/testcases/includeproc.inc rename to testcases/includeproc.inc diff --git a/fco2/testcases/indentation.occ b/testcases/indentation.occ similarity index 100% rename from fco2/testcases/indentation.occ rename to testcases/indentation.occ diff --git a/fco2/testcases/inline.occ b/testcases/inline.occ similarity index 100% rename from fco2/testcases/inline.occ rename to testcases/inline.occ diff --git a/fco2/testcases/inout.occ b/testcases/inout.occ similarity index 100% rename from fco2/testcases/inout.occ rename to testcases/inout.occ diff --git a/fco2/testcases/intrinsics.occ b/testcases/intrinsics.occ similarity index 100% rename from fco2/testcases/intrinsics.occ rename to testcases/intrinsics.occ diff --git a/fco2/testcases/lit-slice.occ b/testcases/lit-slice.occ similarity index 100% rename from fco2/testcases/lit-slice.occ rename to testcases/lit-slice.occ diff --git a/fco2/testcases/literals.occ b/testcases/literals.occ similarity index 100% rename from fco2/testcases/literals.occ rename to testcases/literals.occ diff --git a/fco2/testcases/multidim-literal.occ b/testcases/multidim-literal.occ similarity index 100% rename from fco2/testcases/multidim-literal.occ rename to testcases/multidim-literal.occ diff --git a/fco2/testcases/multidim.occ b/testcases/multidim.occ similarity index 100% rename from fco2/testcases/multidim.occ rename to testcases/multidim.occ diff --git a/fco2/testcases/nesting.occ b/testcases/nesting.occ similarity index 100% rename from fco2/testcases/nesting.occ rename to testcases/nesting.occ diff --git a/fco2/testcases/nonconst-array-literal.occ b/testcases/nonconst-array-literal.occ similarity index 100% rename from fco2/testcases/nonconst-array-literal.occ rename to testcases/nonconst-array-literal.occ diff --git a/fco2/testcases/output-ambiguity.occ b/testcases/output-ambiguity.occ similarity index 100% rename from fco2/testcases/output-ambiguity.occ rename to testcases/output-ambiguity.occ diff --git a/fco2/testcases/par.occ b/testcases/par.occ similarity index 100% rename from fco2/testcases/par.occ rename to testcases/par.occ diff --git a/fco2/testcases/place.occ b/testcases/place.occ similarity index 100% rename from fco2/testcases/place.occ rename to testcases/place.occ diff --git a/fco2/testcases/preproc.occ b/testcases/preproc.occ similarity index 100% rename from fco2/testcases/preproc.occ rename to testcases/preproc.occ diff --git a/fco2/testcases/pri-par.occ b/testcases/pri-par.occ similarity index 100% rename from fco2/testcases/pri-par.occ rename to testcases/pri-par.occ diff --git a/fco2/testcases/protocols.occ b/testcases/protocols.occ similarity index 100% rename from fco2/testcases/protocols.occ rename to testcases/protocols.occ diff --git a/fco2/testcases/ptp-rep.occ b/testcases/ptp-rep.occ similarity index 100% rename from fco2/testcases/ptp-rep.occ rename to testcases/ptp-rep.occ diff --git a/fco2/testcases/pull-consts.occ b/testcases/pull-consts.occ similarity index 100% rename from fco2/testcases/pull-consts.occ rename to testcases/pull-consts.occ diff --git a/fco2/testcases/real-conversions.occ b/testcases/real-conversions.occ similarity index 100% rename from fco2/testcases/real-conversions.occ rename to testcases/real-conversions.occ diff --git a/fco2/testcases/record-literals.occ b/testcases/record-literals.occ similarity index 100% rename from fco2/testcases/record-literals.occ rename to testcases/record-literals.occ diff --git a/fco2/testcases/records.occ b/testcases/records.occ similarity index 100% rename from fco2/testcases/records.occ rename to testcases/records.occ diff --git a/fco2/testcases/rem-op.occ b/testcases/rem-op.occ similarity index 100% rename from fco2/testcases/rem-op.occ rename to testcases/rem-op.occ diff --git a/fco2/testcases/reprep.occ b/testcases/reprep.occ similarity index 100% rename from fco2/testcases/reprep.occ rename to testcases/reprep.occ diff --git a/fco2/testcases/retypes.occ b/testcases/retypes.occ similarity index 100% rename from fco2/testcases/retypes.occ rename to testcases/retypes.occ diff --git a/fco2/testcases/shifts.occ b/testcases/shifts.occ similarity index 100% rename from fco2/testcases/shifts.occ rename to testcases/shifts.occ diff --git a/fco2/testcases/simple-alt.occ b/testcases/simple-alt.occ similarity index 100% rename from fco2/testcases/simple-alt.occ rename to testcases/simple-alt.occ diff --git a/fco2/testcases/skip.occ b/testcases/skip.occ similarity index 100% rename from fco2/testcases/skip.occ rename to testcases/skip.occ diff --git a/fco2/testcases/slices.occ b/testcases/slices.occ similarity index 100% rename from fco2/testcases/slices.occ rename to testcases/slices.occ diff --git a/fco2/testcases/stop.occ b/testcases/stop.occ similarity index 100% rename from fco2/testcases/stop.occ rename to testcases/stop.occ diff --git a/fco2/testcases/stringlit.occ b/testcases/stringlit.occ similarity index 100% rename from fco2/testcases/stringlit.occ rename to testcases/stringlit.occ diff --git a/fco2/testcases/tables.occ b/testcases/tables.occ similarity index 100% rename from fco2/testcases/tables.occ rename to testcases/tables.occ diff --git a/fco2/testcases/tags.occ b/testcases/tags.occ similarity index 100% rename from fco2/testcases/tags.occ rename to testcases/tags.occ diff --git a/fco2/testcases/timer-arg.occ b/testcases/timer-arg.occ similarity index 100% rename from fco2/testcases/timer-arg.occ rename to testcases/timer-arg.occ diff --git a/fco2/testcases/timer-guards.occ b/testcases/timer-guards.occ similarity index 100% rename from fco2/testcases/timer-guards.occ rename to testcases/timer-guards.occ diff --git a/fco2/testcases/tlp.occ b/testcases/tlp.occ similarity index 100% rename from fco2/testcases/tlp.occ rename to testcases/tlp.occ diff --git a/fco2/testcases/val-retypes.occ b/testcases/val-retypes.occ similarity index 100% rename from fco2/testcases/val-retypes.occ rename to testcases/val-retypes.occ diff --git a/fco2/testcases/val-retypes2.occ b/testcases/val-retypes2.occ similarity index 100% rename from fco2/testcases/val-retypes2.occ rename to testcases/val-retypes2.occ diff --git a/fco2/tock_support.h b/tock_support.h similarity index 100% rename from fco2/tock_support.h rename to tock_support.h