From 5f697e828652e3ee15deb2834839428918fbc6c4 Mon Sep 17 00:00:00 2001 From: Adam Sampson Date: Thu, 5 Oct 2006 00:08:57 +0000 Subject: [PATCH] Tag parse tree nodes with source position metadata while parsing --- fco/Main.hs | 2 +- fco/Makefile | 5 +- fco/Metadata.hs | 12 ++ fco/PT.hs | 6 +- fco/PTToAST.hs | 74 ++++----- fco/Parse.hs | 385 +++++++++++++++++++++++---------------------- fco/SExpression.hs | 40 ++--- 7 files changed, 277 insertions(+), 247 deletions(-) create mode 100644 fco/Metadata.hs diff --git a/fco/Main.hs b/fco/Main.hs index b90b899..f0acc02 100644 --- a/fco/Main.hs +++ b/fco/Main.hs @@ -56,7 +56,7 @@ main = do progress $ "}}}" progress $ "{{{ Parser" - let pt = parseSource preprocessed + let pt = parseSource preprocessed fn progress $ pshow pt progress $ "}}}" diff --git a/fco/Makefile b/fco/Makefile index 5cf5d0d..10aadd1 100644 --- a/fco/Makefile +++ b/fco/Makefile @@ -3,14 +3,15 @@ all: fco sources = \ AST.hs \ ASTPasses.hs \ + Main.hs \ + Metadata.hs \ Parse.hs \ Pass.hs \ PrettyShow.hs \ PT.hs \ PTPasses.hs \ SExpression.hs \ - PTToAST.hs \ - Main.hs + PTToAST.hs fco: $(sources) ghc -fglasgow-exts -o fco --make Main diff --git a/fco/Metadata.hs b/fco/Metadata.hs new file mode 100644 index 0000000..0f443cc --- /dev/null +++ b/fco/Metadata.hs @@ -0,0 +1,12 @@ +-- Metadata types + +module Metadata where + +import Data.Generics + +type Meta = [Metadatum] + +data Metadatum = + SourcePos String Int Int + deriving (Show, Eq, Typeable, Data) + diff --git a/fco/PT.hs b/fco/PT.hs index 82fb825..a10aaa7 100644 --- a/fco/PT.hs +++ b/fco/PT.hs @@ -5,8 +5,12 @@ module PT where import Data.Generics +import Metadata -data Node = +data Node = Node Meta NodeType + deriving (Show, Eq, Typeable, Data) + +data NodeType = Decl Node Node | Alt [Node] | AltRep Node Node diff --git a/fco/PTToAST.hs b/fco/PTToAST.hs index b465b02..581893e 100644 --- a/fco/PTToAST.hs +++ b/fco/PTToAST.hs @@ -6,14 +6,14 @@ import qualified PT as N import qualified AST as O doName :: N.Node -> O.Name -doName (N.Name s) = O.Name s +doName (N.Node _ (N.Name s)) = O.Name s doName n = error $ "Can't do name: " ++ (show n) doTag :: N.Node -> O.Tag -doTag (N.Name s) = O.Tag s +doTag (N.Node _ (N.Name s)) = O.Tag s doType :: N.Node -> O.Type -doType n = case n of +doType n@(N.Node _ nt) = case nt of N.Bool -> O.Bool N.Byte -> O.Byte N.Int -> O.Int @@ -33,14 +33,14 @@ doType n = case n of N.Val t -> O.Val (doType t) doMonadicOp :: N.Node -> O.MonadicOp -doMonadicOp n = case n of +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 = case n of +doDyadicOp n@(N.Node _ nt) = case nt of N.Add -> O.Add N.Subtr -> O.Subtr N.Mul -> O.Mul @@ -63,14 +63,14 @@ doDyadicOp n = case n of N.After -> O.After doSubscript :: N.Node -> O.Subscript -doSubscript n = case n of +doSubscript n@(N.Node _ nt) = case nt of N.SubPlain e -> O.Subscript (doExpression e) N.SubFromFor e f -> O.SubFromFor (doExpression e) (doExpression f) N.SubFrom e -> O.SubFrom (doExpression e) N.SubFor f -> O.SubFor (doExpression f) doLiteral :: N.Node -> O.Literal -doLiteral n = case n of +doLiteral n@(N.Node _ nt) = case nt of N.TypedLit t l -> O.Literal (doType t) rep where (O.Literal _ rep) = doLiteral l N.LitReal s -> O.Literal O.Real32 (O.RealLiteral s) N.LitInt s -> O.Literal O.Int (O.IntLiteral s) @@ -81,12 +81,12 @@ doLiteral n = case n of N.Sub s l -> O.SubscriptedLiteral (doSubscript s) (doLiteral l) doVariable :: N.Node -> O.Variable -doVariable n = case n of +doVariable n@(N.Node _ nt) = case nt of N.Name _ -> O.Variable (doName n) N.Sub s v -> O.SubscriptedVariable (doSubscript s) (doVariable v) doExpression :: N.Node -> O.Expression -doExpression n = case n of +doExpression n@(N.Node _ nt) = case nt of N.MonadicOp o a -> O.Monadic (doMonadicOp o) (doExpression a) N.DyadicOp o a b -> O.Dyadic (doDyadicOp o) (doExpression a) (doExpression b) N.MostPos t -> O.MostPos (doType t) @@ -110,67 +110,67 @@ doExpression n = case n of otherwise -> O.ExprVariable (doVariable n) doExpressionList :: N.Node -> O.ExpressionList -doExpressionList n = case n of +doExpressionList n@(N.Node _ nt) = case nt of N.Call f es -> O.FunctionCallList (doName f) (map doExpression es) N.ExpList es -> O.ExpressionList (map doExpression es) doReplicator :: N.Node -> O.Replicator -doReplicator n = case n of +doReplicator n@(N.Node _ nt) = case nt of N.For v f t -> O.For (doName v) (doExpression f) (doExpression t) doFields :: [N.Node] -> [(O.Type, O.Tag)] -doFields ns = concat $ [[(doType t, doTag f) | f <- fs] | (N.Fields t fs) <- ns] +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.Formals t ns) <- fs] +doFormals fs = concat $ [[(doType t, doName n) | n <- ns] | (N.Node _ (N.Formals t ns)) <- fs] doVariant :: N.Node -> O.Structured O.Variant -doVariant n = case n of - N.Variant (N.Tag t is) p -> O.Only $ O.Variant (doTag t) (map doInputItem is) (doProcess p) +doVariant n@(N.Node _ nt) = case nt of + N.Variant (N.Node _ (N.Tag t is)) p -> O.Only $ O.Variant (doTag t) (map doInputItem is) (doProcess p) N.Decl s v -> doSpecifications s O.Spec (doVariant v) doChoice :: N.Node -> O.Structured O.Choice -doChoice n = case n of +doChoice n@(N.Node _ nt) = case nt of N.If cs -> O.Several $ map doChoice cs N.IfRep r c -> O.Rep (doReplicator r) (doChoice c) N.Choice b p -> O.Only $ O.Choice (doExpression b) (doProcess p) N.Decl s c -> doSpecifications s O.Spec (doChoice c) doOption :: N.Node -> O.Structured O.Option -doOption n = case n of +doOption n@(N.Node _ nt) = case nt of N.CaseExps cs p -> O.Only $ O.Option (map doExpression cs) (doProcess p) N.Else p -> O.Only $ O.Else (doProcess p) N.Decl s o -> doSpecifications s O.Spec (doOption o) doInputItem :: N.Node -> O.InputItem -doInputItem n = case n of +doInputItem n@(N.Node _ nt) = case nt of N.Counted c d -> O.InCounted (doVariable c) (doVariable d) otherwise -> O.InVariable (doVariable n) doOutputItem :: N.Node -> O.OutputItem -doOutputItem n = case n of +doOutputItem n@(N.Node _ nt) = case nt of N.Counted c d -> O.OutCounted (doExpression c) (doExpression d) otherwise -> O.OutExpression (doExpression n) doInputMode :: N.Node -> O.InputMode -doInputMode n = case n of +doInputMode n@(N.Node _ nt) = case nt of N.InSimple is -> O.InputSimple (map doInputItem is) N.InCase vs -> O.InputCase (O.Several $ map doVariant vs) - N.InTag (N.Tag t is) -> O.InputCase (O.Only $ O.Variant (doTag t) (map doInputItem is) O.Skip) + N.InTag (N.Node _ (N.Tag t is)) -> O.InputCase (O.Only $ O.Variant (doTag t) (map doInputItem is) O.Skip) N.InAfter e -> O.InputAfter (doExpression e) doSimpleSpec :: N.Node -> O.Specification -doSimpleSpec n = case n of +doSimpleSpec n@(N.Node _ nt) = case nt of N.Is d v -> (doName d, O.Is O.Infer (doVariable v)) N.IsType t d v -> (doName d, O.Is (doType t) (doVariable v)) N.ValIs d e -> (doName d, O.ValIs O.Infer (doExpression e)) N.ValIsType t d e -> (doName d, O.ValIs (doType t) (doExpression e)) N.Place v e -> (doName v, O.Place (doExpression e)) - N.DataType n (N.Record fs) -> (doName n, O.DataTypeRecord False (doFields fs)) - N.DataType n (N.PackedRecord fs) -> (doName n, O.DataTypeRecord True (doFields fs)) + N.DataType n (N.Node _ (N.Record fs)) -> (doName n, O.DataTypeRecord False (doFields fs)) + N.DataType n (N.Node _ (N.PackedRecord fs)) -> (doName n, O.DataTypeRecord True (doFields fs)) N.DataType n t -> (doName n, O.DataTypeIs (doType t)) N.Protocol n is -> (doName n, O.ProtocolIs (map doType is)) - N.TaggedProtocol n ts -> (doName n, O.ProtocolCase [(doTag tn, map doType tts) | (N.Tag tn tts) <- ts]) + N.TaggedProtocol n ts -> (doName n, O.ProtocolCase [(doTag tn, map doType tts) | (N.Node _ (N.Tag tn tts)) <- ts]) N.Proc n fs p -> (doName n, O.Proc (doFormals fs) (doProcess p)) N.Func n rs fs vp -> (doName n, O.Function (map doType rs) (doFormals fs) (doValueProcess vp)) N.FuncIs n rs fs el -> (doName n, O.Function (map doType rs) (doFormals fs) (O.ValOf O.Skip (doExpressionList el))) @@ -180,24 +180,24 @@ doSimpleSpec n = case n of N.ValReshapes t d s -> (doName d, O.ValReshapes (doType t) (doVariable s)) doSpecifications :: N.Node -> (O.Specification -> a -> a) -> a -> a -doSpecifications n comb arg = case n of +doSpecifications n@(N.Node m nt) comb arg = case nt of N.Vars t [] -> arg - N.Vars t (v:vs) -> comb (doName v, O.Declaration (doType t)) (doSpecifications (N.Vars t vs) comb arg) + N.Vars t (v:vs) -> comb (doName v, O.Declaration (doType t)) (doSpecifications (N.Node m (N.Vars t vs)) comb arg) otherwise -> comb (doSimpleSpec n) arg doAlternative :: N.Node -> O.Alternative -doAlternative n = case n of - N.Guard (N.In c m) p -> O.Alternative (doVariable c) (doInputMode m) (doProcess p) - N.Guard (N.CondGuard b (N.In c m)) p -> O.AlternativeCond (doExpression b) (doVariable c) (doInputMode m) (doProcess p) - N.Guard (N.CondGuard b N.Skip) p -> O.AlternativeSkip (doExpression b) (doProcess p) +doAlternative n@(N.Node _ nt) = case nt of + N.Guard (N.Node _ (N.In c m)) p -> O.Alternative (doVariable c) (doInputMode m) (doProcess p) + N.Guard (N.Node _ (N.CondGuard b (N.Node _ (N.In c m)))) p -> O.AlternativeCond (doExpression b) (doVariable c) (doInputMode m) (doProcess p) + N.Guard (N.Node _ (N.CondGuard b (N.Node _ N.Skip))) p -> O.AlternativeSkip (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 m@(N.InCase _) -> O.Alternative (doVariable c) (doInputMode m) O.Skip - N.CondGuard b (N.In c m@(N.InCase _)) -> O.AlternativeCond (doExpression b) (doVariable c) (doInputMode m) O.Skip + N.In c m@(N.Node _ (N.InCase _)) -> O.Alternative (doVariable c) (doInputMode m) O.Skip + N.CondGuard b (N.Node _ (N.In c m@(N.Node _ (N.InCase _)))) -> O.AlternativeCond (doExpression b) (doVariable c) (doInputMode m) O.Skip doAlt :: N.Node -> O.Structured O.Alternative -doAlt n = case n of +doAlt n@(N.Node _ nt) = case nt of N.Alt ns -> O.Several $ map doAlt ns N.PriAlt ns -> O.Several $ map doAlt ns N.AltRep r n -> O.Rep (doReplicator r) (doAlt n) @@ -206,19 +206,19 @@ doAlt n = case n of otherwise -> O.Only $ doAlternative n doValueProcess :: N.Node -> O.ValueProcess -doValueProcess n = case n of +doValueProcess n@(N.Node _ nt) = case nt of N.Decl s n -> doSpecifications s O.ValOfSpec (doValueProcess n) N.ValOf p el -> O.ValOf (doProcess p) (doExpressionList el) doPlacedPar :: N.Node -> O.Structured O.Process -doPlacedPar n = case n of +doPlacedPar n@(N.Node _ nt) = case nt of N.PlacedPar ps -> O.Several $ map doPlacedPar ps N.PlacedParRep r p -> O.Rep (doReplicator r) (doPlacedPar p) N.Processor e p -> O.Only $ O.Processor (doExpression e) (doProcess p) N.Decl s p -> doSpecifications s O.Spec (doPlacedPar p) doProcess :: N.Node -> O.Process -doProcess n = case n of +doProcess n@(N.Node _ nt) = case nt of N.Decl s p -> doSpecifications s O.ProcSpec (doProcess p) N.Assign vs el -> O.Assign (map doVariable vs) (doExpressionList el) N.In c m -> O.Input (doVariable c) (doInputMode m) diff --git a/fco/Parse.hs b/fco/Parse.hs index de8c56e..d8d9b09 100644 --- a/fco/Parse.hs +++ b/fco/Parse.hs @@ -9,6 +9,17 @@ 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 -- ------------------------------------------------------------- @@ -212,11 +223,11 @@ eol = symbol "@" -- The way productions should work is that each production should only consume input if it's sure that it's unambiguous. abbreviation - = try (do { n <- name ; sIS ; v <- variable ; sColon ; eol ; return $ N.Is n v }) - <|> try (do { s <- specifier ; n <- name ; sIS ; v <- variable ; sColon ; eol ; return $ N.IsType s n v }) - <|> do { sVAL ; - try (do { n <- name ; sIS ; e <- expression ; sColon ; eol ; return $ N.ValIs n e }) - <|> do { s <- specifier ; n <- name ; sIS ; e <- expression ; sColon ; eol ; return $ N.ValIsType s n e } } + = 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 @@ -226,16 +237,16 @@ actual "actual" allocation - = do { sPLACE ; n <- name ; sAT ; e <- expression ; sColon ; eol ; return $ N.Place n e } + = do { m <- md ; sPLACE ; n <- name ; sAT ; e <- expression ; sColon ; eol ; return $ nd m $ N.Place n e } "allocation" alternation - = do { sALT ; - do { eol ; indent ; as <- many1 alternative ; outdent ; return $ N.Alt as } - <|> do { r <- replicator ; eol ; indent ; a <- alternative ; outdent ; return $ N.AltRep r a } } - <|> do { sPRI ; sALT ; - do { eol ; indent ; as <- many1 alternative ; outdent ; return $ N.PriAlt as } - <|> do { r <- replicator ; eol ; indent ; a <- alternative ; outdent ; return $ N.PriAltRep r a } } + = 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 @@ -244,13 +255,13 @@ alternation alternative = guardedAlternative <|> alternation - <|> try (do { b <- boolean ; sAmp ; c <- channel ; sQuest ; sCASE ; eol ; indent ; vs <- many1 variant ; outdent ; return $ N.CondGuard b (N.In c (N.InCase vs)) }) - <|> try (do { c <- channel ; sQuest ; sCASE ; eol ; indent ; vs <- many1 variant ; outdent ; return $ N.In c (N.InCase vs) }) - <|> do { s <- specification ; a <- alternative ; return $ N.Decl s a } + <|> 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 { vs <- variableList ; sAssign ; es <- expressionList ; eol ; return $ N.Assign vs es } + = do { m <- md ; vs <- variableList ; sAssign ; es <- expressionList ; eol ; return $ nd m $ N.Assign vs es } "assignment" base @@ -262,7 +273,7 @@ boolean "boolean" byte - = lexeme (do { char '\'' ; s <- character ; char '\'' ; return $ N.LitByte s }) + = lexeme (do { m <- md ; char '\'' ; s <- character ; char '\'' ; return $ nd m $ N.LitByte s }) "byte" caseExpression @@ -270,26 +281,26 @@ caseExpression "caseExpression" caseInput - = do { c <- channel ; sQuest ; sCASE ; eol ; indent ; vs <- many1 variant ; outdent ; return $ N.In c (N.InCase vs) } + = 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 { v <- channel' ; es <- many (do { sLeft ; e <- expression ; sRight ; return e }) ; return $ foldl (\e s -> N.Sub (N.SubPlain s) e) v es } + = 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 { sLeft ; n <- channel ; sFROM ; e <- expression ; sFOR ; f <- expression ; sRight ; return $ N.Sub (N.SubFromFor e f) n }) - <|> try (do { sLeft ; n <- channel ; sFROM ; e <- expression ; sRight ; return $ N.Sub (N.SubFrom e) n }) - <|> do { sLeft ; n <- channel ; sFOR ; e <- expression ; sRight ; return $ N.Sub (N.SubFor e) n } + <|> 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 { sCHAN ; sOF ; p <- protocol ; return $ N.ChanOf p } - <|> try (do { sLeft ; s <- expression ; sRight ; t <- channelType ; return $ N.Array s t }) + = 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! @@ -303,18 +314,19 @@ character occamChoice = guardedChoice <|> conditional - <|> do { s <- try specification ; c <- occamChoice ; return $ N.Decl s c } + <|> do { m <- md ; s <- try specification ; c <- occamChoice ; return $ nd m $ N.Decl s c } "choice" conditional - = do { sIF ; - do { eol ; indent ; cs <- many1 occamChoice ; outdent ; return $ N.If cs } - <|> do { r <- replicator ; eol ; indent ; c <- occamChoice ; outdent ; return $ N.IfRep r c } } + = 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" conversion - = do t <- dataType - do { sROUND ; o <- operand ; return $ N.Round t o } <|> do { sTRUNC ; o <- operand ; return $ N.Trunc t o } <|> do { o <- operand ; return $ N.Conv t o } + = 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 <- operand ; return $ nd m $ N.Conv t o } "conversion" occamCount @@ -322,15 +334,15 @@ occamCount "count" dataType - = do { sBOOL ; return $ N.Bool } - <|> do { sBYTE ; return $ N.Byte } - <|> do { sINT ; return $ N.Int } - <|> do { sINT16 ; return $ N.Int16 } - <|> do { sINT32 ; return $ N.Int32 } - <|> do { sINT64 ; return $ N.Int64 } - <|> do { sREAL32 ; return $ N.Real32 } - <|> do { sREAL64 ; return $ N.Real64 } - <|> try (do { sLeft ; s <- expression ; sRight ; t <- dataType ; return $ N.Array s t }) + = 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" @@ -341,28 +353,28 @@ declType <|> portType -- FIXME this originally had four lines like this, one for each of the above; --- it might be nicer to generate a different N.Node for each type of declaration +-- it might be nicer to generate a different nd m $ N.Node for each type of declaration declaration - = do { d <- declType ; ns <- sepBy1 name sComma ; sColon ; eol ; return $ N.Vars d ns } + = do { m <- md ; d <- declType ; ns <- sepBy1 name sComma ; sColon ; eol ; return $ nd m $ N.Vars d ns } "declaration" definition - = do { sDATA ; sTYPE ; n <- name ; - do {sIS ; t <- dataType ; sColon ; eol ; return $ N.DataType n t } - <|> do { eol ; indent ; t <- structuredType ; outdent ; sColon ; eol ; return $ N.DataType n t } } - <|> do { sPROTOCOL ; n <- name ; - do { sIS ; p <- sequentialProtocol ; sColon ; eol ; return $ N.Protocol n p } - <|> do { eol ; indent ; sCASE ; eol ; indent ; ps <- many1 taggedProtocol ; outdent ; outdent ; sColon ; eol ; return $ N.TaggedProtocol n ps } } - <|> do { sPROC ; n <- name ; fs <- formalList ; eol ; indent ; p <- process ; outdent ; sColon ; eol ; return $ N.Proc n fs p } - <|> try (do { rs <- sepBy1 dataType sComma ; (n, fs) <- functionHeader ; - do { sIS ; el <- expressionList ; sColon ; eol ; return $ N.FuncIs n rs fs el } - <|> do { eol ; indent ; vp <- valueProcess ; outdent ; sColon ; eol ; return $ N.Func n rs fs vp } }) - <|> try (do { s <- specifier ; n <- name ; - do { sRETYPES ; v <- variable ; sColon ; eol ; return $ N.Retypes s n v } - <|> do { try sRESHAPES ; v <- variable ; sColon ; eol ; return $ N.Reshapes s n v } }) - <|> do { sVAL ; s <- specifier ; n <- name ; - do { sRETYPES ; v <- variable ; sColon ; eol ; return $ N.ValRetypes s n v } - <|> do { sRESHAPES ; v <- variable ; sColon ; eol ; return $ N.ValReshapes s n v } } + = 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 @@ -370,49 +382,48 @@ digits "digits" dyadicOperator - = do { reservedOp "+" ; return $ N.Add } - <|> do { reservedOp "-" ; return $ N.Subtr } - <|> do { reservedOp "*" ; return $ N.Mul } - <|> do { reservedOp "/" ; return $ N.Div } - <|> do { reservedOp "\\" ; return $ N.Rem } - <|> do { sREM ; return $ N.Rem } - <|> do { sPLUS ; return $ N.Plus } - <|> do { sMINUS ; return $ N.Minus } - <|> do { sTIMES ; return $ N.Times } - <|> do { reservedOp "/\\" ; return $ N.BitAnd } - <|> do { reservedOp "\\/" ; return $ N.BitOr } - <|> do { reservedOp "><" ; return $ N.BitXor } - <|> do { sBITAND ; return $ N.BitAnd } - <|> do { sBITOR ; return $ N.BitOr } - <|> do { sAND ; return $ N.And } - <|> do { sOR ; return $ N.Or } - <|> do { reservedOp "=" ; return $ N.Eq } - <|> do { reservedOp "<>" ; return $ N.NEq } - <|> do { reservedOp "<" ; return $ N.Less } - <|> do { reservedOp ">" ; return $ N.More } - <|> do { reservedOp "<=" ; return $ N.LessEq } - <|> do { reservedOp ">=" ; return $ N.MoreEq } - <|> do { sAFTER ; return $ N.After } + = 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 :: Parser N.Node expression - = try (do { o <- monadicOperator ; v <- operand ; return $ N.MonadicOp o v }) - <|> do { a <- sMOSTPOS ; t <- dataType ; return $ N.MostPos t } - <|> do { a <- sMOSTNEG ; t <- dataType ; return $ N.MostNeg t } - <|> do { a <- sSIZE ; t <- dataType ; return $ N.Size t } - <|> try (do { a <- operand ; o <- dyadicOperator ; b <- operand ; return $ N.DyadicOp o a b }) + = 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 { n <- name ; sLeftR ; as <- sepBy expression sComma ; sRightR ; return $ N.Call n as }) - <|> do { es <- sepBy1 expression sComma ; return $ N.ExpList es } + = 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" @@ -423,23 +434,23 @@ 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 { sLeftR ; fs <- sepBy formalArg sComma ; sRightR ; return $ markTypes fs } + = 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 { sVAL ; s <- specifier ; n <- name ; return $ (Just (N.Val s), n) }) + 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 :: [(Maybe N.Node, N.Node)] -> [N.Node] - markTypes [] = [] - markTypes ((Nothing, _):_) = error "Formal list must start with a type" - markTypes ((Just ft, fn):is) = markRest ft [fn] is + 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 :: N.Node -> [N.Node] -> [(Maybe N.Node, N.Node)] -> [N.Node] - markRest lt ns [] = [N.Formals lt ns] - markRest lt ns ((Nothing, n):is) = markRest lt (ns ++ [n]) is - markRest lt ns ((Just t, n):is) = (markRest lt ns []) ++ (markRest t [n] 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) } @@ -447,37 +458,38 @@ functionHeader guard = try input - <|> try (do { b <- boolean ; sAmp ; i <- input ; return $ N.CondGuard b i }) - <|> try (do { b <- boolean ; sAmp ; sSKIP ; eol ; return $ N.CondGuard b N.Skip }) + <|> 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 { g <- guard ; indent ; p <- process ; outdent ; return $ N.Guard g p } + = do { m <- md ; g <- guard ; indent ; p <- process ; outdent ; return $ nd m $ N.Guard g p } "guardedAlternative" guardedChoice - = do { b <- boolean ; eol ; indent ; p <- process ; outdent ; return $ N.Choice b p } + = do { m <- md ; b <- boolean ; eol ; indent ; p <- process ; outdent ; return $ nd m $ N.Choice b p } "guardedChoice" hexDigits - = do { d <- many1 hexDigit ; return $ N.LitHex d } + = do { m <- md ; d <- many1 hexDigit ; return $ nd m $ N.LitHex d } "hexDigits" input - = do c <- channel + = do m <- md + c <- channel sQuest - (do { sCASE ; tl <- taggedList ; eol ; return $ N.In c (N.InTag tl) } - <|> do { sAFTER ; e <- expression ; eol ; return $ N.In c (N.InAfter e) } - <|> do { is <- sepBy1 inputItem sSemi ; eol ; return $ N.In c (N.InSimple is) }) + (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 { v <- variable ; sColons ; w <- variable ; return $ N.Counted v w }) + = try (do { m <- md ; v <- variable ; sColons ; w <- variable ; return $ nd m $ N.Counted v w }) <|> variable "inputItem" integer - = try (do { d <- lexeme digits ; return $ N.LitInt d }) + = try (do { m <- md ; d <- lexeme digits ; return $ nd m $ N.LitInt d }) <|> do { char '#' ; d <- lexeme hexDigits ; return $ d } "integer" @@ -485,35 +497,35 @@ literal = try real <|> try integer <|> try byte - <|> try (do { v <- real ; sLeftR ; t <- dataType ; sRightR ; return $ N.TypedLit t v }) - <|> try (do { v <- integer ; sLeftR ; t <- dataType ; sRightR ; return $ N.TypedLit t v }) - <|> try (do { v <- byte ; sLeftR ; t <- dataType ; sRightR ; return $ N.TypedLit t v }) - <|> try (do { sTRUE ; return $ N.True }) - <|> do { sFALSE ; return $ N.False } + <|> 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 { sWHILE ; b <- boolean ; eol ; indent ; p <- process ; outdent ; return $ N.While b p } + = do { m <- md ; sWHILE ; b <- boolean ; eol ; indent ; p <- process ; outdent ; return $ nd m $ N.While b p } monadicOperator - = do { reservedOp "-" ; return $ N.MonSub } - <|> do { sMINUS ; return $ N.MonSub } - <|> do { reservedOp "~" ; return $ N.MonBitNot } - <|> do { sBITNOT ; return $ N.MonBitNot } - <|> do { sNOT ; return $ N.MonNot } - <|> do { sSIZE ; return $ N.MonSize } + = 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 { s <- identifier ; return $ N.Name s } + = do { m <- md ; s <- identifier ; return $ nd m $ N.Name s } "name" occamString - = lexeme (do { char '"' ; s <- many (noneOf "\"") ; char '"' ; return $ N.LitString s }) + = lexeme (do { m <- md ; char '"' ; s <- many (noneOf "\"") ; char '"' ; return $ nd m $ N.LitString s }) "string" operand - = do { v <- operand' ; es <- many (do { sLeft ; e <- expression ; sRight ; return e }) ; return $ foldl (\e s -> N.Sub (N.SubPlain s) e) v es } + = 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' @@ -522,61 +534,62 @@ operand' <|> try table <|> try (do { sLeftR ; e <- expression ; sRightR ; return e }) -- XXX value process - <|> try (do { n <- name ; sLeftR ; as <- sepBy expression sComma ; sRightR ; return $ N.Call n as }) - <|> try (do { sBYTESIN ; sLeftR ; o <- operand ; sRightR ; return $ N.BytesIn o }) - <|> try (do { sBYTESIN ; sLeftR ; o <- dataType ; sRightR ; return $ N.BytesIn o }) - <|> try (do { sOFFSETOF ; sLeftR ; n <- name ; sComma ; f <- fieldName ; sRightR ; return $ N.OffsetOf n f }) + <|> 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 }) "operand'" occamOption - = try (do { ces <- sepBy caseExpression sComma ; eol ; indent ; p <- process ; outdent ; return $ N.CaseExps ces p }) - <|> try (do { sELSE ; eol ; indent ; p <- process ; outdent ; return $ N.Else p }) - <|> do { s <- specification ; o <- occamOption ; return $ N.Decl s o } + = 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 c <- channel + = do m <- md + c <- channel sBang - (do { sCASE ; t <- tag ; sSemi ; os <- sepBy1 outputItem sSemi ; eol ; return $ N.OutCase c t os } - <|> do { sCASE ; t <- tag ; eol ; return $ N.OutCase c t [] } - <|> do { os <- sepBy1 outputItem sSemi ; eol ; return $ N.Out c os }) + (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 { a <- expression ; sColons ; b <- expression ; return $ N.Counted a b }) + = try (do { m <- md ; a <- expression ; sColons ; b <- expression ; return $ nd m $ N.Counted a b }) <|> expression "outputItem" parallel - = do { sPAR ; do { eol ; indent ; ps <- many1 process ; outdent ; return $ N.Par ps } <|> do { r <- replicator ; eol ; indent ; p <- process ; outdent ; return $ N.ParRep r p } } - <|> do { sPRI ; sPAR ; do { eol ; indent ; ps <- many1 process ; outdent ; return $ N.PriPar ps } <|> do { r <- replicator ; eol ; indent ; p <- process ; outdent ; return $ N.PriParRep r p } } + = 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 { sPLACED ; sPAR ; do { eol ; indent ; ps <- many1 placedpar ; outdent ; return $ N.PlacedPar ps } <|> do { r <- replicator ; eol ; indent ; p <- placedpar ; outdent ; return $ N.PlacedParRep r p } } - <|> do { sPROCESSOR ; e <- expression ; eol ; indent ; p <- process ; outdent ; return $ N.Processor e p } + = 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 { sPORT ; sOF ; p <- protocol ; return $ N.PortOf p } - <|> do { try sLeft ; s <- try expression ; try sRight ; t <- portType ; return $ N.Array s t } + = 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 { n <- name ; sLeftR ; as <- sepBy actual sComma ; sRightR ; eol ; return $ N.ProcCall n as } + = 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 { sSKIP ; eol ; return $ N.Skip } - <|> do { sSTOP ; eol ; return $ N.Stop } + <|> do { m <- md ; sSKIP ; eol ; return $ nd m $ N.Skip } + <|> do { m <- md ; sSTOP ; eol ; return $ nd m $ N.Stop } <|> occamSequence <|> conditional <|> selection @@ -585,9 +598,9 @@ process <|> alternation <|> try caseInput <|> try procInstance - <|> do { sMainMarker ; eol ; return $ N.MainProcess } - <|> do { a <- allocation ; p <- process ; return $ N.Decl a p } - <|> do { s <- specification ; p <- process ; return $ N.Decl s p } + <|> 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 @@ -596,16 +609,16 @@ protocol "protocol" real - = try (do { l <- digits ; char '.' ; r <- digits ; char 'e' ; e <- lexeme occamExponent ; return $ N.LitReal (l ++ "." ++ r ++ "e" ++ e) }) - <|> do { l <- digits ; char '.' ; r <- lexeme digits ; return $ N.LitReal (l ++ "." ++ r) } + = 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 { n <- name ; sEq ; b <- base ; sFOR ; c <- occamCount ; return $ N.For n b c } + = do { m <- md ; n <- name ; sEq ; b <- base ; sFOR ; c <- occamCount ; return $ nd m $ N.For n b c } "replicator" selection - = do { sCASE ; s <- selector ; eol ; indent ; os <- many1 occamOption ; outdent ; return $ N.Case s os } + = do { m <- md ; sCASE ; s <- selector ; eol ; indent ; os <- many1 occamOption ; outdent ; return $ nd m $ N.Case s os } "selection" selector @@ -613,9 +626,10 @@ selector "selector" occamSequence - = do sSEQ - (do { eol ; indent ; ps <- many1 process ; outdent ; return $ N.Seq ps } - <|> do { r <- replicator ; eol ; indent ; p <- process ; outdent ; return $ N.SeqRep r p }) + = 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 @@ -623,9 +637,9 @@ sequentialProtocol "sequentialProtocol" simpleProtocol - = try (do { l <- dataType ; sColons ; sLeft ; sRight ; r <- dataType ; return $ N.Counted l r }) + = try (do { m <- md ; l <- dataType ; sColons ; sLeft ; sRight ; r <- dataType ; return $ nd m $ N.Counted l r }) <|> dataType - <|> do { sANY ; return $ N.Any } + <|> do { m <- md ; sANY ; return $ nd m $ N.Any } "simpleProtocol" specification @@ -634,39 +648,38 @@ specification <|> definition "specification" -specifier :: Parser N.Node specifier = try dataType <|> try channelType <|> try timerType <|> try portType - <|> try (do { sLeft ; sRight ; s <- specifier ; return $ N.ArrayUnsized s }) - <|> do { sLeft ; e <- expression ; sRight ; s <- specifier ; return $ N.Array e s } + <|> 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 { sRECORD ; eol ; indent ; fs <- many1 structuredTypeField ; outdent ; return $ N.Record fs }) - <|> do { sPACKED ; sRECORD ; eol ; indent ; fs <- many1 structuredTypeField ; outdent ; return $ N.PackedRecord fs } + = 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 { t <- dataType ; fs <- many1 fieldName ; sColon ; eol ; return $ N.Fields t fs } + = do { m <- md ; t <- dataType ; fs <- many1 fieldName ; sColon ; eol ; return $ nd m $ N.Fields t fs } "structuredTypeField" -- i.e. array literal table - = do { v <- table' ; es <- many (do { sLeft ; e <- expression ; sRight ; return e }) ; return $ foldl (\e s -> N.Sub (N.SubPlain s) e) v es } + = 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 { s <- occamString ; sLeftR ; n <- name ; sRightR ; return $ N.TypedLit n s }) + <|> try (do { m <- md ; s <- occamString ; sLeftR ; n <- name ; sRightR ; return $ nd m $ N.TypedLit n s }) <|> do { sLeft ; - try (do { es <- sepBy1 expression sComma ; sRight ; return $ N.LitArray es }) - <|> try (do { n <- table ; sFROM ; e <- expression ; sFOR ; f <- expression ; sRight ; return $ N.Sub (N.SubFromFor e f) n }) - <|> try (do { n <- table ; sFROM ; e <- expression ; sRight ; return $ N.Sub (N.SubFrom e) n }) - <|> do { n <- table ; sFOR ; e <- expression ; sRight ; return $ N.Sub (N.SubFor e) n } } + 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 @@ -674,32 +687,32 @@ tag "tag" taggedList - = try (do { t <- tag ; sSemi ; is <- sepBy1 inputItem sSemi ; return $ N.Tag t is }) - <|> do { t <- tag ; return $ N.Tag t [] } + = 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 { t <- tag ; eol ; return $ N.Tag t [] }) - <|> try (do { t <- tag ; sSemi ; sp <- sequentialProtocol ; eol ; return $ N.Tag t sp }) + = 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 { sTIMER ; return $ N.Timer } - <|> do { try sLeft ; s <- try expression ; try sRight ; t <- timerType ; return $ N.Array s t } + = 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 { sVALOF ; eol ; indent ; p <- process ; sRESULT ; el <- expressionList ; eol ; outdent ; return $ N.ValOf p el }) - <|> do { s <- specification ; v <- valueProcess ; return $ N.Decl s v } + = 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 { v <- variable' ; es <- many (do { sLeft ; e <- expression ; sRight ; return e }) ; return $ foldl (\e s -> N.Sub (N.SubPlain s) e) v es } + = 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 { sLeft ; n <- variable ; sFROM ; e <- expression ; sFOR ; f <- expression ; sRight ; return $ N.Sub (N.SubFromFor e f) n }) - <|> try (do { sLeft ; n <- variable ; sFROM ; e <- expression ; sRight ; return $ N.Sub (N.SubFrom e) n }) - <|> do { sLeft ; n <- variable ; sFOR ; e <- expression ; sRight ; return $ N.Sub (N.SubFor e) n } + <|> 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 @@ -707,8 +720,8 @@ variableList "variableList" variant - = try (do { t <- taggedList ; eol ; indent ; p <- process ; outdent ; return $ N.Variant t p }) - <|> do { s <- specification ; v <- variant ; return $ N.Decl s v } + = 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" -- ------------------------------------------------------------- @@ -775,9 +788,9 @@ readSource fn = do -- ------------------------------------------------------------- -parseSource :: String -> N.Node -parseSource prep - = case (parse sourceFile "occam" prep) of +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/SExpression.hs b/fco/SExpression.hs index 4ac1ef6..8c6c6be 100644 --- a/fco/SExpression.hs +++ b/fco/SExpression.hs @@ -16,7 +16,7 @@ instance Show SExp where show s = render $ sexpToDoc s dyadicName :: N.Node -> String -dyadicName n = case n of +dyadicName (N.Node meta node) = case node of N.Add -> "+" N.Subtr -> "-" N.Mul -> "*" @@ -39,25 +39,25 @@ dyadicName n = case n of N.After -> "after" monadicName :: N.Node -> String -monadicName n = case n of +monadicName (N.Node meta node) = case node of N.MonSub -> "-" N.MonBitNot -> "bitnot" N.MonNot -> "not" N.MonSize -> "size" nodeToSExp :: N.Node -> SExp -nodeToSExp node +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.InSimple b) -> wrapl1 "?" (top a) (map 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.InCase b) -> wrapl1 "?case" (top a) (map top b) - N.In a (N.InTag b) -> wrap2 "?case-tag" (top a) (top b) - N.In a (N.InAfter b) -> wrap2 "?after" (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) @@ -101,10 +101,10 @@ nodeToSExp node 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.SubPlain b) a -> wrap2 "sub" (top a) (top b) - N.Sub (N.SubFromFor b c) a -> wrap3 "sub-from-for" (top a) (top b) (top c) - N.Sub (N.SubFrom b) a -> wrap2 "sub-from" (top a) (top b) - N.Sub (N.SubFor b) a -> wrap2 "sub-for" (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) @@ -159,18 +159,18 @@ nodeToSExp node wrapl2 name arg1 arg2 args = List ((Item name) : arg1 : arg2 : args) nodeToSOccam :: N.Node -> SExp -nodeToSOccam node +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.InSimple b) -> wrapl1 "?" (top a) (map 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.InCase b) -> wrapl1 "?case" (top a) (map top b) - N.In a (N.InTag b) -> wrap2 "?case-tag" (top a) (top b) - N.In a (N.InAfter b) -> wrap2 "?after" (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) @@ -214,10 +214,10 @@ nodeToSOccam node 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.SubPlain b) a -> wrap2 "sub" (top a) (top b) - N.Sub (N.SubFromFor b c) a -> wrap3 "sub-from-for" (top a) (top b) (top c) - N.Sub (N.SubFrom b) a -> wrap2 "sub-from" (top a) (top b) - N.Sub (N.SubFor b) a -> wrap2 "sub-for" (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)