Add tree datatype, and rework parser to produce it instead of soccam
This commit is contained in:
Adam Sampson
parent
5429cfe2b8
commit
2e9d2123ad
12
fco/Main.hs
Normal file
12
fco/Main.hs
Normal file
|
|
@ -0,0 +1,12 @@
|
|||
-- Driver for FCO
|
||||
|
||||
module Main where
|
||||
|
||||
import Text.ParserCombinators.Parsec
|
||||
|
||||
import Parse
|
||||
|
||||
main = do d <- getContents
|
||||
parseTest process (prepare d)
|
||||
|
||||
|
||||
|
|
@ -1,5 +1,5 @@
|
|||
all: occ2socc
|
||||
all: fco
|
||||
|
||||
occ2socc: Parse.hs
|
||||
ghc -o occ2socc --make Parse
|
||||
fco: Main.hs Parse.hs Tree.hs
|
||||
ghc -o fco --make Main
|
||||
|
||||
|
|
|
|||
443
fco/Parse.hs
443
fco/Parse.hs
|
|
@ -1,22 +1,13 @@
|
|||
-- vim:et:ts=2
|
||||
-- Parse occam2.1 code into soccam2.1.
|
||||
-- Adam Sampson <ats@offog.org>
|
||||
-- To compile: ghc -o occ2socc --make Parse
|
||||
-- Then run with: ./occ2socc <my.occ >my.socc
|
||||
-- Or to interpret: ghci Parse.hs
|
||||
-- Parse occam code
|
||||
|
||||
module Parse where
|
||||
|
||||
import Data.List
|
||||
import Text.ParserCombinators.Parsec
|
||||
import qualified Text.ParserCombinators.Parsec.Token as P
|
||||
import Text.ParserCombinators.Parsec.Language (emptyDef)
|
||||
|
||||
-- -------------------------------------------------------------
|
||||
|
||||
data SExp = Item String | List [SExp]
|
||||
|
||||
instance Show SExp where
|
||||
show (Item s) = s
|
||||
show (List is) = "(" ++ (concat $ intersperse " " $ map show is) ++ ")"
|
||||
import Tree
|
||||
|
||||
-- -------------------------------------------------------------
|
||||
|
||||
|
|
@ -209,21 +200,19 @@ indent = symbol "{"
|
|||
outdent = symbol "}"
|
||||
eol = symbol "@"
|
||||
|
||||
-- Most of these have type "Parser SExp".
|
||||
|
||||
abbreviation
|
||||
= try (do { n <- name ; sIS ; v <- variable ; sColon ; eol ; return $ List [Item "is", n, v] })
|
||||
<|> try (do { s <- specifier ; n <- name ; sIS ; v <- variable ; sColon ; eol ; return $ List [Item "is", s, n, v] })
|
||||
<|> try (do { sVAL ; n <- name ; sIS ; e <- expression ; sColon ; eol ; return $ List [Item "val-is", n, e] })
|
||||
<|> try (do { sVAL ; s <- specifier ; n <- name ; sIS ; e <- expression ; sColon ; eol ; return $ List [Item "val-is", s, n, e] })
|
||||
<|> try (do { n <- name ; sIS ; v <- channel ; sColon ; eol ; return $ List [Item "is", n, v] })
|
||||
<|> try (do { s <- specifier ; n <- name ; sIS ; v <- channel ; sColon ; eol ; return $ List [Item "is", s, n, v] })
|
||||
<|> try (do { n <- name ; sIS ; sLeft ; v <- sepBy1 channel sComma ; sRight ; sColon ; eol ; return $ List [Item "is", n, List v] })
|
||||
<|> try (do { s <- specifier ; n <- name ; sIS ; sLeft ; v <- sepBy1 channel sComma ; return $ List [Item "is", s, n, List v] })
|
||||
<|> try (do { n <- name ; sIS ; v <- timer ; sColon ; eol ; return $ List [Item "is", n, v] })
|
||||
<|> try (do { s <- specifier ; n <- name ; sIS ; v <- timer ; sColon ; eol ; return $ List [Item "is", s, n, v] })
|
||||
<|> try (do { n <- name ; sIS ; v <- port ; sColon ; eol ; return $ List [Item "is", n, v] })
|
||||
<|> do { s <- specifier ; n <- name ; sIS ; v <- port ; sColon ; eol ; return $ List [Item "is", s, n, v] }
|
||||
= try (do { n <- name ; sIS ; v <- variable ; sColon ; eol ; return $ OcIs n v })
|
||||
<|> try (do { s <- specifier ; n <- name ; sIS ; v <- variable ; sColon ; eol ; return $ OcIsType s n v })
|
||||
<|> try (do { sVAL ; n <- name ; sIS ; e <- expression ; sColon ; eol ; return $ OcValIs n e })
|
||||
<|> try (do { sVAL ; s <- specifier ; n <- name ; sIS ; e <- expression ; sColon ; eol ; return $ OcValIsType s n e })
|
||||
-- <|> try (do { n <- name ; sIS ; v <- channel ; sColon ; eol ; return $ List [Item "is", n, v] })
|
||||
-- <|> try (do { s <- specifier ; n <- name ; sIS ; v <- channel ; sColon ; eol ; return $ List [Item "is", s, n, v] })
|
||||
-- <|> try (do { n <- name ; sIS ; sLeft ; v <- sepBy1 channel sComma ; sRight ; sColon ; eol ; return $ List [Item "is", n, List v] })
|
||||
-- <|> try (do { s <- specifier ; n <- name ; sIS ; sLeft ; v <- sepBy1 channel sComma ; return $ List [Item "is", s, n, List v] })
|
||||
-- <|> try (do { n <- name ; sIS ; v <- timer ; sColon ; eol ; return $ List [Item "is", n, v] })
|
||||
-- <|> try (do { s <- specifier ; n <- name ; sIS ; v <- timer ; sColon ; eol ; return $ List [Item "is", s, n, v] })
|
||||
-- <|> try (do { n <- name ; sIS ; v <- port ; sColon ; eol ; return $ List [Item "is", n, v] })
|
||||
-- <|> do { s <- specifier ; n <- name ; sIS ; v <- port ; sColon ; eol ; return $ List [Item "is", s, n, v] }
|
||||
<?> "abbreviation"
|
||||
|
||||
actual
|
||||
|
|
@ -235,26 +224,26 @@ actual
|
|||
<?> "actual"
|
||||
|
||||
allocation
|
||||
= do { sPLACE ; n <- name ; sAT ; e <- expression ; sColon ; eol ; return $ List [Item "place-at", n, e] }
|
||||
= do { sPLACE ; n <- name ; sAT ; e <- expression ; sColon ; eol ; return $ OcPlace n e }
|
||||
<?> "allocation"
|
||||
|
||||
alternation
|
||||
= try (do { sALT ; eol ; indent ; as <- many1 alternative ; outdent ; return $ List ([Item "alt"] ++ as) })
|
||||
<|> try (do { sALT ; r <- replicator ; eol ; indent ; a <- alternative ; outdent ; return $ List ([Item "alt", r, a]) })
|
||||
<|> try (do { sPRI ; sALT ; eol ; indent ; as <- many1 alternative ; outdent ; return $ List ([Item "pri-alt"] ++ as) })
|
||||
<|> do { sPRI ; sALT ; r <- replicator ; eol ; indent ; a <- alternative ; outdent ; return $ List ([Item "pri-alt", r, a]) }
|
||||
= try (do { sALT ; eol ; indent ; as <- many1 alternative ; outdent ; return $ OcAlt as })
|
||||
<|> try (do { sALT ; r <- replicator ; eol ; indent ; a <- alternative ; outdent ; return $ OcAltRep r a })
|
||||
<|> try (do { sPRI ; sALT ; eol ; indent ; as <- many1 alternative ; outdent ; return $ OcPriAlt as })
|
||||
<|> do { sPRI ; sALT ; r <- replicator ; eol ; indent ; a <- alternative ; outdent ; return $ OcPriAltRep r a }
|
||||
<?> "alternation"
|
||||
|
||||
alternative
|
||||
= try guardedAlternative
|
||||
<|> try alternation
|
||||
<|> try (do { c <- channel ; sQuest ; sCASE ; eol ; indent ; vs <- many1 variant ; outdent ; return $ List ([Item "?case", c] ++ vs) })
|
||||
<|> try (do { b <- boolean ; sAmp ; c <- channel ; sQuest ; sCASE ; eol ; indent ; vs <- many1 variant ; outdent ; return $ List ([Item "?case-guarded", b, c] ++ vs) })
|
||||
<|> do { s <- specification ; a <- alternative ; return $ List [Item ":", s, a] }
|
||||
<|> try (do { c <- channel ; sQuest ; sCASE ; eol ; indent ; vs <- many1 variant ; outdent ; return $ OcInCase c vs })
|
||||
<|> try (do { b <- boolean ; sAmp ; c <- channel ; sQuest ; sCASE ; eol ; indent ; vs <- many1 variant ; outdent ; return $ OcInCaseGuard b c vs })
|
||||
<|> do { s <- specification ; a <- alternative ; return $ OcDecl s a }
|
||||
<?> "alternative"
|
||||
|
||||
assignment
|
||||
= do { vs <- variableList ; sAssign ; es <- expressionList ; eol ; return $ List [Item ":=", vs, es] }
|
||||
= do { vs <- variableList ; sAssign ; es <- expressionList ; eol ; return $ OcAssign vs es }
|
||||
<?> "assignment"
|
||||
|
||||
base
|
||||
|
|
@ -266,7 +255,7 @@ boolean
|
|||
<?> "boolean"
|
||||
|
||||
byte
|
||||
= lexeme (do { char '\'' ; c <- character ; char '\'' ; return $ Item ("'" ++ (case c of Item s -> s) ++ "'") })
|
||||
= lexeme (do { char '\'' ; s <- character ; char '\'' ; return $ OcLitByte s })
|
||||
<?> "byte"
|
||||
|
||||
caseExpression
|
||||
|
|
@ -274,46 +263,46 @@ caseExpression
|
|||
<?> "caseExpression"
|
||||
|
||||
caseInput
|
||||
= do { c <- channel ; sQuest ; sCASE ; eol ; indent ; vs <- many1 variant ; outdent ; return $ List ([Item "?case", c] ++ vs) }
|
||||
= do { c <- channel ; sQuest ; sCASE ; eol ; indent ; vs <- many1 variant ; outdent ; return $ OcInCase c vs }
|
||||
<?> "caseInput"
|
||||
|
||||
channel
|
||||
= do { v <- channel' ; es <- many (do { sLeft ; e <- expression ; sRight ; return e }) ; return $ foldl (\ v e -> List [Item "sub", v, e]) v es }
|
||||
= do { v <- channel' ; es <- many (do { sLeft ; e <- expression ; sRight ; return e }) ; return $ foldl OcSub v es }
|
||||
<?> "channel"
|
||||
|
||||
channel'
|
||||
= try name
|
||||
<|> try (do { sLeft ; n <- channel ; sFROM ; e <- expression ; sFOR ; f <- expression ; sRight ; return $ List [Item "sub-from-for", n, e, f] })
|
||||
<|> try (do { sLeft ; n <- channel ; sFROM ; e <- expression ; sRight ; return $ List [Item "sub-from", n, e] })
|
||||
<|> do { sLeft ; n <- channel ; sFOR ; e <- expression ; sRight ; return $ List [Item "sub-for", n, e] }
|
||||
<|> try (do { sLeft ; n <- channel ; sFROM ; e <- expression ; sFOR ; f <- expression ; sRight ; return $ OcSubFromFor n e f })
|
||||
<|> try (do { sLeft ; n <- channel ; sFROM ; e <- expression ; sRight ; return $ OcSubFrom n e })
|
||||
<|> do { sLeft ; n <- channel ; sFOR ; e <- expression ; sRight ; return $ OcSubFor n e }
|
||||
<?> "channel'"
|
||||
|
||||
channelType
|
||||
= try (do { sCHAN ; sOF ; p <- protocol ; return $ List [Item "chan-of", p] })
|
||||
<|> do { sLeft ; s <- expression ; sRight ; t <- channelType ; return $ List [Item "array", s, t] }
|
||||
= try (do { sCHAN ; sOF ; p <- protocol ; return $ OcChanOf p })
|
||||
<|> do { sLeft ; s <- expression ; sRight ; t <- channelType ; return $ OcArray s t }
|
||||
<?> "channelType"
|
||||
|
||||
character
|
||||
= try (do { char '*' ; char '#' ; a <- hexDigit ; b <- hexDigit ; return $ Item ['*', '#', a, b] })
|
||||
<|> try (do { char '*' ; c <- anyChar ; return $ Item ['*', c] })
|
||||
<|> do { c <- anyChar ; return $ Item [c] }
|
||||
= try (do { char '*' ; char '#' ; a <- hexDigit ; b <- hexDigit ; return $ ['*', '#', a, b] })
|
||||
<|> try (do { char '*' ; c <- anyChar ; return $ ['*', c] })
|
||||
<|> do { c <- anyChar ; return $ [c] }
|
||||
<?> "character"
|
||||
|
||||
occamChoice
|
||||
= try guardedChoice
|
||||
<|> try conditional
|
||||
<|> do { s <- specification ; c <- occamChoice ; return $ List [Item ":", s, c] }
|
||||
<|> do { s <- specification ; c <- occamChoice ; return $ OcDecl s c }
|
||||
<?> "choice"
|
||||
|
||||
conditional
|
||||
= try (do { sIF ; eol ; indent ; cs <- many1 occamChoice ; outdent ; return $ List ([Item "if"] ++ cs) })
|
||||
<|> do { sIF ; r <- replicator ; eol ; indent ; c <- occamChoice ; outdent ; return $ List [Item "if", r, c] }
|
||||
= try (do { sIF ; eol ; indent ; cs <- many1 occamChoice ; outdent ; return $ OcIf cs })
|
||||
<|> do { sIF ; r <- replicator ; eol ; indent ; c <- occamChoice ; outdent ; return $ OcIfRep r c }
|
||||
<?> "conditional"
|
||||
|
||||
conversion
|
||||
= try (do { t <- dataType ; o <- operand ; return $ List [Item "conv", t, o] })
|
||||
<|> try (do { t <- dataType ; sROUND ; o <- operand ; return $ List [Item "round", t, o] })
|
||||
<|> do { t <- dataType ; sTRUNC ; o <- operand ; return $ List [Item "trunc", t, o] }
|
||||
= try (do { t <- dataType ; o <- operand ; return $ OcConv t o })
|
||||
<|> try (do { t <- dataType ; sROUND ; o <- operand ; return $ OcRound t o })
|
||||
<|> do { t <- dataType ; sTRUNC ; o <- operand ; return $ OcTrunc t o }
|
||||
<?> "conversion"
|
||||
|
||||
occamCount
|
||||
|
|
@ -321,46 +310,51 @@ occamCount
|
|||
<?> "count"
|
||||
|
||||
dataType
|
||||
= do { try sBOOL ; return $ Item "bool" }
|
||||
<|> do { try sBYTE ; return $ Item "byte" }
|
||||
<|> do { try sINT ; return $ Item "int" }
|
||||
<|> do { try sINT16 ; return $ Item "int16" }
|
||||
<|> do { try sINT32 ; return $ Item "int32" }
|
||||
<|> do { try sINT64 ; return $ Item "int64" }
|
||||
<|> do { try sREAL32 ; return $ Item "real32" }
|
||||
<|> do { try sREAL64 ; return $ Item "real64" }
|
||||
<|> try (do { sLeft ; s <- expression ; sRight ; t <- dataType ; return $ List [Item "array", s, t] })
|
||||
= do { try sBOOL ; return $ OcBool }
|
||||
<|> do { try sBYTE ; return $ OcByte }
|
||||
<|> do { try sINT ; return $ OcInt }
|
||||
<|> do { try sINT16 ; return $ OcInt16 }
|
||||
<|> do { try sINT32 ; return $ OcInt32 }
|
||||
<|> do { try sINT64 ; return $ OcInt64 }
|
||||
<|> do { try sREAL32 ; return $ OcReal32 }
|
||||
<|> do { try sREAL64 ; return $ OcReal64 }
|
||||
<|> try (do { sLeft ; s <- expression ; sRight ; t <- dataType ; return $ OcArray 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 Node for each type of declaration
|
||||
declaration
|
||||
= try (do { d <- dataType ; ns <- sepBy1 name sComma ; sColon ; eol ; return $ List (d : ns) })
|
||||
<|> try (do { d <- channelType ; ns <- sepBy1 name sComma ; sColon ; eol ; return $ List (d : ns) })
|
||||
<|> try (do { d <- timerType ; ns <- sepBy1 name sComma ; sColon ; eol ; return $ List (d : ns) })
|
||||
<|> try (do { d <- portType ; ns <- sepBy1 name sComma ; sColon ; eol ; return $ List (d : ns) })
|
||||
= try (do { d <- declType ; ns <- sepBy1 name sComma ; sColon ; eol ; return $ OcVars d ns })
|
||||
<?> "declaration"
|
||||
|
||||
definition
|
||||
= try (do { sDATA ; sTYPE ; n <- name ; sIS ; t <- dataType ; sColon ; eol ; return $ List [Item "data-type", n, t] })
|
||||
<|> try (do { sDATA ; sTYPE ; n <- name ; eol ; indent ; t <- structuredType ; outdent ; sColon ; eol ; return $ List [Item "data-type", n, t] })
|
||||
<|> try (do { sPROTOCOL ; n <- name ; sIS ; p <- simpleProtocol ; sColon ; eol ; return $ List [Item "protocol", n, p] })
|
||||
<|> try (do { sPROTOCOL ; n <- name ; sIS ; p <- sequentialProtocol ; sColon ; eol ; return $ List [Item "protocol", n, p] })
|
||||
<|> try (do { sPROTOCOL ; n <- name ; eol ; indent ; sCASE ; eol ; indent ; ps <- many1 taggedProtocol ; outdent ; outdent ; sColon ; eol ; return $ List [Item "protocol", n, List ps] })
|
||||
<|> try (do { sPROC ; n <- name ; fs <- formalList ; eol ; indent ; p <- process ; outdent ; sColon ; eol ; return $ List [Item "proc", n, fs, p] })
|
||||
<|> try (do { rs <- sepBy1 dataType sComma ; (n, fs) <- functionHeader ; eol ; indent ; vp <- valueProcess ; outdent ; sColon ; eol ; return $ List [Item "fun", List rs, n, fs, vp] })
|
||||
<|> try (do { rs <- sepBy1 dataType sComma ; (n, fs) <- functionHeader ; sIS ; el <- expressionList ; sColon ; eol ; return $ List [Item "fun-is", List rs, n, fs, el] })
|
||||
<|> try (do { s <- specifier ; n <- name ; sRETYPES ; v <- variable ; sColon ; eol ; return $ List [Item "retypes", s, n, v] })
|
||||
<|> try (do { sVAL ; s <- specifier ; n <- name ; sRETYPES ; v <- variable ; sColon ; eol ; return $ List [Item "val-retypes", s, n, v] })
|
||||
<|> try (do { s <- specifier ; n <- name ; sRETYPES ; v <- channel ; sColon ; eol ; return $ List [Item "retypes", s, n, v] })
|
||||
<|> try (do { s <- specifier ; n <- name ; sRETYPES ; v <- port ; sColon ; eol ; return $ List [Item "retypes", s, n, v] })
|
||||
<|> try (do { s <- specifier ; n <- name ; sRESHAPES ; v <- variable ; sColon ; eol ; return $ List [Item "reshapes", s, n, v] })
|
||||
<|> try (do { sVAL ; s <- specifier ; n <- name ; sRESHAPES ; v <- variable ; sColon ; eol ; return $ List [Item "val-reshapes", s, n, v] })
|
||||
<|> try (do { s <- specifier ; n <- name ; sRESHAPES ; v <- channel ; sColon ; eol ; return $ List [Item "reshapes", s, n, v] })
|
||||
<|> do { s <- specifier ; n <- name ; sRESHAPES ; v <- port ; sColon ; eol ; return $ List [Item "reshapes", s, n, v] }
|
||||
= try (do { sDATA ; sTYPE ; n <- name ; sIS ; t <- dataType ; sColon ; eol ; return $ OcDataType n t })
|
||||
<|> try (do { sDATA ; sTYPE ; n <- name ; eol ; indent ; t <- structuredType ; outdent ; sColon ; eol ; return $ OcDataType n t })
|
||||
<|> try (do { sPROTOCOL ; n <- name ; sIS ; p <- simpleProtocol ; sColon ; eol ; return $ OcProtocol n [p] })
|
||||
<|> try (do { sPROTOCOL ; n <- name ; sIS ; p <- sequentialProtocol ; sColon ; eol ; return $ OcProtocol n p })
|
||||
<|> try (do { sPROTOCOL ; n <- name ; eol ; indent ; sCASE ; eol ; indent ; ps <- many1 taggedProtocol ; outdent ; outdent ; sColon ; eol ; return $ OcTaggedProtocol n ps })
|
||||
<|> try (do { sPROC ; n <- name ; fs <- formalList ; eol ; indent ; p <- process ; outdent ; sColon ; eol ; return $ OcProc n fs p })
|
||||
<|> try (do { rs <- sepBy1 dataType sComma ; (n, fs) <- functionHeader ; eol ; indent ; vp <- valueProcess ; outdent ; sColon ; eol ; return $ OcFunc n rs fs vp })
|
||||
<|> try (do { rs <- sepBy1 dataType sComma ; (n, fs) <- functionHeader ; sIS ; el <- expressionList ; sColon ; eol ; return $ OcFuncIs n rs fs el })
|
||||
<|> try (do { s <- specifier ; n <- name ; sRETYPES ; v <- variable ; sColon ; eol ; return $ OcRetypes s n v })
|
||||
<|> try (do { sVAL ; s <- specifier ; n <- name ; sRETYPES ; v <- variable ; sColon ; eol ; return $ OcValRetypes s n v })
|
||||
-- <|> try (do { s <- specifier ; n <- name ; sRETYPES ; v <- channel ; sColon ; eol ; return $ List [Item "retypes", s, n, v] })
|
||||
-- <|> try (do { s <- specifier ; n <- name ; sRETYPES ; v <- port ; sColon ; eol ; return $ List [Item "retypes", s, n, v] })
|
||||
<|> try (do { s <- specifier ; n <- name ; sRESHAPES ; v <- variable ; sColon ; eol ; return $ OcReshapes s n v })
|
||||
<|> try (do { sVAL ; s <- specifier ; n <- name ; sRESHAPES ; v <- variable ; sColon ; eol ; return $ OcValReshapes s n v })
|
||||
-- <|> try (do { s <- specifier ; n <- name ; sRESHAPES ; v <- channel ; sColon ; eol ; return $ List [Item "reshapes", s, n, v] })
|
||||
-- <|> do { s <- specifier ; n <- name ; sRESHAPES ; v <- port ; sColon ; eol ; return $ List [Item "reshapes", s, n, v] }
|
||||
<?> "definition"
|
||||
|
||||
delayedInput
|
||||
= try (do { c <- channel ; sQuest ; sAFTER ; e <- expression ; eol ; return $ List [Item "?after", c, e] })
|
||||
= try (do { c <- channel ; sQuest ; sAFTER ; e <- expression ; eol ; return $ OcInAfter c e })
|
||||
<?> "delayedInput"
|
||||
|
||||
-- NB does not return an SExp
|
||||
|
|
@ -369,48 +363,49 @@ digits
|
|||
<?> "digits"
|
||||
|
||||
dyadicOperator
|
||||
= try (do { reservedOp "+" ; return $ Item "+" })
|
||||
<|> try (do { reservedOp "-" ; return $ Item "-" })
|
||||
<|> try (do { reservedOp "*" ; return $ Item "*" })
|
||||
<|> try (do { reservedOp "/" ; return $ Item "/" })
|
||||
<|> try (do { reservedOp "\\" ; return $ Item "mod" })
|
||||
<|> try (do { sREM ; return $ Item "rem" })
|
||||
<|> try (do { sPLUS ; return $ Item "plus" })
|
||||
<|> try (do { sMINUS ; return $ Item "minus" })
|
||||
<|> try (do { sTIMES ; return $ Item "times" })
|
||||
<|> try (do { reservedOp "/\\" ; return $ Item "bitand" })
|
||||
<|> try (do { reservedOp "\\/" ; return $ Item "bitor" })
|
||||
<|> try (do { reservedOp "><" ; return $ Item "bitxor" })
|
||||
<|> try (do { sBITAND ; return $ Item "bitand" })
|
||||
<|> try (do { sBITOR ; return $ Item "bitor" })
|
||||
<|> try (do { sAND ; return $ Item "and" })
|
||||
<|> try (do { sOR ; return $ Item "or" })
|
||||
<|> try (do { reservedOp "=" ; return $ Item "=" })
|
||||
<|> try (do { reservedOp "<>" ; return $ Item "<>" })
|
||||
<|> try (do { reservedOp "<" ; return $ Item "<" })
|
||||
<|> try (do { reservedOp ">" ; return $ Item ">" })
|
||||
<|> try (do { reservedOp ">=" ; return $ Item ">=" })
|
||||
<|> try (do { reservedOp "<=" ; return $ Item "<=" })
|
||||
<|> try (do { sAFTER ; return $ Item "after" })
|
||||
= try (do { reservedOp "+" ; return $ OcAdd })
|
||||
<|> try (do { reservedOp "-" ; return $ OcSubtr })
|
||||
<|> try (do { reservedOp "*" ; return $ OcMul })
|
||||
<|> try (do { reservedOp "/" ; return $ OcDiv })
|
||||
<|> try (do { reservedOp "\\" ; return $ OcMod })
|
||||
<|> try (do { sREM ; return $ OcRem })
|
||||
<|> try (do { sPLUS ; return $ OcPlus })
|
||||
<|> try (do { sMINUS ; return $ OcMinus })
|
||||
<|> try (do { sTIMES ; return $ OcTimes })
|
||||
<|> try (do { reservedOp "/\\" ; return $ OcBitAnd })
|
||||
<|> try (do { reservedOp "\\/" ; return $ OcBitOr })
|
||||
<|> try (do { reservedOp "><" ; return $ OcBitXor })
|
||||
<|> try (do { sBITAND ; return $ OcBitAnd })
|
||||
<|> try (do { sBITOR ; return $ OcBitOr })
|
||||
<|> try (do { sAND ; return $ OcAnd })
|
||||
<|> try (do { sOR ; return $ OcOr })
|
||||
<|> try (do { reservedOp "=" ; return $ OcEq })
|
||||
<|> try (do { reservedOp "<>" ; return $ OcNEq })
|
||||
<|> try (do { reservedOp "<" ; return $ OcLess })
|
||||
<|> try (do { reservedOp ">" ; return $ OcMore })
|
||||
<|> try (do { reservedOp "<=" ; return $ OcLessEq })
|
||||
<|> try (do { reservedOp ">=" ; return $ OcMoreEq })
|
||||
<|> try (do { sAFTER ; return $ OcAfter })
|
||||
<?> "dyadicOperator"
|
||||
|
||||
occamExponent
|
||||
= try (do { c <- oneOf "+-" ; d <- digits ; return $ c : d })
|
||||
<?> "exponent"
|
||||
|
||||
expression :: Parser Node
|
||||
expression
|
||||
= try (do { o <- monadicOperator ; v <- operand ; return $ List [o, v] })
|
||||
<|> try (do { a <- operand ; o <- dyadicOperator ; b <- operand ; return $ List [o, a, b] })
|
||||
<|> try (do { a <- sMOSTPOS ; t <- dataType ; return $ List [Item "mostpos", t] })
|
||||
<|> try (do { a <- sMOSTNEG ; t <- dataType ; return $ List [Item "mostneg", t] })
|
||||
<|> try (do { a <- sSIZE ; t <- dataType ; return $ List [Item "size", t] })
|
||||
= try (do { o <- monadicOperator ; v <- operand ; return $ o v })
|
||||
<|> try (do { a <- operand ; o <- dyadicOperator ; b <- operand ; return $ o a b })
|
||||
<|> try (do { a <- sMOSTPOS ; t <- dataType ; return $ OcMostPos t })
|
||||
<|> try (do { a <- sMOSTNEG ; t <- dataType ; return $ OcMostNeg t })
|
||||
<|> try (do { a <- sSIZE ; t <- dataType ; return $ OcSize t })
|
||||
<|> try conversion
|
||||
<|> operand
|
||||
<?> "expression"
|
||||
|
||||
expressionList
|
||||
= try (do { n <- name ; sLeftR ; as <- sepBy expression sComma ; sRightR ; return $ List ([Item "call", n] ++ as) })
|
||||
<|> try (do { es <- sepBy1 expression sComma ; return $ List es })
|
||||
= try (do { n <- name ; sLeftR ; as <- sepBy expression sComma ; sRightR ; return $ OcCall n as })
|
||||
<|> try (do { es <- sepBy1 expression sComma ; return $ OcExpList es })
|
||||
-- XXX value process
|
||||
<?> "expressionList"
|
||||
|
||||
|
|
@ -419,21 +414,24 @@ fieldName
|
|||
<?> "fieldName"
|
||||
|
||||
-- This is rather different from the grammar.
|
||||
-- FIXME should this lot actually be done in a pass? probably...
|
||||
formalList
|
||||
= do { sLeftR ; fs <- sepBy formalArg sComma ; sRightR ; return $ List (map List (reverse (reduce (reverse fs) []))) }
|
||||
= do { sLeftR ; fs <- sepBy formalArg sComma ; sRightR ; return $ markTypes fs }
|
||||
<?> "formalList"
|
||||
where
|
||||
formalArg :: Parser ([[SExp]] -> [[SExp]])
|
||||
formalArg = try (do { sVAL ; s <- specifier ; n <- name ; return $ addToList [Item "val", s] n })
|
||||
<|> try (do { s <- specifier ; n <- name ; return $ addToList [s] n })
|
||||
<|> try (do { n <- name ; return $ addToList [] n })
|
||||
formalArg :: Parser (Maybe Node, Node)
|
||||
formalArg = try (do { sVAL ; s <- specifier ; n <- name ; return $ (Just (OcVal s), n) })
|
||||
<|> try (do { s <- specifier ; n <- name ; return $ (Just s, n) })
|
||||
<|> try (do { n <- name ; return $ (Nothing, n) })
|
||||
|
||||
addToList :: [SExp] -> SExp -> [[SExp]] -> [[SExp]]
|
||||
addToList [] n (l:ls) = (l ++ [n]) : ls
|
||||
addToList s n ls = (s ++ [n]) : ls
|
||||
markTypes :: [(Maybe Node, Node)] -> [Node]
|
||||
markTypes ((Nothing, _):_) = error "Formal list must start with a type"
|
||||
markTypes ((Just ft,fn):is) = (OcFormal ft fn) : markRest ft is
|
||||
|
||||
reduce [] x = x
|
||||
reduce (f:fs) x = f (reduce fs x)
|
||||
markRest :: Node -> [(Maybe Node, Node)] -> [Node]
|
||||
markRest _ [] = []
|
||||
markRest t ((Nothing, n):is) = (OcFormal t n) : markRest t is
|
||||
markRest _ ((Just t, n):is) = (OcFormal t n) : markRest t is
|
||||
|
||||
functionHeader
|
||||
= do { sFUNCTION ; n <- name ; fs <- formalList ; return $ (n, fs) }
|
||||
|
|
@ -441,20 +439,20 @@ functionHeader
|
|||
|
||||
guard
|
||||
= try input
|
||||
<|> try (do { b <- boolean ; sAmp ; i <- input ; return $ List [Item "guarded", b, i] })
|
||||
<|> try (do { b <- boolean ; sAmp ; sSKIP ; eol ; return $ List [Item "guarded", b, Item "skip"] })
|
||||
<|> try (do { b <- boolean ; sAmp ; i <- input ; return $ OcGuarded b i })
|
||||
<|> try (do { b <- boolean ; sAmp ; sSKIP ; eol ; return $ OcGuarded b OcSkip })
|
||||
<?> "guard"
|
||||
|
||||
guardedAlternative
|
||||
= do { g <- guard ; indent ; p <- process ; outdent ; return $ List [g, p] }
|
||||
= do { g <- guard ; indent ; p <- process ; outdent ; return $ OcGuarded g p }
|
||||
<?> "guardedAlternative"
|
||||
|
||||
guardedChoice
|
||||
= do { b <- boolean ; eol ; indent ; p <- process ; outdent ; return $ List [b, p] }
|
||||
= do { b <- boolean ; eol ; indent ; p <- process ; outdent ; return $ OcGuarded b p }
|
||||
<?> "guardedChoice"
|
||||
|
||||
hexDigits
|
||||
= do { d <- many1 hexDigit ; return $ Item d }
|
||||
= do { d <- many1 hexDigit ; return $ OcLitHex d }
|
||||
<?> "hexDigits"
|
||||
|
||||
-- XXX how does the syntax handle multiline regular CASE inputs?
|
||||
|
|
@ -463,56 +461,56 @@ hexDigits
|
|||
-- ...
|
||||
|
||||
input
|
||||
= try (do { c <- channel ; sQuest ; is <- sepBy1 inputItem sSemi ; eol ; return $ List ([Item "?", c] ++ is) })
|
||||
<|> try (do { c <- channel ; sQuest ; sCASE ; tl <- taggedList ; eol ; return $ List [Item "?case", c, tl] })
|
||||
= try (do { c <- channel ; sQuest ; is <- sepBy1 inputItem sSemi ; eol ; return $ OcIn c is })
|
||||
<|> try (do { c <- channel ; sQuest ; sCASE ; tl <- taggedList ; eol ; return $ OcInTag c tl })
|
||||
<|> timerInput
|
||||
<|> delayedInput
|
||||
<|> do { p <- port ; sQuest ; v <- variable ; eol ; return $ List [Item "?", p, v] }
|
||||
-- <|> do { p <- port ; sQuest ; v <- variable ; eol ; return $ OcIn p (OcExpList [v]) }
|
||||
<?> "input"
|
||||
|
||||
inputItem
|
||||
= try (do { v <- variable ; sColons ; w <- variable ; return $ List [Item "::", v, w] })
|
||||
= try (do { v <- variable ; sColons ; w <- variable ; return $ OcCounted v w })
|
||||
<|> variable
|
||||
<?> "inputItem"
|
||||
|
||||
integer
|
||||
= try (do { d <- lexeme digits ; return $ Item d })
|
||||
<|> do { char '#' ; d <- lexeme hexDigits ; return $ Item ("#" ++ case d of Item ds -> ds) }
|
||||
= try (do { d <- lexeme digits ; return $ OcLitInt d })
|
||||
<|> do { char '#' ; d <- lexeme hexDigits ; return $ d }
|
||||
<?> "integer"
|
||||
|
||||
literal
|
||||
= try real
|
||||
<|> try integer
|
||||
<|> try byte
|
||||
<|> try (do { v <- real ; sLeftR ; t <- dataType ; sRightR ; return $ List [t, v] })
|
||||
<|> try (do { v <- integer ; sLeftR ; t <- dataType ; sRightR ; return $ List [t, v] })
|
||||
<|> try (do { v <- byte ; sLeftR ; t <- dataType ; sRightR ; return $ List [t, v] })
|
||||
<|> try (do { sTRUE ; return $ Item "true" })
|
||||
<|> do { sFALSE ; return $ Item "false" }
|
||||
<|> try (do { v <- real ; sLeftR ; t <- dataType ; sRightR ; return $ OcTypedLit t v })
|
||||
<|> try (do { v <- integer ; sLeftR ; t <- dataType ; sRightR ; return $ OcTypedLit t v })
|
||||
<|> try (do { v <- byte ; sLeftR ; t <- dataType ; sRightR ; return $ OcTypedLit t v })
|
||||
<|> try (do { sTRUE ; return $ OcTrue })
|
||||
<|> do { sFALSE ; return $ OcFalse }
|
||||
<?> "literal"
|
||||
|
||||
loop
|
||||
= do { sWHILE ; b <- boolean ; eol ; indent ; p <- process ; outdent ; return $ List [Item "while", p] }
|
||||
= do { sWHILE ; b <- boolean ; eol ; indent ; p <- process ; outdent ; return $ OcWhile b p }
|
||||
|
||||
monadicOperator
|
||||
= try (do { reservedOp "-" ; return $ Item "-" })
|
||||
<|> try (do { sMINUS ; return $ Item "-" })
|
||||
<|> try (do { reservedOp "~" ; return $ Item "bitnot" })
|
||||
<|> try (do { sBITNOT ; return $ Item "bitnot" })
|
||||
<|> try (do { sNOT ; return $ Item "not" })
|
||||
<|> do { sSIZE ; return $ Item "size" }
|
||||
= try (do { reservedOp "-" ; return $ OcMonSub })
|
||||
<|> try (do { sMINUS ; return $ OcMonSub })
|
||||
<|> try (do { reservedOp "~" ; return $ OcMonBitNot })
|
||||
<|> try (do { sBITNOT ; return $ OcMonBitNot })
|
||||
<|> try (do { sNOT ; return $ OcMonNot })
|
||||
<|> do { sSIZE ; return $ OcSize }
|
||||
<?> "monadicOperator"
|
||||
|
||||
name
|
||||
= do { s <- identifier ; return $ Item s }
|
||||
= do { s <- identifier ; return $ OcName s }
|
||||
<?> "name"
|
||||
|
||||
occamString
|
||||
= lexeme (do { char '"' ; s <- many (noneOf "\"") ; char '"' ; return $ Item ("\"" ++ s ++ "\"") })
|
||||
= lexeme (do { char '"' ; s <- many (noneOf "\"") ; char '"' ; return $ OcLitString s })
|
||||
<?> "string"
|
||||
|
||||
operand
|
||||
= do { v <- operand' ; es <- many (do { sLeft ; e <- expression ; sRight ; return e }) ; return $ foldl (\ v e -> List [Item "sub", v, e]) v es }
|
||||
= do { v <- operand' ; es <- many (do { sLeft ; e <- expression ; sRight ; return e }) ; return $ foldl OcSub v es }
|
||||
<?> "operand"
|
||||
|
||||
operand'
|
||||
|
|
@ -521,70 +519,70 @@ 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 $ List ([Item "call", n] ++ as) })
|
||||
<|> try (do { sBYTESIN ; sLeftR ; o <- operand ; sRightR ; return $ List [Item "bytesin", o] })
|
||||
<|> try (do { sBYTESIN ; sLeftR ; o <- dataType ; sRightR ; return $ List [Item "bytesin", o] })
|
||||
<|> try (do { sOFFSETOF ; sLeftR ; n <- name ; sComma ; f <- fieldName ; sRightR ; return $ List [Item "offsetof", n, f] })
|
||||
<|> try (do { n <- name ; sLeftR ; as <- sepBy expression sComma ; sRightR ; return $ OcCall n as })
|
||||
<|> try (do { sBYTESIN ; sLeftR ; o <- operand ; sRightR ; return $ OcBytesIn o })
|
||||
<|> try (do { sBYTESIN ; sLeftR ; o <- dataType ; sRightR ; return $ OcBytesIn o })
|
||||
<|> try (do { sOFFSETOF ; sLeftR ; n <- name ; sComma ; f <- fieldName ; sRightR ; return $ OcOffsetOf n f })
|
||||
<?> "operand'"
|
||||
|
||||
occamOption
|
||||
= try (do { ces <- sepBy caseExpression sComma ; eol ; indent ; p <- process ; outdent ; return $ List [List ces, p] })
|
||||
<|> try (do { sELSE ; eol ; indent ; p <- process ; outdent ; return $ List [Item "else", p] })
|
||||
<|> do { s <- specification ; o <- occamOption ; return $ List [Item ":", s, o] }
|
||||
= try (do { ces <- sepBy caseExpression sComma ; eol ; indent ; p <- process ; outdent ; return $ OcCaseExps ces p })
|
||||
<|> try (do { sELSE ; eol ; indent ; p <- process ; outdent ; return $ OcElse p })
|
||||
<|> do { s <- specification ; o <- occamOption ; return $ OcDecl s o }
|
||||
<?> "option"
|
||||
|
||||
output
|
||||
= try (do { c <- channel ; sBang ; os <- sepBy1 outputItem sSemi ; eol ; return $ List ([Item "!", c] ++ os) })
|
||||
<|> try (do { c <- channel ; sBang ; t <- tag ; sSemi ; os <- sepBy1 outputItem sSemi ; eol ; return $ List ([Item "!", c, t] ++ os) })
|
||||
<|> try (do { c <- channel ; sBang ; t <- tag ; eol ; return $ List [Item "!", c, t] })
|
||||
<|> do { p <- port ; sBang ; e <- expression ; eol ; return $ List [Item "!", p, e] }
|
||||
= try (do { c <- channel ; sBang ; os <- sepBy1 outputItem sSemi ; eol ; return $ OcOut c os })
|
||||
<|> try (do { c <- channel ; sBang ; t <- tag ; sSemi ; os <- sepBy1 outputItem sSemi ; eol ; return $ OcOutCase c t os })
|
||||
<|> do { c <- channel ; sBang ; t <- tag ; eol ; return $ OcOutCase c t [] }
|
||||
-- <|> do { p <- port ; sBang ; e <- expression ; eol ; return $ List [Item "!", p, e] }
|
||||
<?> "output"
|
||||
|
||||
outputItem
|
||||
= try (do { a <- expression ; sColons ; b <- expression ; return $ List [Item "::", a, b] })
|
||||
= try (do { a <- expression ; sColons ; b <- expression ; return $ OcCounted a b })
|
||||
<|> expression
|
||||
<?> "outputItem"
|
||||
|
||||
parallel
|
||||
= try (do { sPAR ; eol ; indent ; ps <- many1 process ; outdent ; return $ List ([Item "par"] ++ ps) })
|
||||
<|> try (do { sPAR ; r <- replicator ; eol ; indent ; p <- process ; outdent ; return $ List ([Item "par", r, p]) })
|
||||
<|> try (do { sPRI ; sPAR ; eol ; indent ; ps <- many1 process ; outdent ; return $ List ([Item "pri-par"] ++ ps) })
|
||||
<|> try (do { sPRI ; sPAR ; r <- replicator ; eol ; indent ; p <- process ; outdent ; return $ List ([Item "pri-par", r, p]) })
|
||||
= try (do { sPAR ; eol ; indent ; ps <- many1 process ; outdent ; return $ OcPar ps })
|
||||
<|> try (do { sPAR ; r <- replicator ; eol ; indent ; p <- process ; outdent ; return $ OcParRep r p })
|
||||
<|> try (do { sPRI ; sPAR ; eol ; indent ; ps <- many1 process ; outdent ; return $ OcPriPar ps })
|
||||
<|> try (do { sPRI ; sPAR ; r <- replicator ; eol ; indent ; p <- process ; outdent ; return $ OcPriParRep r p })
|
||||
<|> placedpar
|
||||
<?> "parallel"
|
||||
|
||||
placedpar
|
||||
= try (do { sPLACED ; sPAR ; eol ; indent ; ps <- many1 placedpar ; outdent ; return $ List ([Item "placed-par"] ++ ps) })
|
||||
<|> try (do { sPLACED ; sPAR ; r <- replicator ; eol ; indent ; p <- placedpar ; outdent ; return $ List ([Item "placed-par", r, p]) })
|
||||
<|> do { sPROCESSOR ; e <- expression ; eol ; indent ; p <- process ; outdent ; return $ List ([Item "processor", e, p]) }
|
||||
= try (do { sPLACED ; sPAR ; eol ; indent ; ps <- many1 placedpar ; outdent ; return $ OcPlacedPar ps })
|
||||
<|> try (do { sPLACED ; sPAR ; r <- replicator ; eol ; indent ; p <- placedpar ; outdent ; return $ OcPlacedParRep r p })
|
||||
<|> do { sPROCESSOR ; e <- expression ; eol ; indent ; p <- process ; outdent ; return $ OcProcessor e p }
|
||||
<?> "placedpar"
|
||||
|
||||
port
|
||||
= do { v <- port' ; es <- many (do { sLeft ; e <- expression ; sRight ; return e }) ; return $ foldl (\ v e -> List [Item "sub", v, e]) v es }
|
||||
= do { v <- port' ; es <- many (do { sLeft ; e <- expression ; sRight ; return e }) ; return $ foldl OcSub v es }
|
||||
<?> "port"
|
||||
|
||||
port'
|
||||
= try name
|
||||
<|> try (do { sLeft ; n <- port ; sFROM ; e <- expression ; sFOR ; f <- expression ; sRight ; return $ List [Item "sub-from-for", n, e, f] })
|
||||
<|> try (do { sLeft ; n <- port ; sFROM ; e <- expression ; sRight ; return $ List [Item "sub-from", n, e] })
|
||||
<|> do { sLeft ; n <- port ; sFOR ; e <- expression ; sRight ; return $ List [Item "sub-for", n, e] }
|
||||
<|> try (do { sLeft ; n <- port ; sFROM ; e <- expression ; sFOR ; f <- expression ; sRight ; return $ OcSubFromFor n e f })
|
||||
<|> try (do { sLeft ; n <- port ; sFROM ; e <- expression ; sRight ; return $ OcSubFrom n e })
|
||||
<|> do { sLeft ; n <- port ; sFOR ; e <- expression ; sRight ; return $ OcSubFor n e }
|
||||
<?> "port'"
|
||||
|
||||
portType
|
||||
= try (do { sPORT ; sOF ; p <- protocol ; return $ List [Item "port-of", p] })
|
||||
<|> do { sLeft ; s <- expression ; sRight ; t <- portType ; return $ List [Item "array", s, t] }
|
||||
= try (do { sPORT ; sOF ; p <- protocol ; return $ OcPortOf p })
|
||||
<|> do { sLeft ; s <- expression ; sRight ; t <- portType ; return $ OcArray s t }
|
||||
<?> "portType"
|
||||
|
||||
procInstance
|
||||
= do { n <- name ; sLeftR ; as <- sepBy actual sComma ; sRightR ; eol ; return $ List (n : as) }
|
||||
= do { n <- name ; sLeftR ; as <- sepBy actual sComma ; sRightR ; eol ; return $ OcProcCall n as }
|
||||
<?> "procInstance"
|
||||
|
||||
process
|
||||
= try assignment
|
||||
<|> try input
|
||||
<|> try output
|
||||
<|> try (do { sSKIP ; eol ; return $ Item "skip" })
|
||||
<|> try (do { sSTOP ; eol ; return $ Item "stop" })
|
||||
<|> try (do { sSKIP ; eol ; return $ OcSkip })
|
||||
<|> try (do { sSTOP ; eol ; return $ OcStop })
|
||||
<|> try occamSequence
|
||||
<|> try conditional
|
||||
<|> try selection
|
||||
|
|
@ -593,8 +591,8 @@ process
|
|||
<|> try alternation
|
||||
<|> try caseInput
|
||||
<|> try procInstance
|
||||
<|> try (do { s <- specification ; p <- process ; return $ List [Item ":", s, p] })
|
||||
<|> do { a <- allocation ; p <- process ; return $ List [Item ":", a, p] }
|
||||
<|> try (do { s <- specification ; p <- process ; return $ OcDecl s p })
|
||||
<|> do { a <- allocation ; p <- process ; return $ OcDecl a p }
|
||||
<?> "process"
|
||||
|
||||
protocol
|
||||
|
|
@ -603,16 +601,16 @@ protocol
|
|||
<?> "protocol"
|
||||
|
||||
real
|
||||
= try (do { l <- digits ; char '.' ; r <- digits ; char 'e' ; e <- lexeme occamExponent ; return $ Item (l ++ "." ++ r ++ "e" ++ e) })
|
||||
<|> do { l <- digits ; char '.' ; r <- lexeme digits ; return $ Item (l ++ "." ++ r) }
|
||||
= try (do { l <- digits ; char '.' ; r <- digits ; char 'e' ; e <- lexeme occamExponent ; return $ OcLitReal (l ++ "." ++ r ++ "e" ++ e) })
|
||||
<|> do { l <- digits ; char '.' ; r <- lexeme digits ; return $ OcLitReal (l ++ "." ++ r) }
|
||||
<?> "real"
|
||||
|
||||
replicator
|
||||
= do { n <- name ; sEq ; b <- base ; sFOR ; c <- occamCount ; return $ List [Item "for", n, b, c] }
|
||||
= do { n <- name ; sEq ; b <- base ; sFOR ; c <- occamCount ; return $ OcFor n b c }
|
||||
<?> "replicator"
|
||||
|
||||
selection
|
||||
= do { sCASE ; s <- selector ; eol ; indent ; os <- many1 occamOption ; outdent ; return $ List ([Item "case", s] ++ os) }
|
||||
= do { sCASE ; s <- selector ; eol ; indent ; os <- many1 occamOption ; outdent ; return $ OcCase s os }
|
||||
<?> "selection"
|
||||
|
||||
selector
|
||||
|
|
@ -620,18 +618,18 @@ selector
|
|||
<?> "selector"
|
||||
|
||||
occamSequence
|
||||
= try (do { sSEQ ; eol ; indent ; ps <- many1 process ; outdent ; return $ List ([Item "seq"] ++ ps) })
|
||||
<|> do { sSEQ ; r <- replicator ; eol ; indent ; p <- process ; outdent ; return $ List ([Item "seq", r, p]) }
|
||||
= try (do { sSEQ ; eol ; indent ; ps <- many1 process ; outdent ; return $ OcSeq ps })
|
||||
<|> do { sSEQ ; r <- replicator ; eol ; indent ; p <- process ; outdent ; return $ OcSeqRep r p }
|
||||
<?> "sequence"
|
||||
|
||||
sequentialProtocol
|
||||
= do { l <- sepBy1 simpleProtocol sSemi ; return $ List l }
|
||||
= do { l <- sepBy1 simpleProtocol sSemi ; return $ l }
|
||||
<?> "sequentialProtocol"
|
||||
|
||||
simpleProtocol
|
||||
= try (do { l <- dataType ; sColons ; sLeft ; sRight ; r <- dataType ; return $ List [Item "::", l, r] })
|
||||
= try (do { l <- dataType ; sColons ; sLeft ; sRight ; r <- dataType ; return $ OcCounted l r })
|
||||
<|> try dataType
|
||||
<|> do { try (sANY) ; return $ Item "any" }
|
||||
<|> do { try (sANY) ; return $ OcAny }
|
||||
<?> "simpleProtocol"
|
||||
|
||||
specification
|
||||
|
|
@ -640,36 +638,38 @@ specification
|
|||
<|> definition
|
||||
<?> "specification"
|
||||
|
||||
specifier :: Parser Node
|
||||
specifier
|
||||
= try dataType
|
||||
<|> try channelType
|
||||
<|> try timerType
|
||||
<|> try portType
|
||||
<|> try (do { sLeft ; sRight ; s <- specifier ; return $ List [Item "array", s] })
|
||||
<|> do { sLeft ; e <- expression ; sRight ; s <- specifier ; return $ List [Item "array", e, s] }
|
||||
<|> try (do { sLeft ; sRight ; s <- specifier ; return $ OcArrayUnsized s })
|
||||
<|> do { sLeft ; e <- expression ; sRight ; s <- specifier ; return $ OcArray e s }
|
||||
<?> "specifier"
|
||||
|
||||
structuredType
|
||||
= try (do { sRECORD ; eol ; indent ; fs <- many1 structuredTypeField ; outdent ; return $ List ([Item "record"] ++ fs) })
|
||||
<|> do { sPACKED ; sRECORD ; eol ; indent ; fs <- many1 structuredTypeField ; outdent ; return $ List ([Item "packed-record"] ++ fs) }
|
||||
= try (do { sRECORD ; eol ; indent ; fs <- many1 structuredTypeField ; outdent ; return $ OcRecord fs })
|
||||
<|> do { sPACKED ; sRECORD ; eol ; indent ; fs <- many1 structuredTypeField ; outdent ; return $ OcPackedRecord 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 $ List (t : fs) }
|
||||
= do { t <- dataType ; fs <- many1 fieldName ; sColon ; eol ; return $ OcFields t fs }
|
||||
<?> "structuredTypeField"
|
||||
|
||||
-- XXX (<name> <string>) not (<string> <name>) in case 2 for consistency with literal
|
||||
-- i.e. array literal
|
||||
table
|
||||
= do { v <- table' ; es <- many (do { sLeft ; e <- expression ; sRight ; return e }) ; return $ foldl (\ v e -> List [Item "sub", v, e]) v es }
|
||||
= do { v <- table' ; es <- many (do { sLeft ; e <- expression ; sRight ; return e }) ; return $ foldl OcSub v es }
|
||||
<?> "table"
|
||||
|
||||
table'
|
||||
= try occamString
|
||||
<|> try (do { s <- occamString ; sLeftR ; n <- name ; sRightR ; return $ List [n, s] })
|
||||
<|> try (do { sLeft ; es <- sepBy1 expression sComma ; sRight ; return $ List es })
|
||||
<|> try (do { sLeft ; n <- table ; sFROM ; e <- expression ; sFOR ; f <- expression ; sRight ; return $ List [Item "sub-from-for", n, e, f] })
|
||||
<|> try (do { sLeft ; n <- table ; sFROM ; e <- expression ; sRight ; return $ List [Item "sub-from", n, e] })
|
||||
<|> try (do { sLeft ; n <- table ; sFOR ; e <- expression ; sRight ; return $ List [Item "sub-for", n, e] })
|
||||
<|> try (do { s <- occamString ; sLeftR ; n <- name ; sRightR ; return $ OcTypedLit n s })
|
||||
<|> try (do { sLeft ; es <- sepBy1 expression sComma ; sRight ; return $ OcLitArray es })
|
||||
<|> try (do { sLeft ; n <- table ; sFROM ; e <- expression ; sFOR ; f <- expression ; sRight ; return $ OcSubFromFor n e f })
|
||||
<|> try (do { sLeft ; n <- table ; sFROM ; e <- expression ; sRight ; return $ OcSubFrom n e })
|
||||
<|> try (do { sLeft ; n <- table ; sFOR ; e <- expression ; sRight ; return $ OcSubFor n e })
|
||||
<?> "table'"
|
||||
|
||||
tag
|
||||
|
|
@ -677,56 +677,56 @@ tag
|
|||
<?> "tag"
|
||||
|
||||
taggedList
|
||||
= try (do { t <- tag ; sSemi ; is <- sepBy1 inputItem sSemi ; return $ List ([t] ++ is) })
|
||||
<|> do { t <- tag ; return $ List [t] }
|
||||
= try (do { t <- tag ; sSemi ; is <- sepBy1 inputItem sSemi ; return $ OcTag t is })
|
||||
<|> do { t <- tag ; return $ OcTag t [] }
|
||||
<?> "taggedList"
|
||||
|
||||
taggedProtocol
|
||||
= try (do { t <- tag ; eol ; return $ List [t] })
|
||||
<|> try (do { t <- tag ; sSemi ; sp <- sequentialProtocol ; eol ; return $ List (t : case sp of List ps -> ps) })
|
||||
= try (do { t <- tag ; eol ; return $ OcTag t [] })
|
||||
<|> try (do { t <- tag ; sSemi ; sp <- sequentialProtocol ; eol ; return $ OcTag t sp })
|
||||
|
||||
timer
|
||||
= do { v <- timer' ; es <- many (do { sLeft ; e <- expression ; sRight ; return e }) ; return $ foldl (\ v e -> List [Item "sub", v, e]) v es }
|
||||
= do { v <- timer' ; es <- many (do { sLeft ; e <- expression ; sRight ; return e }) ; return $ foldl OcSub v es }
|
||||
<?> "timer"
|
||||
|
||||
timer'
|
||||
= try name
|
||||
<|> try (do { sLeft ; n <- timer ; sFROM ; e <- expression ; sFOR ; f <- expression ; sRight ; return $ List [Item "sub-from-for", n, e, f] })
|
||||
<|> try (do { sLeft ; n <- timer ; sFROM ; e <- expression ; sRight ; return $ List [Item "sub-from", n, e] })
|
||||
<|> do { sLeft ; n <- timer ; sFOR ; e <- expression ; sRight ; return $ List [Item "sub-for", n, e] }
|
||||
<|> try (do { sLeft ; n <- timer ; sFROM ; e <- expression ; sFOR ; f <- expression ; sRight ; return $ OcSubFromFor n e f })
|
||||
<|> try (do { sLeft ; n <- timer ; sFROM ; e <- expression ; sRight ; return $ OcSubFrom n e })
|
||||
<|> do { sLeft ; n <- timer ; sFOR ; e <- expression ; sRight ; return $ OcSubFor n e }
|
||||
<?> "timer'"
|
||||
|
||||
timerInput
|
||||
= try (do { c <- channel ; sQuest ; v <- variable ; eol ; return $ List [Item "?", c, v] })
|
||||
= try (do { c <- channel ; sQuest ; v <- variable ; eol ; return $ OcIn c [v] })
|
||||
<?> "timerInput"
|
||||
|
||||
timerType
|
||||
= try (do { sTIMER ; return $ Item "timer" })
|
||||
<|> do { sLeft ; s <- expression ; sRight ; t <- timerType ; return $ List [Item "array", s, t] }
|
||||
= try (do { sTIMER ; return $ OcTimer })
|
||||
<|> do { sLeft ; s <- expression ; sRight ; t <- timerType ; return $ OcArray s t }
|
||||
<?> "timerType"
|
||||
|
||||
valueProcess
|
||||
= try (do { sVALOF ; eol ; indent ; p <- process ; sRESULT ; el <- expressionList ; eol ; outdent ; return $ List [Item "valof", p, el] })
|
||||
<|> do { s <- specification ; v <- valueProcess ; return $ List [Item ":", s, v] }
|
||||
= try (do { sVALOF ; eol ; indent ; p <- process ; sRESULT ; el <- expressionList ; eol ; outdent ; return $ OcValOf p el })
|
||||
<|> do { s <- specification ; v <- valueProcess ; return $ OcDecl s v }
|
||||
|
||||
variable
|
||||
= do { v <- variable' ; es <- many (do { sLeft ; e <- expression ; sRight ; return e }) ; return $ foldl (\ v e -> List [Item "sub", v, e]) v es }
|
||||
= do { v <- variable' ; es <- many (do { sLeft ; e <- expression ; sRight ; return e }) ; return $ foldl OcSub v es }
|
||||
<?> "variable"
|
||||
|
||||
variable'
|
||||
= try name
|
||||
<|> try (do { sLeft ; n <- variable ; sFROM ; e <- expression ; sFOR ; f <- expression ; sRight ; return $ List [Item "sub-from-for", n, e, f] })
|
||||
<|> try (do { sLeft ; n <- variable ; sFROM ; e <- expression ; sRight ; return $ List [Item "sub-from", n, e] })
|
||||
<|> do { sLeft ; n <- variable ; sFOR ; e <- expression ; sRight ; return $ List [Item "sub-for", n, e] }
|
||||
<|> try (do { sLeft ; n <- variable ; sFROM ; e <- expression ; sFOR ; f <- expression ; sRight ; return $ OcSubFromFor n e f })
|
||||
<|> try (do { sLeft ; n <- variable ; sFROM ; e <- expression ; sRight ; return $ OcSubFrom n e })
|
||||
<|> do { sLeft ; n <- variable ; sFOR ; e <- expression ; sRight ; return $ OcSubFor n e }
|
||||
<?> "variable'"
|
||||
|
||||
variableList
|
||||
= do { vs <- sepBy1 variable sComma ; return $ List vs }
|
||||
= do { vs <- sepBy1 variable sComma ; return $ vs }
|
||||
<?> "variableList"
|
||||
|
||||
variant
|
||||
= try (do { t <- taggedList ; eol ; indent ; p <- process ; outdent ; return $ List [t, p] })
|
||||
<|> do { s <- specification ; v <- variant ; return $ List [Item ":", s, v] }
|
||||
= try (do { t <- taggedList ; eol ; indent ; p <- process ; outdent ; return $ OcVariant t p })
|
||||
<|> do { s <- specification ; v <- variant ; return $ OcDecl s v }
|
||||
<?> "variant"
|
||||
|
||||
-- -------------------------------------------------------------
|
||||
|
|
@ -778,6 +778,3 @@ prepare d = flatten $ lines (d ++ "\nSKIP\n")
|
|||
parseFile fn = do d <- readFile fn
|
||||
parseTest process (prepare d)
|
||||
|
||||
main = do d <- getContents
|
||||
parseTest process (prepare d)
|
||||
|
||||
|
|
|
|||
140
fco/Tree.hs
Normal file
140
fco/Tree.hs
Normal file
|
|
@ -0,0 +1,140 @@
|
|||
-- Tree datatype and operations
|
||||
|
||||
module Tree where
|
||||
|
||||
data Node =
|
||||
OcDecl Node Node
|
||||
| OcAlt [Node]
|
||||
| OcAltRep Node Node
|
||||
| OcPriAlt [Node]
|
||||
| OcPriAltRep Node Node
|
||||
| OcIn Node [Node]
|
||||
-- e.g. OcInCase (OcName "c") [OcVariant .., OcVariant ..]
|
||||
| OcVariant Node Node
|
||||
| OcInCase Node [Node]
|
||||
| OcInCaseGuard Node Node [Node]
|
||||
-- FIXME can turn into OcInCase ... (OcVariant .. OcSkip)
|
||||
| OcInTag Node Node
|
||||
| OcOut Node [Node]
|
||||
| OcOutCase Node Node [Node]
|
||||
| OcExpList [Node]
|
||||
| OcAssign [Node] Node
|
||||
| OcIf [Node]
|
||||
| OcIfRep Node Node
|
||||
| OcInAfter Node Node
|
||||
| OcWhile Node Node
|
||||
| OcPar [Node]
|
||||
| OcParRep Node Node
|
||||
| OcPriPar [Node]
|
||||
| OcPriParRep Node Node
|
||||
| OcPlacedPar [Node]
|
||||
| OcPlacedParRep Node Node
|
||||
| OcProcessor Node Node
|
||||
| OcSkip
|
||||
| OcStop
|
||||
| OcCase Node [Node]
|
||||
| OcSeq [Node]
|
||||
| OcSeqRep Node Node
|
||||
| OcProcCall Node [Node]
|
||||
|
||||
| OcVars Node [Node]
|
||||
| OcIs Node Node
|
||||
| OcIsType Node Node Node
|
||||
| OcValIs Node Node
|
||||
| OcValIsType Node Node Node
|
||||
| OcPlace Node Node
|
||||
|
||||
| OcDataType Node Node
|
||||
| OcRecord [Node]
|
||||
| OcPackedRecord [Node]
|
||||
| OcFields Node [Node]
|
||||
| OcProtocol Node [Node]
|
||||
| OcTaggedProtocol Node [Node]
|
||||
| OcTag Node [Node]
|
||||
-- e.g. OcProc (OcName "out.string") [OcFormal OcInt (OcName "x"), OcFormal OcBool (OcName "y")]
|
||||
| OcFormal Node Node
|
||||
| OcProc Node [Node] Node
|
||||
| OcFunc Node [Node] [Node] Node
|
||||
| OcFuncIs Node [Node] [Node] Node
|
||||
| OcRetypes Node Node Node
|
||||
| OcValRetypes Node Node Node
|
||||
| OcReshapes Node Node Node
|
||||
| OcValReshapes Node Node Node
|
||||
| OcValOf Node Node
|
||||
|
||||
| OcSub Node Node
|
||||
| OcSubFromFor Node Node Node
|
||||
| OcSubFrom Node Node
|
||||
| OcSubFor Node Node
|
||||
|
||||
| OcCaseExps [Node] Node
|
||||
| OcElse Node
|
||||
|
||||
| OcFor Node Node Node
|
||||
|
||||
| OcConv Node Node
|
||||
| OcRound Node Node
|
||||
| OcTrunc Node Node
|
||||
| OcAdd Node Node
|
||||
| OcSubtr Node Node
|
||||
| OcMul Node Node
|
||||
| OcDiv Node Node
|
||||
| OcMod Node Node
|
||||
| OcRem Node Node
|
||||
| OcPlus Node Node
|
||||
| OcMinus Node Node
|
||||
| OcTimes Node Node
|
||||
| OcBitAnd Node Node
|
||||
| OcBitOr Node Node
|
||||
| OcBitXor Node Node
|
||||
| OcAnd Node Node
|
||||
| OcOr Node Node
|
||||
| OcEq Node Node
|
||||
| OcNEq Node Node
|
||||
| OcLess Node Node
|
||||
| OcMore Node Node
|
||||
| OcLessEq Node Node
|
||||
| OcMoreEq Node Node
|
||||
| OcAfter Node Node
|
||||
| OcMonSub Node
|
||||
| OcMonBitNot Node
|
||||
| OcMonNot Node
|
||||
| OcMostPos Node
|
||||
| OcMostNeg Node
|
||||
| OcSize Node
|
||||
| OcCall Node [Node]
|
||||
| OcBytesIn Node
|
||||
| OcOffsetOf Node Node
|
||||
|
||||
| OcGuarded Node Node
|
||||
|
||||
| OcVal Node
|
||||
| OcChanOf Node
|
||||
| OcPortOf Node
|
||||
| OcTimer
|
||||
| OcArray Node Node
|
||||
| OcArrayUnsized Node
|
||||
| OcCounted Node Node
|
||||
| OcBool
|
||||
| OcByte
|
||||
| OcInt
|
||||
| OcInt16
|
||||
| OcInt32
|
||||
| OcInt64
|
||||
| OcReal32
|
||||
| OcReal64
|
||||
| OcAny
|
||||
|
||||
| OcTypedLit Node Node
|
||||
| OcLitReal String
|
||||
| OcLitInt String
|
||||
| OcLitHex String
|
||||
| OcLitByte String
|
||||
| OcLitString String
|
||||
| OcLitArray [Node]
|
||||
| OcTrue
|
||||
| OcFalse
|
||||
| OcName String
|
||||
|
||||
deriving (Show, Eq)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user