From 996f64702ab0692d461a6936303f6dd1289d4397 Mon Sep 17 00:00:00 2001 From: Adam Sampson Date: Wed, 18 Oct 2006 14:36:31 +0000 Subject: [PATCH] Unique naming working nicely --- fco/AST.hs | 8 +++-- fco/ASTPasses.hs | 61 ++++++++++++++++++++++++++++------ fco/PTToAST.hs | 2 +- fco/doc/writeup.tex | 11 ++++-- fco/testcases/abbreviation.occ | 13 ++++++++ 5 files changed, 78 insertions(+), 17 deletions(-) create mode 100644 fco/testcases/abbreviation.occ diff --git a/fco/AST.hs b/fco/AST.hs index 0a0f070..1a6e630 100644 --- a/fco/AST.hs +++ b/fco/AST.hs @@ -150,6 +150,8 @@ data InputMode = | InputAfter Expression deriving (Show, Eq, Typeable, Data) +type Formals = [(Type, Name)] + type Specification = (Name, SpecType) data SpecType = Place Expression @@ -160,8 +162,8 @@ data SpecType = | DataTypeRecord Bool [(Type, Tag)] | ProtocolIs [Type] | ProtocolCase [(Tag, [Type])] - | Proc [(Type, Name)] Process - | Function [Type] [(Type, Name)] ValueProcess + | Proc Formals Process + | Function [Type] Formals ValueProcess | Retypes Type Variable | Reshapes Type Variable | ValRetypes Type Variable @@ -183,7 +185,7 @@ data Process = | Stop | Main | Seq [Process] - | ReplicatedSeq Replicator Process + | SeqRep Replicator Process | If Structured | Case Expression Structured | While Expression Process diff --git a/fco/ASTPasses.hs b/fco/ASTPasses.hs index 4efdbd2..714887b 100644 --- a/fco/ASTPasses.hs +++ b/fco/ASTPasses.hs @@ -42,30 +42,71 @@ uniqueNamesPass p = evalState (doAny p) (0, []) doGeneric :: Data t => t -> UniqueM t doGeneric = gmapM doAny --- this is wrong for "v IS v:" -- name shouldn't come into scope until after the spec - withSpec :: Data t => A.Specification -> t -> UniqueM t - withSpec (A.Name n, _) p = do - (_, vars) <- get + withNames :: Data t => [A.Name] -> t -> UniqueM ([A.Name], t) + withNames ns b = do (count, vars) <- get - put (count + 1, (n, n ++ "." ++ show count) : vars) - p' <- doGeneric p + let names = [s | A.Name 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 p' + + return (map A.Name 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 fs pp -> do (fs', pp') <- withFormals fs pp + return $ A.Proc fs' pp' + A.Function rt fs pp -> do (fs', pp') <- withFormals fs pp + return $ A.Function 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 n f1 f2) b = do + (n', b') <- withName n b + f1' <- doAny f1 + f2' <- doAny f2 + return $ (A.For n' f1' f2', b') doProcess :: A.Process -> UniqueM A.Process doProcess p = case p of - A.ProcSpec s _ -> withSpec s p + A.ProcSpec s b -> do (s', b') <- withSpec s b + return $ A.ProcSpec s' b' + A.SeqRep r b -> do (r', b') <- withRep r b + return $ A.SeqRep r' b' + A.ParRep pri r b -> do (r', b') <- withRep r b + return $ A.ParRep pri r' b' otherwise -> doGeneric p doValueProcess :: A.ValueProcess -> UniqueM A.ValueProcess doValueProcess p = case p of - A.ValOfSpec s _ -> withSpec s p + A.ValOfSpec s b -> do (s', b') <- withSpec s b + return $ A.ValOfSpec s' b' otherwise -> doGeneric p doStructured :: A.Structured -> UniqueM A.Structured doStructured p = case p of - A.Spec s _ -> withSpec s p + A.Rep r b -> do (r', b') <- withRep r b + return $ A.Rep r' b' + A.Spec s b -> do (s', b') <- withSpec s b + return $ A.Spec s' b' otherwise -> doGeneric p doName :: A.Name -> UniqueM A.Name diff --git a/fco/PTToAST.hs b/fco/PTToAST.hs index e2f1a9f..dbfa152 100644 --- a/fco/PTToAST.hs +++ b/fco/PTToAST.hs @@ -229,7 +229,7 @@ doProcess n@(N.Node _ nt) = case nt of N.Stop -> O.Stop N.MainProcess -> O.Main N.Seq ps -> O.Seq (map doProcess ps) - N.SeqRep r p -> O.ReplicatedSeq (doReplicator r) (doProcess p) + N.SeqRep r p -> O.SeqRep (doReplicator r) (doProcess p) N.If _ -> O.If $ doChoice n N.Case e os -> O.Case (doExpression e) (O.Several $ map doOption os) N.While e p -> O.While (doExpression e) (doProcess p) diff --git a/fco/doc/writeup.tex b/fco/doc/writeup.tex index dac5598..dd5d8ee 100644 --- a/fco/doc/writeup.tex +++ b/fco/doc/writeup.tex @@ -56,9 +56,10 @@ 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, and it has excellent support for lightweight -concurrency. \occam may therefore be of interest to some Haskell -programmers. +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} @@ -186,6 +187,10 @@ 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} diff --git a/fco/testcases/abbreviation.occ b/fco/testcases/abbreviation.occ new file mode 100644 index 0000000..d34cead --- /dev/null +++ b/fco/testcases/abbreviation.occ @@ -0,0 +1,13 @@ +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 +: