suzanne.soy/tock-mirror
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Rework parser to commit sooner

Browse Source 
Essentially just move around a lot of "try"s, and make the flattening code
preserve lines. This lets it give more useful error messages when it can't
parse something.
This commit is contained in:
Adam Sampson 2006-09-07 02:38:51 +00:00
parent 02abee3d7f
commit 344add99e9
5 changed files with 338 additions and 179 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

339
fco/Parse.hs
View File

@ -1,6 +1,6 @@
-- Parse occam code -- Parse occam code
module Parse (parseSourceFile) where module Parse (parseSourceFile, prepare) where
import Data.List import Data.List
import Text.ParserCombinators.Parsec import Text.ParserCombinators.Parsec
@ -20,7 +20,8 @@ occamStyle
, P.nestedComments = False , P.nestedComments = False
, P.identStart = letter , P.identStart = letter
, P.identLetter = alphaNum <|> char '.' , P.identLetter = alphaNum <|> char '.'
, P.opStart = oneOf "+-/*" , P.opStart = oneOf "+-*/\\>=<~"
, P.opLetter = oneOf "/\\>=<"
, P.reservedOpNames= [ , P.reservedOpNames= [
"+", "+",
"-", "-",
@ -121,20 +122,19 @@ identifier= P.identifier lexer
reserved = P.reserved lexer reserved = P.reserved lexer
reservedOp= P.reservedOp lexer reservedOp= P.reservedOp lexer
-- XXX these should be operators sLeft = try $ symbol "["
sLeft = symbol "[" sRight = try $ symbol "]"
sRight = symbol "]" sLeftR = try $ symbol "("
sLeftR = symbol "(" sRightR = try $ symbol ")"
sRightR = symbol ")" sAssign = try $ symbol ":="
sAssign = symbol ":=" sColon = try $ symbol ":"
sColon = symbol ":" sColons = try $ symbol "::"
sColons = symbol "::" sComma = try $ symbol ","
sComma = symbol "," sSemi = try $ symbol ";"
sSemi = symbol ";" sAmp = try $ symbol "&"
sAmp = symbol "&" sQuest = try $ symbol "?"
sQuest = symbol "?" sBang = try $ symbol "!"
sBang = symbol "!" sEq = try $ symbol "="
sEq = symbol "="
sAFTER = reserved "AFTER" sAFTER = reserved "AFTER"
sALT = reserved "ALT" sALT = reserved "ALT"
@ -209,27 +209,20 @@ eol = symbol "@"
-- These productions are based on the syntax in the occam2.1 manual. -- These productions are based on the syntax in the occam2.1 manual.
-- The way productions should work is that each production should only consume input if it's sure that it's unambiguous.
abbreviation abbreviation
= try (do { n <- name ; sIS ; v <- variable ; sColon ; eol ; return $ OcIs 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 { 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 }) <|> do { sVAL ;
<|> try (do { sVAL ; s <- specifier ; n <- name ; sIS ; e <- expression ; sColon ; eol ; return $ OcValIsType s n e }) try (do { n <- name ; sIS ; e <- expression ; sColon ; eol ; return $ OcValIs n e })
-- <|> try (do { n <- name ; sIS ; v <- channel ; sColon ; eol ; return $ List [Item "is", n, v] }) <|> do { s <- specifier ; n <- name ; sIS ; e <- expression ; sColon ; eol ; return $ OcValIsType s n e } }
-- <|> 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" <?> "abbreviation"
actual actual
= try expression = expression
<|> try variable <|> variable
<|> try channel <|> channel
<|> try timer
<|> port
<?> "actual" <?> "actual"
allocation allocation
@ -237,17 +230,19 @@ allocation
<?> "allocation" <?> "allocation"
alternation alternation
= try (do { sALT ; eol ; indent ; as <- many1 alternative ; outdent ; return $ OcAlt as }) = do { sALT ;
<|> try (do { sALT ; r <- replicator ; eol ; indent ; a <- alternative ; outdent ; return $ OcAltRep r a }) do { eol ; indent ; as <- many1 alternative ; outdent ; return $ OcAlt as }
<|> try (do { sPRI ; sALT ; eol ; indent ; as <- many1 alternative ; outdent ; return $ OcPriAlt as }) <|> do { r <- replicator ; eol ; indent ; a <- alternative ; outdent ; return $ OcAltRep r a } }
<|> do { sPRI ; sALT ; r <- replicator ; eol ; indent ; a <- alternative ; outdent ; return $ OcPriAltRep r a } <|> do { sPRI ; sALT ;
do { eol ; indent ; as <- many1 alternative ; outdent ; return $ OcPriAlt as }
<|> do { r <- replicator ; eol ; indent ; a <- alternative ; outdent ; return $ OcPriAltRep r a } }
<?> "alternation" <?> "alternation"
alternative alternative
= try guardedAlternative = guardedAlternative
<|> try alternation <|> alternation
<|> 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 }) <|> try (do { b <- boolean ; sAmp ; c <- channel ; sQuest ; sCASE ; eol ; indent ; vs <- many1 variant ; outdent ; return $ OcInCaseGuard b c vs })
<|> try (do { c <- channel ; sQuest ; sCASE ; eol ; indent ; vs <- many1 variant ; outdent ; return $ OcInCase c vs })
<|> do { s <- specification ; a <- alternative ; return $ OcDecl s a } <|> do { s <- specification ; a <- alternative ; return $ OcDecl s a }
<?> "alternative" <?> "alternative"
@ -275,6 +270,8 @@ caseInput
= do { c <- channel ; sQuest ; sCASE ; eol ; indent ; vs <- many1 variant ; outdent ; return $ OcInCase c vs } = do { c <- channel ; sQuest ; sCASE ; eol ; indent ; vs <- many1 variant ; outdent ; return $ OcInCase c vs }
<?> "caseInput" <?> "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 channel
= do { v <- channel' ; es <- many (do { sLeft ; e <- expression ; sRight ; return e }) ; return $ foldl OcSub v es } = do { v <- channel' ; es <- many (do { sLeft ; e <- expression ; sRight ; return e }) ; return $ foldl OcSub v es }
<?> "channel" <?> "channel"
@ -286,32 +283,35 @@ channel'
<|> do { sLeft ; n <- channel ; sFOR ; e <- expression ; sRight ; return $ OcSubFor n e } <|> do { sLeft ; n <- channel ; sFOR ; e <- expression ; sRight ; return $ OcSubFor n e }
<?> "channel'" <?> "channel'"
-- FIXME should probably make CHAN INT work, since that'd be trivial...
channelType channelType
= try (do { sCHAN ; sOF ; p <- protocol ; return $ OcChanOf p }) = do { sCHAN ; sOF ; p <- protocol ; return $ OcChanOf p }
<|> do { sLeft ; s <- expression ; sRight ; t <- channelType ; return $ OcArray s t } <|> try (do { sLeft ; s <- expression ; sRight ; t <- channelType ; return $ OcArray s t })
<?> "channelType" <?> "channelType"
-- FIXME this isn't at all the right way to return the character!
character character
= try (do { char '*' ; char '#' ; a <- hexDigit ; b <- hexDigit ; return $ ['*', '#', a, b] }) = try (do { char '*' ;
<|> try (do { char '*' ; c <- anyChar ; return $ ['*', c] }) do { char '#' ; a <- hexDigit ; b <- hexDigit ; return $ ['*', '#', a, b] }
<|> do { c <- anyChar ; return $ ['*', c] } })
<|> do { c <- anyChar ; return $ [c] } <|> do { c <- anyChar ; return $ [c] }
<?> "character" <?> "character"
occamChoice occamChoice
= try guardedChoice = guardedChoice
<|> try conditional <|> conditional
<|> do { s <- specification ; c <- occamChoice ; return $ OcDecl s c } <|> do { s <- try specification ; c <- occamChoice ; return $ OcDecl s c }
<?> "choice" <?> "choice"
conditional conditional
= try (do { sIF ; eol ; indent ; cs <- many1 occamChoice ; outdent ; return $ OcIf cs }) = do { sIF ;
<|> do { sIF ; r <- replicator ; eol ; indent ; c <- occamChoice ; outdent ; return $ OcIfRep r c } do { eol ; indent ; cs <- many1 occamChoice ; outdent ; return $ OcIf cs }
<|> do { r <- replicator ; eol ; indent ; c <- occamChoice ; outdent ; return $ OcIfRep r c } }
<?> "conditional" <?> "conditional"
conversion conversion
= try (do { t <- dataType ; o <- operand ; return $ OcConv t o }) = do t <- dataType
<|> try (do { t <- dataType ; sROUND ; o <- operand ; return $ OcRound t o }) do { sROUND ; o <- operand ; return $ OcRound t o } <|> do { sTRUNC ; o <- operand ; return $ OcTrunc t o } <|> do { o <- operand ; return $ OcConv t o }
<|> do { t <- dataType ; sTRUNC ; o <- operand ; return $ OcTrunc t o }
<?> "conversion" <?> "conversion"
occamCount occamCount
@ -319,14 +319,14 @@ occamCount
<?> "count" <?> "count"
dataType dataType
= do { try sBOOL ; return $ OcBool } = do { sBOOL ; return $ OcBool }
<|> do { try sBYTE ; return $ OcByte } <|> do { sBYTE ; return $ OcByte }
<|> do { try sINT ; return $ OcInt } <|> do { sINT ; return $ OcInt }
<|> do { try sINT16 ; return $ OcInt16 } <|> do { sINT16 ; return $ OcInt16 }
<|> do { try sINT32 ; return $ OcInt32 } <|> do { sINT32 ; return $ OcInt32 }
<|> do { try sINT64 ; return $ OcInt64 } <|> do { sINT64 ; return $ OcInt64 }
<|> do { try sREAL32 ; return $ OcReal32 } <|> do { sREAL32 ; return $ OcReal32 }
<|> do { try sREAL64 ; return $ OcReal64 } <|> do { sREAL64 ; return $ OcReal64 }
<|> try (do { sLeft ; s <- expression ; sRight ; t <- dataType ; return $ OcArray s t }) <|> try (do { sLeft ; s <- expression ; sRight ; t <- dataType ; return $ OcArray s t })
<|> name <|> name
<?> "data type" <?> "data type"
@ -340,61 +340,58 @@ declType
-- FIXME this originally had four lines like this, one for each of the above; -- 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 -- it might be nicer to generate a different Node for each type of declaration
declaration declaration
= try (do { d <- declType ; ns <- sepBy1 name sComma ; sColon ; eol ; return $ OcVars d ns }) = do { d <- declType ; ns <- sepBy1 name sComma ; sColon ; eol ; return $ OcVars d ns }
<?> "declaration" <?> "declaration"
definition definition
= try (do { sDATA ; sTYPE ; n <- name ; sIS ; t <- dataType ; sColon ; eol ; return $ OcDataType n t }) = do { sDATA ; sTYPE ; n <- name ;
<|> try (do { sDATA ; sTYPE ; n <- name ; eol ; indent ; t <- structuredType ; outdent ; sColon ; eol ; return $ OcDataType n t }) do {sIS ; t <- dataType ; sColon ; eol ; return $ OcDataType n t }
<|> try (do { sPROTOCOL ; n <- name ; sIS ; p <- simpleProtocol ; sColon ; eol ; return $ OcProtocol n [p] }) <|> do { eol ; indent ; t <- structuredType ; outdent ; sColon ; eol ; return $ OcDataType n t } }
<|> try (do { sPROTOCOL ; n <- name ; sIS ; p <- sequentialProtocol ; sColon ; eol ; return $ OcProtocol n p }) <|> do { sPROTOCOL ; n <- name ;
<|> try (do { sPROTOCOL ; n <- name ; eol ; indent ; sCASE ; eol ; indent ; ps <- many1 taggedProtocol ; outdent ; outdent ; sColon ; eol ; return $ OcTaggedProtocol n ps }) do { sIS ; p <- sequentialProtocol ; sColon ; eol ; return $ OcProtocol n p }
<|> try (do { sPROC ; n <- name ; fs <- formalList ; eol ; indent ; p <- process ; outdent ; sColon ; eol ; return $ OcProc n fs p }) <|> do { eol ; indent ; sCASE ; eol ; indent ; ps <- many1 taggedProtocol ; outdent ; outdent ; sColon ; eol ; return $ OcTaggedProtocol n ps } }
<|> try (do { rs <- sepBy1 dataType sComma ; (n, fs) <- functionHeader ; eol ; indent ; vp <- valueProcess ; outdent ; sColon ; eol ; return $ OcFunc n rs fs vp }) <|> 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 ; sIS ; el <- expressionList ; sColon ; eol ; return $ OcFuncIs n rs fs el }) -- Again, don't know why this has to be entirely try ()...
<|> try (do { s <- specifier ; n <- name ; sRETYPES ; v <- variable ; sColon ; eol ; return $ OcRetypes s n v }) <|> try (do { rs <- sepBy1 dataType sComma ; (n, fs) <- functionHeader ;
<|> try (do { sVAL ; s <- specifier ; n <- name ; sRETYPES ; v <- variable ; sColon ; eol ; return $ OcValRetypes s n v }) do { sIS ; el <- expressionList ; sColon ; eol ; return $ OcFuncIs n rs fs el }
-- <|> try (do { s <- specifier ; n <- name ; sRETYPES ; v <- channel ; sColon ; eol ; return $ List [Item "retypes", s, n, v] }) <|> do { eol ; indent ; vp <- valueProcess ; outdent ; sColon ; eol ; return $ OcFunc n rs fs vp } })
-- <|> try (do { s <- specifier ; n <- name ; sRETYPES ; v <- port ; sColon ; eol ; return $ List [Item "retypes", s, n, v] }) <|> try (do { s <- specifier ; n <- name ;
<|> try (do { s <- specifier ; n <- name ; sRESHAPES ; v <- variable ; sColon ; eol ; return $ OcReshapes s n v }) do { sRETYPES ; v <- variable ; sColon ; eol ; return $ OcRetypes s n v }
<|> try (do { sVAL ; s <- specifier ; n <- name ; sRESHAPES ; v <- variable ; sColon ; eol ; return $ OcValReshapes s n v }) <|> do { try sRESHAPES ; v <- variable ; sColon ; eol ; return $ OcReshapes s n v } })
-- <|> try (do { s <- specifier ; n <- name ; sRESHAPES ; v <- channel ; sColon ; eol ; return $ List [Item "reshapes", s, n, v] }) <|> do { sVAL ; s <- specifier ; n <- name ;
-- <|> do { s <- specifier ; n <- name ; sRESHAPES ; v <- port ; sColon ; eol ; return $ List [Item "reshapes", s, n, v] } do { sRETYPES ; v <- variable ; sColon ; eol ; return $ OcValRetypes s n v }
<|> do { sRESHAPES ; v <- variable ; sColon ; eol ; return $ OcValReshapes s n v } }
<?> "definition" <?> "definition"
delayedInput
= try (do { c <- channel ; sQuest ; sAFTER ; e <- expression ; eol ; return $ OcInAfter c e })
<?> "delayedInput"
-- NB does not return an SExp -- NB does not return an SExp
digits digits
= many1 digit = many1 digit
<?> "digits" <?> "digits"
dyadicOperator dyadicOperator
= try (do { reservedOp "+" ; return $ OcAdd }) = do { reservedOp "+" ; return $ OcAdd }
<|> try (do { reservedOp "-" ; return $ OcSubtr }) <|> do { reservedOp "-" ; return $ OcSubtr }
<|> try (do { reservedOp "*" ; return $ OcMul }) <|> do { reservedOp "*" ; return $ OcMul }
<|> try (do { reservedOp "/" ; return $ OcDiv }) <|> do { reservedOp "/" ; return $ OcDiv }
<|> try (do { reservedOp "\\" ; return $ OcMod }) <|> do { reservedOp "\\" ; return $ OcMod }
<|> try (do { sREM ; return $ OcRem }) <|> do { sREM ; return $ OcRem }
<|> try (do { sPLUS ; return $ OcPlus }) <|> do { sPLUS ; return $ OcPlus }
<|> try (do { sMINUS ; return $ OcMinus }) <|> do { sMINUS ; return $ OcMinus }
<|> try (do { sTIMES ; return $ OcTimes }) <|> do { sTIMES ; return $ OcTimes }
<|> try (do { reservedOp "/\\" ; return $ OcBitAnd }) <|> do { reservedOp "/\\" ; return $ OcBitAnd }
<|> try (do { reservedOp "\\/" ; return $ OcBitOr }) <|> do { reservedOp "\\/" ; return $ OcBitOr }
<|> try (do { reservedOp "><" ; return $ OcBitXor }) <|> do { reservedOp "><" ; return $ OcBitXor }
<|> try (do { sBITAND ; return $ OcBitAnd }) <|> do { sBITAND ; return $ OcBitAnd }
<|> try (do { sBITOR ; return $ OcBitOr }) <|> do { sBITOR ; return $ OcBitOr }
<|> try (do { sAND ; return $ OcAnd }) <|> do { sAND ; return $ OcAnd }
<|> try (do { sOR ; return $ OcOr }) <|> do { sOR ; return $ OcOr }
<|> try (do { reservedOp "=" ; return $ OcEq }) <|> do { reservedOp "=" ; return $ OcEq }
<|> try (do { reservedOp "<>" ; return $ OcNEq }) <|> do { reservedOp "<>" ; return $ OcNEq }
<|> try (do { reservedOp "<" ; return $ OcLess }) <|> do { reservedOp "<" ; return $ OcLess }
<|> try (do { reservedOp ">" ; return $ OcMore }) <|> do { reservedOp ">" ; return $ OcMore }
<|> try (do { reservedOp "<=" ; return $ OcLessEq }) <|> do { reservedOp "<=" ; return $ OcLessEq }
<|> try (do { reservedOp ">=" ; return $ OcMoreEq }) <|> do { reservedOp ">=" ; return $ OcMoreEq }
<|> try (do { sAFTER ; return $ OcAfter }) <|> do { sAFTER ; return $ OcAfter }
<?> "dyadicOperator" <?> "dyadicOperator"
occamExponent occamExponent
@ -404,17 +401,17 @@ occamExponent
expression :: Parser Node expression :: Parser Node
expression expression
= try (do { o <- monadicOperator ; v <- operand ; return $ o v }) = try (do { o <- monadicOperator ; v <- operand ; return $ o v })
<|> do { a <- sMOSTPOS ; t <- dataType ; return $ OcMostPos t }
<|> do { a <- sMOSTNEG ; t <- dataType ; return $ OcMostNeg t }
<|> do { a <- sSIZE ; t <- dataType ; return $ OcSize t }
<|> try (do { a <- operand ; o <- dyadicOperator ; b <- operand ; return $ o a b }) <|> 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 <|> try conversion
<|> operand <|> operand
<?> "expression" <?> "expression"
expressionList expressionList
= try (do { n <- name ; sLeftR ; as <- sepBy expression sComma ; sRightR ; return $ OcCall n as }) = try (do { n <- name ; sLeftR ; as <- sepBy expression sComma ; sRightR ; return $ OcCall n as })
<|> try (do { es <- sepBy1 expression sComma ; return $ OcExpList es }) <|> do { es <- sepBy1 expression sComma ; return $ OcExpList es }
-- XXX value process -- XXX value process
<?> "expressionList" <?> "expressionList"
@ -471,11 +468,11 @@ hexDigits
-- ... -- ...
input input
= try (do { c <- channel ; sQuest ; is <- sepBy1 inputItem sSemi ; eol ; return $ OcIn c is }) = do c <- channel
<|> try (do { c <- channel ; sQuest ; sCASE ; tl <- taggedList ; eol ; return $ OcInTag c tl }) sQuest
<|> timerInput (do { sCASE ; tl <- taggedList ; eol ; return $ OcInTag c tl }
<|> delayedInput <|> do { sAFTER ; e <- expression ; eol ; return $ OcInAfter c e }
-- <|> do { p <- port ; sQuest ; v <- variable ; eol ; return $ OcIn p (OcExpList [v]) } <|> do { is <- sepBy1 inputItem sSemi ; eol ; return $ OcIn c is })
<?> "input" <?> "input"
inputItem inputItem
@ -503,11 +500,11 @@ loop
= do { sWHILE ; b <- boolean ; eol ; indent ; p <- process ; outdent ; return $ OcWhile b p } = do { sWHILE ; b <- boolean ; eol ; indent ; p <- process ; outdent ; return $ OcWhile b p }
monadicOperator monadicOperator
= try (do { reservedOp "-" ; return $ OcMonSub }) = do { reservedOp "-" ; return $ OcMonSub }
<|> try (do { sMINUS ; return $ OcMonSub }) <|> do { sMINUS ; return $ OcMonSub }
<|> try (do { reservedOp "~" ; return $ OcMonBitNot }) <|> do { reservedOp "~" ; return $ OcMonBitNot }
<|> try (do { sBITNOT ; return $ OcMonBitNot }) <|> do { sBITNOT ; return $ OcMonBitNot }
<|> try (do { sNOT ; return $ OcMonNot }) <|> do { sNOT ; return $ OcMonNot }
<|> do { sSIZE ; return $ OcSize } <|> do { sSIZE ; return $ OcSize }
<?> "monadicOperator" <?> "monadicOperator"
@ -541,11 +538,14 @@ occamOption
<|> do { s <- specification ; o <- occamOption ; return $ OcDecl s o } <|> do { s <- specification ; o <- occamOption ; return $ OcDecl s o }
<?> "option" <?> "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.
output output
= try (do { c <- channel ; sBang ; os <- sepBy1 outputItem sSemi ; eol ; return $ OcOut c os }) = do c <- channel
<|> try (do { c <- channel ; sBang ; t <- tag ; sSemi ; os <- sepBy1 outputItem sSemi ; eol ; return $ OcOutCase c t os }) sBang
<|> do { c <- channel ; sBang ; t <- tag ; eol ; return $ OcOutCase c t [] } (do { sCASE ; t <- tag ; sSemi ; os <- sepBy1 outputItem sSemi ; eol ; return $ OcOutCase c t os }
-- <|> do { p <- port ; sBang ; e <- expression ; eol ; return $ List [Item "!", p, e] } <|> do { sCASE ; t <- tag ; eol ; return $ OcOutCase c t [] }
<|> do { os <- sepBy1 outputItem sSemi ; eol ; return $ OcOut c os })
<?> "output" <?> "output"
outputItem outputItem
@ -554,33 +554,20 @@ outputItem
<?> "outputItem" <?> "outputItem"
parallel parallel
= try (do { sPAR ; eol ; indent ; ps <- many1 process ; outdent ; return $ OcPar ps }) = do { sPAR ; do { eol ; indent ; ps <- many1 process ; outdent ; return $ OcPar ps } <|> do { r <- replicator ; eol ; indent ; p <- process ; outdent ; return $ OcParRep r p } }
<|> try (do { sPAR ; r <- replicator ; eol ; indent ; p <- process ; outdent ; return $ OcParRep r p }) <|> do { sPRI ; sPAR ; do { eol ; indent ; ps <- many1 process ; outdent ; return $ OcPriPar ps } <|> do { r <- replicator ; eol ; indent ; p <- process ; outdent ; return $ OcPriParRep 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 <|> placedpar
<?> "parallel" <?> "parallel"
-- XXX PROCESSOR as a process isn't really legal, surely?
placedpar placedpar
= try (do { sPLACED ; sPAR ; eol ; indent ; ps <- many1 placedpar ; outdent ; return $ OcPlacedPar ps }) = do { sPLACED ; sPAR ; do { eol ; indent ; ps <- many1 placedpar ; outdent ; return $ OcPlacedPar ps } <|> do { r <- replicator ; eol ; indent ; p <- placedpar ; outdent ; return $ OcPlacedParRep r p } }
<|> 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 } <|> do { sPROCESSOR ; e <- expression ; eol ; indent ; p <- process ; outdent ; return $ OcProcessor e p }
<?> "placedpar" <?> "placedpar"
port
= 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 $ 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 portType
= try (do { sPORT ; sOF ; p <- protocol ; return $ OcPortOf p }) = do { sPORT ; sOF ; p <- protocol ; return $ OcPortOf p }
<|> do { sLeft ; s <- expression ; sRight ; t <- portType ; return $ OcArray s t } <|> do { try sLeft ; s <- try expression ; try sRight ; t <- portType ; return $ OcArray s t }
<?> "portType" <?> "portType"
procInstance procInstance
@ -591,19 +578,19 @@ process
= try assignment = try assignment
<|> try input <|> try input
<|> try output <|> try output
<|> try (do { sSKIP ; eol ; return $ OcSkip }) <|> do { sSKIP ; eol ; return $ OcSkip }
<|> try (do { sSTOP ; eol ; return $ OcStop }) <|> do { sSTOP ; eol ; return $ OcStop }
<|> try occamSequence <|> occamSequence
<|> try conditional <|> conditional
<|> try selection <|> selection
<|> try loop <|> loop
<|> try parallel <|> try parallel
<|> try alternation <|> alternation
<|> try caseInput <|> try caseInput
<|> try procInstance <|> try procInstance
<|> try (do { sMainMarker ; eol ; return $ OcMainProcess }) <|> do { sMainMarker ; eol ; return $ OcMainProcess }
<|> try (do { s <- specification ; p <- process ; return $ OcDecl s p })
<|> do { a <- allocation ; p <- process ; return $ OcDecl a p } <|> do { a <- allocation ; p <- process ; return $ OcDecl a p }
<|> do { s <- specification ; p <- process ; return $ OcDecl s p }
<?> "process" <?> "process"
protocol protocol
@ -629,18 +616,20 @@ selector
<?> "selector" <?> "selector"
occamSequence occamSequence
= try (do { sSEQ ; eol ; indent ; ps <- many1 process ; outdent ; return $ OcSeq ps }) = do sSEQ
<|> do { sSEQ ; r <- replicator ; eol ; indent ; p <- process ; outdent ; return $ OcSeqRep r p } (do { eol ; indent ; ps <- many1 process ; outdent ; return $ OcSeq ps }
<|> do { r <- replicator ; eol ; indent ; p <- process ; outdent ; return $ OcSeqRep r p })
<?> "sequence" <?> "sequence"
sequentialProtocol sequentialProtocol
= do { l <- sepBy1 simpleProtocol sSemi ; return $ l } = do { l <- try $ sepBy1 simpleProtocol sSemi ; return $ l }
<?> "sequentialProtocol" <?> "sequentialProtocol"
simpleProtocol simpleProtocol
-- FIXME I don't know why this needs to all be in a try, but I couldn't get it to work otherwise...
= try (do { l <- dataType ; sColons ; sLeft ; sRight ; r <- dataType ; return $ OcCounted l r }) = try (do { l <- dataType ; sColons ; sLeft ; sRight ; r <- dataType ; return $ OcCounted l r })
<|> try dataType <|> dataType
<|> do { try (sANY) ; return $ OcAny } <|> do { sANY ; return $ OcAny }
<?> "simpleProtocol" <?> "simpleProtocol"
specification specification
@ -677,10 +666,11 @@ table
table' table'
= try occamString = try occamString
<|> try (do { s <- occamString ; sLeftR ; n <- name ; sRightR ; return $ OcTypedLit n s }) <|> try (do { s <- occamString ; sLeftR ; n <- name ; sRightR ; return $ OcTypedLit n s })
<|> try (do { sLeft ; es <- sepBy1 expression sComma ; sRight ; return $ OcLitArray es }) <|> do { sLeft ;
<|> try (do { sLeft ; n <- table ; sFROM ; e <- expression ; sFOR ; f <- expression ; sRight ; return $ OcSubFromFor n e f }) try (do { es <- sepBy1 expression sComma ; sRight ; return $ OcLitArray es })
<|> try (do { sLeft ; n <- table ; sFROM ; e <- expression ; sRight ; return $ OcSubFrom n e }) <|> try (do { n <- table ; sFROM ; e <- expression ; sFOR ; f <- expression ; sRight ; return $ OcSubFromFor n e f })
<|> try (do { sLeft ; n <- table ; sFOR ; e <- expression ; sRight ; return $ OcSubFor n e }) <|> try (do { n <- table ; sFROM ; e <- expression ; sRight ; return $ OcSubFrom n e })
<|> do { n <- table ; sFOR ; e <- expression ; sRight ; return $ OcSubFor n e } }
<?> "table'" <?> "table'"
tag tag
@ -696,24 +686,9 @@ taggedProtocol
= try (do { t <- tag ; eol ; return $ OcTag t [] }) = try (do { t <- tag ; eol ; return $ OcTag t [] })
<|> try (do { t <- tag ; sSemi ; sp <- sequentialProtocol ; eol ; return $ OcTag t sp }) <|> 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 OcSub v es }
<?> "timer"
timer'
= try name
<|> 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 $ OcIn c [v] })
<?> "timerInput"
timerType timerType
= try (do { sTIMER ; return $ OcTimer }) = do { sTIMER ; return $ OcTimer }
<|> do { sLeft ; s <- expression ; sRight ; t <- timerType ; return $ OcArray s t } <|> do { try sLeft ; s <- try expression ; try sRight ; t <- timerType ; return $ OcArray s t }
<?> "timerType" <?> "timerType"
valueProcess valueProcess
@ -746,7 +721,7 @@ variant
-- source file is really a series of specifications, but the later ones need to -- source file is really a series of specifications, but the later ones need to
-- have the earlier ones in scope, so we can't parse them separately. -- have the earlier ones in scope, so we can't parse them separately.
sourceFile = process sourceFile = do { whiteSpace ; process }
-- ------------------------------------------------------------- -- -------------------------------------------------------------
@ -774,17 +749,18 @@ stripCommentInString ('"':s) = '"' : stripComment s
stripCommentInString (c:s) = c : stripCommentInString s stripCommentInString (c:s) = c : stripCommentInString s
flatten :: [String] -> String flatten :: [String] -> String
flatten ls = concat $ intersperse "@" $ flatten' ls 0 flatten ls = concat $ intersperse "\n" $ flatten' ls 0
where where
rep n i = take n (repeat i) rep n i = take n (repeat i)
flatten' [] level = [rep level '}'] flatten' [] level = [rep level '}']
flatten' (s:ss) level flatten' (s:ss) level
| stripped == "" = flatten' ss level | stripped == "" = "" : flatten' ss level
| newLevel > level = (rep (newLevel - level) '{' ++ stripped) : rest | newLevel > level = (rep (newLevel - level) '{' ++ stripped) : rest
| newLevel < level = (rep (level - newLevel) '}' ++ stripped) : rest | newLevel < level = (rep (level - newLevel) '}' ++ stripped) : rest
| otherwise = stripped : rest | otherwise = stripped : rest
where newLevel = countIndent s where newLevel = countIndent s
stripped = stripIndent $ stripComment s stripped' = stripIndent $ stripComment s
stripped = if stripped' == "" then "" else (stripped' ++ "@")
rest = flatten' ss newLevel rest = flatten' ss newLevel
-- ------------------------------------------------------------- -- -------------------------------------------------------------
@ -793,11 +769,16 @@ flatten ls = concat $ intersperse "@" $ flatten' ls 0
prepare d = flatten $ lines (d ++ "\n" ++ mainMarker) prepare d = flatten $ lines (d ++ "\n" ++ mainMarker)
numberedListing :: String -> String
numberedListing s = concat $ intersperse "\n" $ [(show n) ++ ": " ++ s | (n, s) <- zip [1..] (lines s)]
parseSourceFile :: String -> IO Node parseSourceFile :: String -> IO Node
parseSourceFile fn parseSourceFile fn
= do f <- IO.openFile fn IO.ReadMode = do f <- IO.openFile fn IO.ReadMode
d <- IO.hGetContents f d <- IO.hGetContents f
return $ case (parse sourceFile "occam" $ prepare d) of let prep = prepare d
putStrLn $ "Prepared: " ++ numberedListing prep
return $ case (parse sourceFile "occam" prep) of
Left err -> error ("Parsing error: " ++ (show err)) Left err -> error ("Parsing error: " ++ (show err))
Right defs -> defs Right defs -> defs

89
fco/test3.occ Normal file
View File

@ -0,0 +1,89 @@
-- commstime, from the KRoC distribution
#USE "course.lib"
--{{{ PROC seq.delta (CHAN INT in?, out.0!, out.1!)
PROC seq.delta (CHAN INT in?, out.0!, out.1!)
WHILE TRUE
INT n:
SEQ
in ? n
out.0 ! n
out.1 ! n
:
--}}}
--{{{ PROC consume (VAL INT n.loops, CHAN INT in?, CHAN BYTE out!)
PROC consume (VAL INT n.loops, CHAN INT in?, CHAN BYTE out!)
TIMER tim:
INT t0, t1:
INT value:
SEQ
--{{{ warm-up loop
VAL INT warm.up IS 16:
SEQ i = 0 FOR warm.up
in ? value
--}}}
WHILE TRUE
SEQ
tim ? t0
--{{{ bench-mark loop
SEQ i = 0 FOR n.loops
in ? value
--}}}
tim ? t1
--{{{ report
VAL INT microsecs IS t1 MINUS t0:
VAL INT64 nanosecs IS 1000 * (INT64 microsecs):
SEQ
out.string ("Last value received = ", 0, out!)
out.int (value, 0, out!)
out.string ("*c*n", 0, out!)
out.string ("Time = ", 0, out!)
out.int (microsecs, 0, out!)
out.string (" microsecs*c*n", 0, out!)
out.string ("Time per loop = ", 0, out!)
out.int (INT (nanosecs/(INT64 n.loops)), 0, out!)
out.string (" nanosecs*c*n", 0, out!)
out.string ("Context switch = ", 0, out!)
out.int (INT ((nanosecs/(INT64 n.loops))/4), 0, out!)
out.string (" nanosecs*c*n*n", 0, out!)
--}}}
:
--}}}
--{{{ PROC comms.time (CHAN BYTE keyboard?, screen!, error!)
PROC comms.time (CHAN BYTE keyboard?, screen!, error!)
BOOL use.seq.delta:
SEQ
--{{{ announce
SEQ
out.string ("*c*nCommstime in occam ...*c*n*n", 0, screen!)
out.string ("Using the SEQ-output version of the delta process*c*n", 0, screen!)
out.string ("yields a more accurate measure of context-switch time*c*n*n", 0, screen!)
out.string ("Using the PAR-output version carries an extra overhead*c*n", 0, screen!)
out.string ("of one process startup/shutdown per Commstime loop*c*n*n", 0, screen!)
out.string ("By comparing **loop** times between the SEQ and PAR versions,*c*n", 0, screen!)
out.string ("the process startup/shutdown overhead may be deduced*c*n*n", 0, screen!)
--}}}
ask.bool ("Sequential delta? ", use.seq.delta, keyboard?, screen!)
out.string ("*nCommstime starting ...*c*n*n", 0, screen!)
CHAN INT a, b, c, d:
PAR
prefix (0, b?, a!)
IF
use.seq.delta
seq.delta (a?, c!, d!) -- the one defined above
TRUE
delta (a?, c!, d!) -- the one that does a parallel output
succ (c?, b!)
consume (1000000, d?, screen!)
:
--}}}

6
fco/test4.occ Normal file
View File

@ -0,0 +1,6 @@
PROC test.simple (CHAN OF BYTE in, out, err)
SEQ
out ! 'h'
out ! 'i'
out ! '*n'
:

10
fco/test5.occ Normal file
View File

@ -0,0 +1,10 @@
PROC test.expressions ()
INT a:
INT b:
INT c:
SEQ
a := 1
b := 2
c := 3
c := (42 * a) + (b - (72 / c))
:

73
fco/test6.occ Normal file
View File

@ -0,0 +1,73 @@
PROC test.syntax ()
INT x:
[10]INT xs:
CHAN OF INT c:
--[10]CHAN OF INT cs:
SEQ
-- abbreviation
xx IS x:
SKIP
INT xx IS x:
SKIP
VAL xx IS x:
SKIP
VAL INT xx IS x:
SKIP
-- allocation
[2]INT q:
-- Doesn't work in KRoC.
--PLACE q AT 12345:
SKIP
-- alternation
ALT
c ? x
SKIP
TRUE & SKIP
SKIP
ALT i = 0 FOR 10
cs[i] ? xs[i]
SKIP
PRI ALT
c ? x
SKIP
TRUE & SKIP
SKIP
PRI ALT i = 0 FOR 10
cs[i] ? xs[i]
SKIP
xx IS x:
ALT
TRUE & SKIP
SKIP
-- definition
DATA TYPE T1 IS INT:
DATA TYPE T2
RECORD
INT x:
:
PROTOCOL P1 IS INT; INT:
PROTOCOL P2 IS ANY:
PROTOCOL P3
CASE
foo
:
PROC p1 (INT x)
SKIP
:
INT FUNCTION f1 (VAL INT x) IS x:
INT FUNCTION f2 (VAL INT x)
VALOF
SKIP
RESULT x
:
INT xx RETYPES x:
INT xx RESHAPES x:
VAL INT xx RETYPES x:
VAL INT xx RESHAPES x:
SKIP
: