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

Import Tree qualified, getting rid of the silly Oc prefix on all the types

Browse Source
This commit is contained in:
Adam Sampson 2006-10-02 16:31:23 +00:00
parent 792728b7aa
commit acb785e85b
7 changed files with 572 additions and 570 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

334
fco/Parse.hs
View File

@ -8,7 +8,7 @@ import qualified Text.ParserCombinators.Parsec.Token as P
import Text.ParserCombinators.Parsec.Language (emptyDef) import Text.ParserCombinators.Parsec.Language (emptyDef)
import qualified IO import qualified IO
import Tree import qualified Tree as N
-- ------------------------------------------------------------- -- -------------------------------------------------------------
@ -212,11 +212,11 @@ eol = symbol "@"
-- The way productions should work is that each production should only consume input if it's sure that it's unambiguous. -- 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 $ N.Is 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 $ N.IsType s n v })
<|> do { sVAL ; <|> do { sVAL ;
try (do { n <- name ; sIS ; e <- expression ; sColon ; eol ; return $ OcValIs n e }) 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 $ OcValIsType s n e } } <|> do { s <- specifier ; n <- name ; sIS ; e <- expression ; sColon ; eol ; return $ N.ValIsType s n e } }
<?> "abbreviation" <?> "abbreviation"
actual actual
@ -226,28 +226,28 @@ actual
<?> "actual" <?> "actual"
allocation allocation
= do { sPLACE ; n <- name ; sAT ; e <- expression ; sColon ; eol ; return $ OcPlace n e } = do { sPLACE ; n <- name ; sAT ; e <- expression ; sColon ; eol ; return $ N.Place n e }
<?> "allocation" <?> "allocation"
alternation alternation
= do { sALT ; = do { sALT ;
do { eol ; indent ; as <- many1 alternative ; outdent ; return $ OcAlt as } do { eol ; indent ; as <- many1 alternative ; outdent ; return $ N.Alt as }
<|> do { r <- replicator ; eol ; indent ; a <- alternative ; outdent ; return $ OcAltRep r a } } <|> do { r <- replicator ; eol ; indent ; a <- alternative ; outdent ; return $ N.AltRep r a } }
<|> do { sPRI ; sALT ; <|> do { sPRI ; sALT ;
do { eol ; indent ; as <- many1 alternative ; outdent ; return $ OcPriAlt as } do { eol ; indent ; as <- many1 alternative ; outdent ; return $ N.PriAlt as }
<|> do { r <- replicator ; eol ; indent ; a <- alternative ; outdent ; return $ OcPriAltRep r a } } <|> do { r <- replicator ; eol ; indent ; a <- alternative ; outdent ; return $ N.PriAltRep r a } }
<?> "alternation" <?> "alternation"
alternative alternative
= guardedAlternative = guardedAlternative
<|> alternation <|> alternation
<|> 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 $ N.InCaseGuard b c vs })
<|> try (do { c <- channel ; sQuest ; sCASE ; eol ; indent ; vs <- many1 variant ; outdent ; return $ OcInCase c vs }) <|> try (do { c <- channel ; sQuest ; sCASE ; eol ; indent ; vs <- many1 variant ; outdent ; return $ N.InCase c vs })
<|> do { s <- specification ; a <- alternative ; return $ OcDecl s a } <|> do { s <- specification ; a <- alternative ; return $ N.Decl s a }
<?> "alternative" <?> "alternative"
assignment assignment
= do { vs <- variableList ; sAssign ; es <- expressionList ; eol ; return $ OcAssign vs es } = do { vs <- variableList ; sAssign ; es <- expressionList ; eol ; return $ N.Assign vs es }
<?> "assignment" <?> "assignment"
base base
@ -259,7 +259,7 @@ boolean
<?> "boolean" <?> "boolean"
byte byte
= lexeme (do { char '\'' ; s <- character ; char '\'' ; return $ OcLitByte s }) = lexeme (do { char '\'' ; s <- character ; char '\'' ; return $ N.LitByte s })
<?> "byte" <?> "byte"
caseExpression caseExpression
@ -267,26 +267,26 @@ caseExpression
<?> "caseExpression" <?> "caseExpression"
caseInput 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 $ N.InCase c vs }
<?> "caseInput" <?> "caseInput"
-- This is also used for timers and ports, since the syntax is identical (and -- 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). -- 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 N.Sub v es }
<?> "channel" <?> "channel"
channel' channel'
= try name = try name
<|> 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 ; sFOR ; f <- expression ; sRight ; return $ N.SubFromFor n e f })
<|> try (do { sLeft ; n <- channel ; sFROM ; e <- expression ; sRight ; return $ OcSubFrom n e }) <|> try (do { sLeft ; n <- channel ; sFROM ; e <- expression ; sRight ; return $ N.SubFrom n e })
<|> do { sLeft ; n <- channel ; sFOR ; e <- expression ; sRight ; return $ OcSubFor n e } <|> do { sLeft ; n <- channel ; sFOR ; e <- expression ; sRight ; return $ N.SubFor n e }
<?> "channel'" <?> "channel'"
-- FIXME should probably make CHAN INT work, since that'd be trivial... -- FIXME should probably make CHAN INT work, since that'd be trivial...
channelType channelType
= do { sCHAN ; sOF ; p <- protocol ; return $ OcChanOf p } = do { sCHAN ; sOF ; p <- protocol ; return $ N.ChanOf p }
<|> try (do { sLeft ; s <- expression ; sRight ; t <- channelType ; return $ OcArray s t }) <|> try (do { sLeft ; s <- expression ; sRight ; t <- channelType ; return $ N.Array s t })
<?> "channelType" <?> "channelType"
-- FIXME this isn't at all the right way to return the character! -- FIXME this isn't at all the right way to return the character!
@ -300,18 +300,18 @@ character
occamChoice occamChoice
= guardedChoice = guardedChoice
<|> conditional <|> conditional
<|> do { s <- try specification ; c <- occamChoice ; return $ OcDecl s c } <|> do { s <- try specification ; c <- occamChoice ; return $ N.Decl s c }
<?> "choice" <?> "choice"
conditional conditional
= do { sIF ; = do { sIF ;
do { eol ; indent ; cs <- many1 occamChoice ; outdent ; return $ OcIf cs } do { eol ; indent ; cs <- many1 occamChoice ; outdent ; return $ N.If cs }
<|> do { r <- replicator ; eol ; indent ; c <- occamChoice ; outdent ; return $ OcIfRep r c } } <|> do { r <- replicator ; eol ; indent ; c <- occamChoice ; outdent ; return $ N.IfRep r c } }
<?> "conditional" <?> "conditional"
conversion conversion
= do t <- dataType = do t <- dataType
do { sROUND ; o <- operand ; return $ OcRound t o } <|> do { sTRUNC ; o <- operand ; return $ OcTrunc t o } <|> do { o <- operand ; return $ OcConv t o } 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 }
<?> "conversion" <?> "conversion"
occamCount occamCount
@ -319,15 +319,15 @@ occamCount
<?> "count" <?> "count"
dataType dataType
= do { sBOOL ; return $ OcBool } = do { sBOOL ; return $ N.Bool }
<|> do { sBYTE ; return $ OcByte } <|> do { sBYTE ; return $ N.Byte }
<|> do { sINT ; return $ OcInt } <|> do { sINT ; return $ N.Int }
<|> do { sINT16 ; return $ OcInt16 } <|> do { sINT16 ; return $ N.Int16 }
<|> do { sINT32 ; return $ OcInt32 } <|> do { sINT32 ; return $ N.Int32 }
<|> do { sINT64 ; return $ OcInt64 } <|> do { sINT64 ; return $ N.Int64 }
<|> do { sREAL32 ; return $ OcReal32 } <|> do { sREAL32 ; return $ N.Real32 }
<|> do { sREAL64 ; return $ OcReal64 } <|> do { sREAL64 ; return $ N.Real64 }
<|> try (do { sLeft ; s <- expression ; sRight ; t <- dataType ; return $ OcArray s t }) <|> try (do { sLeft ; s <- expression ; sRight ; t <- dataType ; return $ N.Array s t })
<|> name <|> name
<?> "data type" <?> "data type"
@ -338,28 +338,28 @@ declType
<|> portType <|> portType
-- 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 N.Node for each type of declaration
declaration declaration
= do { d <- declType ; ns <- sepBy1 name sComma ; sColon ; eol ; return $ OcVars d ns } = do { d <- declType ; ns <- sepBy1 name sComma ; sColon ; eol ; return $ N.Vars d ns }
<?> "declaration" <?> "declaration"
definition definition
= do { sDATA ; sTYPE ; n <- name ; = do { sDATA ; sTYPE ; n <- name ;
do {sIS ; t <- dataType ; sColon ; eol ; return $ OcDataType n t } do {sIS ; t <- dataType ; sColon ; eol ; return $ N.DataType n t }
<|> do { eol ; indent ; t <- structuredType ; outdent ; sColon ; eol ; return $ OcDataType n t } } <|> do { eol ; indent ; t <- structuredType ; outdent ; sColon ; eol ; return $ N.DataType n t } }
<|> do { sPROTOCOL ; n <- name ; <|> do { sPROTOCOL ; n <- name ;
do { sIS ; p <- sequentialProtocol ; sColon ; eol ; return $ OcProtocol n p } 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 $ OcTaggedProtocol n ps } } <|> 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 $ OcProc n fs p } <|> 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 ; <|> try (do { rs <- sepBy1 dataType sComma ; (n, fs) <- functionHeader ;
do { sIS ; el <- expressionList ; sColon ; eol ; return $ OcFuncIs n rs fs el } do { sIS ; el <- expressionList ; sColon ; eol ; return $ N.FuncIs n rs fs el }
<|> do { eol ; indent ; vp <- valueProcess ; outdent ; sColon ; eol ; return $ OcFunc n rs fs vp } }) <|> do { eol ; indent ; vp <- valueProcess ; outdent ; sColon ; eol ; return $ N.Func n rs fs vp } })
<|> try (do { s <- specifier ; n <- name ; <|> try (do { s <- specifier ; n <- name ;
do { sRETYPES ; v <- variable ; sColon ; eol ; return $ OcRetypes s n v } do { sRETYPES ; v <- variable ; sColon ; eol ; return $ N.Retypes s n v }
<|> do { try sRESHAPES ; v <- variable ; sColon ; eol ; return $ OcReshapes s n v } }) <|> do { try sRESHAPES ; v <- variable ; sColon ; eol ; return $ N.Reshapes s n v } })
<|> do { sVAL ; s <- specifier ; n <- name ; <|> do { sVAL ; s <- specifier ; n <- name ;
do { sRETYPES ; v <- variable ; sColon ; eol ; return $ OcValRetypes s n v } do { sRETYPES ; v <- variable ; sColon ; eol ; return $ N.ValRetypes s n v }
<|> do { sRESHAPES ; v <- variable ; sColon ; eol ; return $ OcValReshapes s n v } } <|> do { sRESHAPES ; v <- variable ; sColon ; eol ; return $ N.ValReshapes s n v } }
<?> "definition" <?> "definition"
digits digits
@ -367,49 +367,49 @@ digits
<?> "digits" <?> "digits"
dyadicOperator dyadicOperator
= do { reservedOp "+" ; return $ OcAdd } = do { reservedOp "+" ; return $ N.Add }
<|> do { reservedOp "-" ; return $ OcSubtr } <|> do { reservedOp "-" ; return $ N.Subtr }
<|> do { reservedOp "*" ; return $ OcMul } <|> do { reservedOp "*" ; return $ N.Mul }
<|> do { reservedOp "/" ; return $ OcDiv } <|> do { reservedOp "/" ; return $ N.Div }
<|> do { reservedOp "\\" ; return $ OcRem } <|> do { reservedOp "\\" ; return $ N.Rem }
<|> do { sREM ; return $ OcRem } <|> do { sREM ; return $ N.Rem }
<|> do { sPLUS ; return $ OcPlus } <|> do { sPLUS ; return $ N.Plus }
<|> do { sMINUS ; return $ OcMinus } <|> do { sMINUS ; return $ N.Minus }
<|> do { sTIMES ; return $ OcTimes } <|> do { sTIMES ; return $ N.Times }
<|> do { reservedOp "/\\" ; return $ OcBitAnd } <|> do { reservedOp "/\\" ; return $ N.BitAnd }
<|> do { reservedOp "\\/" ; return $ OcBitOr } <|> do { reservedOp "\\/" ; return $ N.BitOr }
<|> do { reservedOp "><" ; return $ OcBitXor } <|> do { reservedOp "><" ; return $ N.BitXor }
<|> do { sBITAND ; return $ OcBitAnd } <|> do { sBITAND ; return $ N.BitAnd }
<|> do { sBITOR ; return $ OcBitOr } <|> do { sBITOR ; return $ N.BitOr }
<|> do { sAND ; return $ OcAnd } <|> do { sAND ; return $ N.And }
<|> do { sOR ; return $ OcOr } <|> do { sOR ; return $ N.Or }
<|> do { reservedOp "=" ; return $ OcEq } <|> do { reservedOp "=" ; return $ N.Eq }
<|> do { reservedOp "<>" ; return $ OcNEq } <|> do { reservedOp "<>" ; return $ N.NEq }
<|> do { reservedOp "<" ; return $ OcLess } <|> do { reservedOp "<" ; return $ N.Less }
<|> do { reservedOp ">" ; return $ OcMore } <|> do { reservedOp ">" ; return $ N.More }
<|> do { reservedOp "<=" ; return $ OcLessEq } <|> do { reservedOp "<=" ; return $ N.LessEq }
<|> do { reservedOp ">=" ; return $ OcMoreEq } <|> do { reservedOp ">=" ; return $ N.MoreEq }
<|> do { sAFTER ; return $ OcAfter } <|> do { sAFTER ; return $ N.After }
<?> "dyadicOperator" <?> "dyadicOperator"
occamExponent occamExponent
= try (do { c <- oneOf "+-" ; d <- digits ; return $ c : d }) = try (do { c <- oneOf "+-" ; d <- digits ; return $ c : d })
<?> "exponent" <?> "exponent"
expression :: Parser Node expression :: Parser N.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 <- sMOSTPOS ; t <- dataType ; return $ N.MostPos t }
<|> do { a <- sMOSTNEG ; t <- dataType ; return $ OcMostNeg t } <|> do { a <- sMOSTNEG ; t <- dataType ; return $ N.MostNeg t }
<|> do { a <- sSIZE ; t <- dataType ; return $ OcSize t } <|> do { a <- sSIZE ; t <- dataType ; return $ N.Size 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 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 $ N.Call n as })
<|> do { es <- sepBy1 expression sComma ; return $ OcExpList es } <|> do { es <- sepBy1 expression sComma ; return $ N.ExpList es }
-- XXX value process -- XXX value process
<?> "expressionList" <?> "expressionList"
@ -423,20 +423,20 @@ formalList
= do { sLeftR ; fs <- sepBy formalArg sComma ; sRightR ; return $ markTypes fs } = do { sLeftR ; fs <- sepBy formalArg sComma ; sRightR ; return $ markTypes fs }
<?> "formalList" <?> "formalList"
where where
formalArg :: Parser (Maybe Node, Node) formalArg :: Parser (Maybe N.Node, N.Node)
formalArg = try (do { sVAL ; s <- specifier ; n <- name ; return $ (Just (OcVal s), n) }) formalArg = try (do { sVAL ; s <- specifier ; n <- name ; return $ (Just (N.Val s), n) })
<|> try (do { s <- specifier ; n <- name ; return $ (Just s, n) }) <|> try (do { s <- specifier ; n <- name ; return $ (Just s, n) })
<|> try (do { n <- name ; return $ (Nothing, n) }) <|> try (do { n <- name ; return $ (Nothing, n) })
markTypes :: [(Maybe Node, Node)] -> [Node] markTypes :: [(Maybe N.Node, N.Node)] -> [N.Node]
markTypes [] = [] markTypes [] = []
markTypes ((Nothing, _):_) = error "Formal list must start with a type" markTypes ((Nothing, _):_) = error "Formal list must start with a type"
markTypes ((Just ft,fn):is) = (OcFormal ft fn) : markRest ft is markTypes ((Just ft,fn):is) = (N.Formal ft fn) : markRest ft is
markRest :: Node -> [(Maybe Node, Node)] -> [Node] markRest :: N.Node -> [(Maybe N.Node, N.Node)] -> [N.Node]
markRest _ [] = [] markRest _ [] = []
markRest t ((Nothing, n):is) = (OcFormal t n) : markRest t is markRest t ((Nothing, n):is) = (N.Formal t n) : markRest t is
markRest _ ((Just t, n):is) = (OcFormal t n) : markRest t is markRest _ ((Just t, n):is) = (N.Formal t n) : markRest t is
functionHeader functionHeader
= do { sFUNCTION ; n <- name ; fs <- formalList ; return $ (n, fs) } = do { sFUNCTION ; n <- name ; fs <- formalList ; return $ (n, fs) }
@ -444,20 +444,20 @@ functionHeader
guard guard
= try input = try input
<|> try (do { b <- boolean ; sAmp ; i <- input ; return $ OcGuarded b i }) <|> try (do { b <- boolean ; sAmp ; i <- input ; return $ N.Guarded b i })
<|> try (do { b <- boolean ; sAmp ; sSKIP ; eol ; return $ OcGuarded b OcSkip }) <|> try (do { b <- boolean ; sAmp ; sSKIP ; eol ; return $ N.Guarded b N.Skip })
<?> "guard" <?> "guard"
guardedAlternative guardedAlternative
= do { g <- guard ; indent ; p <- process ; outdent ; return $ OcGuarded g p } = do { g <- guard ; indent ; p <- process ; outdent ; return $ N.Guarded g p }
<?> "guardedAlternative" <?> "guardedAlternative"
guardedChoice guardedChoice
= do { b <- boolean ; eol ; indent ; p <- process ; outdent ; return $ OcGuarded b p } = do { b <- boolean ; eol ; indent ; p <- process ; outdent ; return $ N.Guarded b p }
<?> "guardedChoice" <?> "guardedChoice"
hexDigits hexDigits
= do { d <- many1 hexDigit ; return $ OcLitHex d } = do { d <- many1 hexDigit ; return $ N.LitHex d }
<?> "hexDigits" <?> "hexDigits"
-- XXX how does the syntax handle multiline regular CASE inputs? -- XXX how does the syntax handle multiline regular CASE inputs?
@ -468,18 +468,18 @@ hexDigits
input input
= do c <- channel = do c <- channel
sQuest sQuest
(do { sCASE ; tl <- taggedList ; eol ; return $ OcInTag c tl } (do { sCASE ; tl <- taggedList ; eol ; return $ N.InTag c tl }
<|> do { sAFTER ; e <- expression ; eol ; return $ OcInAfter c e } <|> do { sAFTER ; e <- expression ; eol ; return $ N.InAfter c e }
<|> do { is <- sepBy1 inputItem sSemi ; eol ; return $ OcIn c is }) <|> do { is <- sepBy1 inputItem sSemi ; eol ; return $ N.In c is })
<?> "input" <?> "input"
inputItem inputItem
= try (do { v <- variable ; sColons ; w <- variable ; return $ OcCounted v w }) = try (do { v <- variable ; sColons ; w <- variable ; return $ N.Counted v w })
<|> variable <|> variable
<?> "inputItem" <?> "inputItem"
integer integer
= try (do { d <- lexeme digits ; return $ OcLitInt d }) = try (do { d <- lexeme digits ; return $ N.LitInt d })
<|> do { char '#' ; d <- lexeme hexDigits ; return $ d } <|> do { char '#' ; d <- lexeme hexDigits ; return $ d }
<?> "integer" <?> "integer"
@ -487,35 +487,35 @@ literal
= try real = try real
<|> try integer <|> try integer
<|> try byte <|> try byte
<|> try (do { v <- real ; sLeftR ; t <- dataType ; sRightR ; return $ OcTypedLit t v }) <|> try (do { v <- real ; sLeftR ; t <- dataType ; sRightR ; return $ N.TypedLit t v })
<|> try (do { v <- integer ; sLeftR ; t <- dataType ; sRightR ; return $ OcTypedLit t v }) <|> try (do { v <- integer ; sLeftR ; t <- dataType ; sRightR ; return $ N.TypedLit t v })
<|> try (do { v <- byte ; sLeftR ; t <- dataType ; sRightR ; return $ OcTypedLit t v }) <|> try (do { v <- byte ; sLeftR ; t <- dataType ; sRightR ; return $ N.TypedLit t v })
<|> try (do { sTRUE ; return $ OcTrue }) <|> try (do { sTRUE ; return $ N.True })
<|> do { sFALSE ; return $ OcFalse } <|> do { sFALSE ; return $ N.False }
<?> "literal" <?> "literal"
loop loop
= do { sWHILE ; b <- boolean ; eol ; indent ; p <- process ; outdent ; return $ OcWhile b p } = do { sWHILE ; b <- boolean ; eol ; indent ; p <- process ; outdent ; return $ N.While b p }
monadicOperator monadicOperator
= do { reservedOp "-" ; return $ OcMonSub } = do { reservedOp "-" ; return $ N.MonSub }
<|> do { sMINUS ; return $ OcMonSub } <|> do { sMINUS ; return $ N.MonSub }
<|> do { reservedOp "~" ; return $ OcMonBitNot } <|> do { reservedOp "~" ; return $ N.MonBitNot }
<|> do { sBITNOT ; return $ OcMonBitNot } <|> do { sBITNOT ; return $ N.MonBitNot }
<|> do { sNOT ; return $ OcMonNot } <|> do { sNOT ; return $ N.MonNot }
<|> do { sSIZE ; return $ OcSize } <|> do { sSIZE ; return $ N.Size }
<?> "monadicOperator" <?> "monadicOperator"
name name
= do { s <- identifier ; return $ OcName s } = do { s <- identifier ; return $ N.Name s }
<?> "name" <?> "name"
occamString occamString
= lexeme (do { char '"' ; s <- many (noneOf "\"") ; char '"' ; return $ OcLitString s }) = lexeme (do { char '"' ; s <- many (noneOf "\"") ; char '"' ; return $ N.LitString s })
<?> "string" <?> "string"
operand operand
= do { v <- operand' ; es <- many (do { sLeft ; e <- expression ; sRight ; return e }) ; return $ foldl OcSub v es } = do { v <- operand' ; es <- many (do { sLeft ; e <- expression ; sRight ; return e }) ; return $ foldl N.Sub v es }
<?> "operand" <?> "operand"
operand' operand'
@ -524,16 +524,16 @@ operand'
<|> try table <|> try table
<|> try (do { sLeftR ; e <- expression ; sRightR ; return e }) <|> try (do { sLeftR ; e <- expression ; sRightR ; return e })
-- XXX value process -- XXX value process
<|> 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 $ N.Call n as })
<|> try (do { sBYTESIN ; sLeftR ; o <- operand ; sRightR ; return $ OcBytesIn o }) <|> try (do { sBYTESIN ; sLeftR ; o <- operand ; sRightR ; return $ N.BytesIn o })
<|> try (do { sBYTESIN ; sLeftR ; o <- dataType ; sRightR ; return $ OcBytesIn o }) <|> try (do { sBYTESIN ; sLeftR ; o <- dataType ; sRightR ; return $ N.BytesIn o })
<|> try (do { sOFFSETOF ; sLeftR ; n <- name ; sComma ; f <- fieldName ; sRightR ; return $ OcOffsetOf n f }) <|> try (do { sOFFSETOF ; sLeftR ; n <- name ; sComma ; f <- fieldName ; sRightR ; return $ N.OffsetOf n f })
<?> "operand'" <?> "operand'"
occamOption occamOption
= try (do { ces <- sepBy caseExpression sComma ; eol ; indent ; p <- process ; outdent ; return $ OcCaseExps ces p }) = 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 $ OcElse p }) <|> try (do { sELSE ; eol ; indent ; p <- process ; outdent ; return $ N.Else p })
<|> do { s <- specification ; o <- occamOption ; return $ OcDecl s o } <|> do { s <- specification ; o <- occamOption ; return $ N.Decl s o }
<?> "option" <?> "option"
-- XXX This can't tell at parse time in "c ! x; y" whether x is a variable or a tag... -- XXX This can't tell at parse time in "c ! x; y" whether x is a variable or a tag...
@ -542,43 +542,43 @@ occamOption
output output
= do c <- channel = do c <- channel
sBang sBang
(do { sCASE ; t <- tag ; sSemi ; os <- sepBy1 outputItem sSemi ; eol ; return $ OcOutCase c t os } (do { sCASE ; t <- tag ; sSemi ; os <- sepBy1 outputItem sSemi ; eol ; return $ N.OutCase c t os }
<|> do { sCASE ; t <- tag ; eol ; return $ OcOutCase c t [] } <|> do { sCASE ; t <- tag ; eol ; return $ N.OutCase c t [] }
<|> do { os <- sepBy1 outputItem sSemi ; eol ; return $ OcOut c os }) <|> do { os <- sepBy1 outputItem sSemi ; eol ; return $ N.Out c os })
<?> "output" <?> "output"
outputItem outputItem
= try (do { a <- expression ; sColons ; b <- expression ; return $ OcCounted a b }) = try (do { a <- expression ; sColons ; b <- expression ; return $ N.Counted a b })
<|> expression <|> expression
<?> "outputItem" <?> "outputItem"
parallel parallel
= do { sPAR ; do { eol ; indent ; ps <- many1 process ; outdent ; return $ OcPar ps } <|> do { r <- replicator ; eol ; indent ; p <- process ; outdent ; return $ OcParRep r p } } = 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 $ OcPriPar ps } <|> do { r <- replicator ; eol ; indent ; p <- process ; outdent ; return $ OcPriParRep 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 } }
<|> placedpar <|> placedpar
<?> "parallel" <?> "parallel"
-- XXX PROCESSOR as a process isn't really legal, surely? -- XXX PROCESSOR as a process isn't really legal, surely?
placedpar placedpar
= 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 } } = 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 $ OcProcessor e p } <|> do { sPROCESSOR ; e <- expression ; eol ; indent ; p <- process ; outdent ; return $ N.Processor e p }
<?> "placedpar" <?> "placedpar"
portType portType
= do { sPORT ; sOF ; p <- protocol ; return $ OcPortOf p } = do { sPORT ; sOF ; p <- protocol ; return $ N.PortOf p }
<|> do { try sLeft ; s <- try expression ; try sRight ; t <- portType ; return $ OcArray s t } <|> do { try sLeft ; s <- try expression ; try sRight ; t <- portType ; return $ N.Array s t }
<?> "portType" <?> "portType"
procInstance procInstance
= do { n <- name ; sLeftR ; as <- sepBy actual sComma ; sRightR ; eol ; return $ OcProcCall n as } = do { n <- name ; sLeftR ; as <- sepBy actual sComma ; sRightR ; eol ; return $ N.ProcCall n as }
<?> "procInstance" <?> "procInstance"
process process
= try assignment = try assignment
<|> try input <|> try input
<|> try output <|> try output
<|> do { sSKIP ; eol ; return $ OcSkip } <|> do { sSKIP ; eol ; return $ N.Skip }
<|> do { sSTOP ; eol ; return $ OcStop } <|> do { sSTOP ; eol ; return $ N.Stop }
<|> occamSequence <|> occamSequence
<|> conditional <|> conditional
<|> selection <|> selection
@ -587,9 +587,9 @@ process
<|> alternation <|> alternation
<|> try caseInput <|> try caseInput
<|> try procInstance <|> try procInstance
<|> do { sMainMarker ; eol ; return $ OcMainProcess } <|> do { sMainMarker ; eol ; return $ N.MainProcess }
<|> do { a <- allocation ; p <- process ; return $ OcDecl a p } <|> do { a <- allocation ; p <- process ; return $ N.Decl a p }
<|> do { s <- specification ; p <- process ; return $ OcDecl s p } <|> do { s <- specification ; p <- process ; return $ N.Decl s p }
<?> "process" <?> "process"
protocol protocol
@ -598,16 +598,16 @@ protocol
<?> "protocol" <?> "protocol"
real real
= try (do { l <- digits ; char '.' ; r <- digits ; char 'e' ; e <- lexeme occamExponent ; return $ OcLitReal (l ++ "." ++ r ++ "e" ++ e) }) = 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 $ OcLitReal (l ++ "." ++ r) } <|> do { l <- digits ; char '.' ; r <- lexeme digits ; return $ N.LitReal (l ++ "." ++ r) }
<?> "real" <?> "real"
replicator replicator
= do { n <- name ; sEq ; b <- base ; sFOR ; c <- occamCount ; return $ OcFor n b c } = do { n <- name ; sEq ; b <- base ; sFOR ; c <- occamCount ; return $ N.For n b c }
<?> "replicator" <?> "replicator"
selection selection
= do { sCASE ; s <- selector ; eol ; indent ; os <- many1 occamOption ; outdent ; return $ OcCase s os } = do { sCASE ; s <- selector ; eol ; indent ; os <- many1 occamOption ; outdent ; return $ N.Case s os }
<?> "selection" <?> "selection"
selector selector
@ -616,8 +616,8 @@ selector
occamSequence occamSequence
= do sSEQ = do sSEQ
(do { eol ; indent ; ps <- many1 process ; outdent ; return $ OcSeq ps } (do { eol ; indent ; ps <- many1 process ; outdent ; return $ N.Seq ps }
<|> do { r <- replicator ; eol ; indent ; p <- process ; outdent ; return $ OcSeqRep r p }) <|> do { r <- replicator ; eol ; indent ; p <- process ; outdent ; return $ N.SeqRep r p })
<?> "sequence" <?> "sequence"
sequentialProtocol sequentialProtocol
@ -625,9 +625,9 @@ sequentialProtocol
<?> "sequentialProtocol" <?> "sequentialProtocol"
simpleProtocol simpleProtocol
= try (do { l <- dataType ; sColons ; sLeft ; sRight ; r <- dataType ; return $ OcCounted l r }) = try (do { l <- dataType ; sColons ; sLeft ; sRight ; r <- dataType ; return $ N.Counted l r })
<|> dataType <|> dataType
<|> do { sANY ; return $ OcAny } <|> do { sANY ; return $ N.Any }
<?> "simpleProtocol" <?> "simpleProtocol"
specification specification
@ -636,39 +636,39 @@ specification
<|> definition <|> definition
<?> "specification" <?> "specification"
specifier :: Parser Node specifier :: Parser N.Node
specifier specifier
= try dataType = try dataType
<|> try channelType <|> try channelType
<|> try timerType <|> try timerType
<|> try portType <|> try portType
<|> try (do { sLeft ; sRight ; s <- specifier ; return $ OcArrayUnsized s }) <|> try (do { sLeft ; sRight ; s <- specifier ; return $ N.ArrayUnsized s })
<|> do { sLeft ; e <- expression ; sRight ; s <- specifier ; return $ OcArray e s } <|> do { sLeft ; e <- expression ; sRight ; s <- specifier ; return $ N.Array e s }
<?> "specifier" <?> "specifier"
structuredType structuredType
= try (do { sRECORD ; eol ; indent ; fs <- many1 structuredTypeField ; outdent ; return $ OcRecord fs }) = try (do { sRECORD ; eol ; indent ; fs <- many1 structuredTypeField ; outdent ; return $ N.Record fs })
<|> do { sPACKED ; sRECORD ; eol ; indent ; fs <- many1 structuredTypeField ; outdent ; return $ OcPackedRecord fs } <|> do { sPACKED ; sRECORD ; eol ; indent ; fs <- many1 structuredTypeField ; outdent ; return $ N.PackedRecord fs }
<?> "structuredType" <?> "structuredType"
-- FIXME this should use the same type-folding code as proc/func definitions -- FIXME this should use the same type-folding code as proc/func definitions
structuredTypeField structuredTypeField
= do { t <- dataType ; fs <- many1 fieldName ; sColon ; eol ; return $ OcFields t fs } = do { t <- dataType ; fs <- many1 fieldName ; sColon ; eol ; return $ N.Fields t fs }
<?> "structuredTypeField" <?> "structuredTypeField"
-- i.e. array literal -- i.e. array literal
table table
= do { v <- table' ; es <- many (do { sLeft ; e <- expression ; sRight ; return e }) ; return $ foldl OcSub v es } = do { v <- table' ; es <- many (do { sLeft ; e <- expression ; sRight ; return e }) ; return $ foldl N.Sub v es }
<?> "table" <?> "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 $ N.TypedLit n s })
<|> do { sLeft ; <|> do { sLeft ;
try (do { es <- sepBy1 expression sComma ; sRight ; return $ OcLitArray es }) try (do { es <- sepBy1 expression sComma ; sRight ; return $ N.LitArray es })
<|> try (do { n <- table ; sFROM ; e <- expression ; sFOR ; f <- expression ; sRight ; return $ OcSubFromFor n e f }) <|> try (do { n <- table ; sFROM ; e <- expression ; sFOR ; f <- expression ; sRight ; return $ N.SubFromFor n e f })
<|> try (do { n <- table ; sFROM ; e <- expression ; sRight ; return $ OcSubFrom n e }) <|> try (do { n <- table ; sFROM ; e <- expression ; sRight ; return $ N.SubFrom n e })
<|> do { n <- table ; sFOR ; e <- expression ; sRight ; return $ OcSubFor n e } } <|> do { n <- table ; sFOR ; e <- expression ; sRight ; return $ N.SubFor n e } }
<?> "table'" <?> "table'"
tag tag
@ -676,32 +676,32 @@ tag
<?> "tag" <?> "tag"
taggedList taggedList
= try (do { t <- tag ; sSemi ; is <- sepBy1 inputItem sSemi ; return $ OcTag t is }) = try (do { t <- tag ; sSemi ; is <- sepBy1 inputItem sSemi ; return $ N.Tag t is })
<|> do { t <- tag ; return $ OcTag t [] } <|> do { t <- tag ; return $ N.Tag t [] }
<?> "taggedList" <?> "taggedList"
taggedProtocol taggedProtocol
= try (do { t <- tag ; eol ; return $ OcTag t [] }) = try (do { t <- tag ; eol ; return $ N.Tag t [] })
<|> try (do { t <- tag ; sSemi ; sp <- sequentialProtocol ; eol ; return $ OcTag t sp }) <|> try (do { t <- tag ; sSemi ; sp <- sequentialProtocol ; eol ; return $ N.Tag t sp })
timerType timerType
= do { sTIMER ; return $ OcTimer } = do { sTIMER ; return $ N.Timer }
<|> do { try sLeft ; s <- try expression ; try sRight ; t <- timerType ; return $ OcArray s t } <|> do { try sLeft ; s <- try expression ; try sRight ; t <- timerType ; return $ N.Array s t }
<?> "timerType" <?> "timerType"
valueProcess valueProcess
= try (do { sVALOF ; eol ; indent ; p <- process ; sRESULT ; el <- expressionList ; eol ; outdent ; return $ OcValOf p el }) = try (do { sVALOF ; eol ; indent ; p <- process ; sRESULT ; el <- expressionList ; eol ; outdent ; return $ N.ValOf p el })
<|> do { s <- specification ; v <- valueProcess ; return $ OcDecl s v } <|> do { s <- specification ; v <- valueProcess ; return $ N.Decl s v }
variable variable
= do { v <- variable' ; es <- many (do { sLeft ; e <- expression ; sRight ; return e }) ; return $ foldl OcSub v es } = do { v <- variable' ; es <- many (do { sLeft ; e <- expression ; sRight ; return e }) ; return $ foldl N.Sub v es }
<?> "variable" <?> "variable"
variable' variable'
= try name = try name
<|> 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 ; sFOR ; f <- expression ; sRight ; return $ N.SubFromFor n e f })
<|> try (do { sLeft ; n <- variable ; sFROM ; e <- expression ; sRight ; return $ OcSubFrom n e }) <|> try (do { sLeft ; n <- variable ; sFROM ; e <- expression ; sRight ; return $ N.SubFrom n e })
<|> do { sLeft ; n <- variable ; sFOR ; e <- expression ; sRight ; return $ OcSubFor n e } <|> do { sLeft ; n <- variable ; sFOR ; e <- expression ; sRight ; return $ N.SubFor n e }
<?> "variable'" <?> "variable'"
variableList variableList
@ -709,8 +709,8 @@ variableList
<?> "variableList" <?> "variableList"
variant variant
= try (do { t <- taggedList ; eol ; indent ; p <- process ; outdent ; return $ OcVariant t p }) = try (do { t <- taggedList ; eol ; indent ; p <- process ; outdent ; return $ N.Variant t p })
<|> do { s <- specification ; v <- variant ; return $ OcDecl s v } <|> do { s <- specification ; v <- variant ; return $ N.Decl s v }
<?> "variant" <?> "variant"
-- ------------------------------------------------------------- -- -------------------------------------------------------------
@ -777,7 +777,7 @@ readSource fn = do
-- ------------------------------------------------------------- -- -------------------------------------------------------------
parseSource :: String -> Node parseSource :: String -> N.Node
parseSource prep parseSource prep
= case (parse sourceFile "occam" prep) of = case (parse sourceFile "occam" prep) of
Left err -> error ("Parsing error: " ++ (show err)) Left err -> error ("Parsing error: " ++ (show err))

12
fco/Pass.hs
View File

@ -2,12 +2,12 @@
module Pass where module Pass where
import Tree import qualified Tree as N
import Control.Monad.State import Control.Monad.State
type Progress = (String -> IO ()) type Progress = (String -> IO ())
type ITransform st = Node -> State st Node type ITransform st = N.Node -> State st N.Node
-- This is actually a fraction of a pass: an operation upon the tree. -- This is actually a fraction of a pass: an operation upon the tree.
-- The arguments are: -- The arguments are:
-- - "next": the next pass to try if this one doesn't match; -- - "next": the next pass to try if this one doesn't match;
@ -15,7 +15,7 @@ type ITransform st = Node -> State st Node
-- - the input node. -- - the input node.
type Transform st = ITransform st -> ITransform st -> ITransform st type Transform st = ITransform st -> ITransform st -> ITransform st
runTransforms :: st -> [Transform st] -> Node -> Node runTransforms :: st -> [Transform st] -> N.Node -> N.Node
runTransforms initState passes node = evalState (top node) initState runTransforms initState passes node = evalState (top node) initState
where where
fail :: ITransform st fail :: ITransform st
@ -29,19 +29,19 @@ runTransforms initState passes node = evalState (top node) initState
top = head passList top = head passList
type Pass = Node -> Node type Pass = N.Node -> N.Node
makePass :: st -> Transform st -> [Transform st] -> Pass makePass :: st -> Transform st -> [Transform st] -> Pass
makePass initState t bases = runTransforms initState (t : bases) makePass initState t bases = runTransforms initState (t : bases)
data Phase = Phase String [(String, Pass)] data Phase = Phase String [(String, Pass)]
runPhase :: Phase -> Node -> Progress -> IO Node runPhase :: Phase -> N.Node -> Progress -> IO N.Node
runPhase (Phase name passes) n progress = do runPhase (Phase name passes) n progress = do
progress $ "Phase: " ++ name progress $ "Phase: " ++ name
runPhase' (reverse passes) n runPhase' (reverse passes) n
where where
runPhase' :: [(String, Pass)] -> Node -> IO Node runPhase' :: [(String, Pass)] -> N.Node -> IO N.Node
runPhase' [] n = do return n runPhase' [] n = do return n
runPhase' ((name, pass):passes) n = do runPhase' ((name, pass):passes) n = do
rest <- runPhase' passes n rest <- runPhase' passes n

52
fco/PhaseIntermediate.hs
View File

@ -2,7 +2,7 @@
module PhaseIntermediate (phaseIntermediate) where module PhaseIntermediate (phaseIntermediate) where
import Tree import qualified Tree as N
import Pass import Pass
import BaseTransforms import BaseTransforms
import Control.Monad.State import Control.Monad.State
@ -17,55 +17,55 @@ phaseIntermediate
-- , ("Unique identifiers", makePass (0, Map.empty) uniqueIdentifiers bases) -- , ("Unique identifiers", makePass (0, Map.empty) uniqueIdentifiers bases)
]) ])
nestDecls :: [(Node, Node)] -> Node -> Node nestDecls :: [(N.Node, N.Node)] -> N.Node -> N.Node
nestDecls l n = foldl (\a b -> b a) n [IntDecl n d | (OcName n, d) <- l] nestDecls l n = foldl (\a b -> b a) n [N.IntDecl n d | (N.Name n, d) <- l]
markDecls :: Transform () markDecls :: Transform ()
markDecls next top node markDecls next top node
= case node of = case node of
OcDecl (OcProc nn@(OcName n) args code) body -> do N.Decl (N.Proc nn@(N.Name n) args code) body -> do
body' <- top body body' <- top body
code' <- top code code' <- top code
let pdecl = nestDecls [(n, d) | d@(OcFormal _ n) <- args] (OcProc nn args code') let pdecl = nestDecls [(n, d) | d@(N.Formal _ n) <- args] (N.Proc nn args code')
return $ IntDecl n pdecl body' return $ N.IntDecl n pdecl body'
OcDecl (OcFunc nn@(OcName n) args rets code) body -> do N.Decl (N.Func nn@(N.Name n) args rets code) body -> do
error "blah" error "blah"
body' <- top body body' <- top body
code' <- top code code' <- top code
let pdecl = nestDecls [(n, d) | d@(OcFormal _ n) <- args] (OcFunc nn args rets code') let pdecl = nestDecls [(n, d) | d@(N.Formal _ n) <- args] (N.Func nn args rets code')
return $ IntDecl n pdecl body' return $ N.IntDecl n pdecl body'
-- FIXME same for functions -- FIXME same for functions
OcDecl d body -> do N.Decl d body -> do
body' <- top body body' <- top body
return $ case d of return $ case d of
OcVars t ns -> nestDecls [(n, t) | n <- ns] body' N.Vars t ns -> nestDecls [(n, t) | n <- ns] body'
OcIs (OcName n) _ -> IntDecl n d body' N.Is (N.Name n) _ -> N.IntDecl n d body'
OcIsType (OcName n) _ _ -> IntDecl n d body' N.IsType (N.Name n) _ _ -> N.IntDecl n d body'
OcValIs (OcName n) _ -> IntDecl n d body' N.ValIs (N.Name n) _ -> N.IntDecl n d body'
OcValIsType (OcName n) _ _ -> IntDecl n d body' N.ValIsType (N.Name n) _ _ -> N.IntDecl n d body'
OcDataType (OcName n) _ -> IntDecl n d body' N.DataType (N.Name n) _ -> N.IntDecl n d body'
OcProtocol (OcName n) _ -> IntDecl n d body' N.Protocol (N.Name n) _ -> N.IntDecl n d body'
OcFuncIs (OcName n) _ _ _ -> IntDecl n d body' N.FuncIs (N.Name n) _ _ _ -> N.IntDecl n d body'
OcRetypes (OcName n) _ _ -> IntDecl n d body' N.Retypes (N.Name n) _ _ -> N.IntDecl n d body'
OcValRetypes (OcName n) _ _ -> IntDecl n d body' N.ValRetypes (N.Name n) _ _ -> N.IntDecl n d body'
OcReshapes (OcName n) _ _ -> IntDecl n d body' N.Reshapes (N.Name n) _ _ -> N.IntDecl n d body'
OcValReshapes (OcName n) _ _ -> IntDecl n d body' N.ValReshapes (N.Name n) _ _ -> N.IntDecl n d body'
_ -> error ("Unhandled type of declaration: " ++ (show d)) _ -> error ("Unhandled type of declaration: " ++ (show d))
_ -> next node _ -> next node
uniqueIdentifiers :: Transform (Int, Map.Map String String) uniqueIdentifiers :: Transform (Int, Map.Map String String)
uniqueIdentifiers next top node uniqueIdentifiers next top node
= case node of = case node of
IntDecl name def body -> do N.IntDecl name def body -> do
(n, ids) <- get (n, ids) <- get
let newname = name ++ "_" ++ (show n) let newname = name ++ "_" ++ (show n)
put (n + 1, Map.insert name newname ids) put (n + 1, Map.insert name newname ids)
def' <- top def def' <- top def
body' <- top body body' <- top body
modify (\(n, _) -> (n, ids)) modify (\(n, _) -> (n, ids))
return $ IntDecl newname def' body' return $ N.IntDecl newname def' body'
OcName s -> do N.Name s -> do
(_, ids) <- get (_, ids) <- get
return $ if Map.member s ids then OcName (Map.findWithDefault "" s ids) else error ("Unknown identifier: " ++ s) return $ if Map.member s ids then N.Name (Map.findWithDefault "" s ids) else error ("Unknown identifier: " ++ s)
_ -> next node _ -> next node

6
fco/PhaseSource.hs
View File

@ -2,7 +2,7 @@
module PhaseSource (phaseSource) where module PhaseSource (phaseSource) where
import Tree import qualified Tree as N
import Pass import Pass
import BaseTransforms import BaseTransforms
import Control.Monad.State import Control.Monad.State
@ -19,13 +19,13 @@ phaseSource
simplify :: Transform () simplify :: Transform ()
simplify next top node simplify next top node
= case node of = case node of
-- FIXME rewrite stuff like OcFuncIs -> OcFunc -- FIXME rewrite stuff like N.FuncIs -> N.Func
-- FIXME could we even rewrite procs and functions to the same thing? -- FIXME could we even rewrite procs and functions to the same thing?
_ -> next node _ -> next node
cifyIdentifiers :: Transform () cifyIdentifiers :: Transform ()
cifyIdentifiers next top node cifyIdentifiers next top node
= case node of = case node of
OcName n -> return $ OcName [if c == '.' then '_' else c | c <- n] N.Name n -> return $ N.Name [if c == '.' then '_' else c | c <- n]
_ -> next node _ -> next node

486
fco/SExpression.hs
View File

@ -3,7 +3,7 @@
module SExpression where module SExpression where
import List import List
import Tree import qualified Tree as N
data SExp = Item String | List [SExp] data SExp = Item String | List [SExp]
@ -11,129 +11,129 @@ instance Show SExp where
show (Item s) = s show (Item s) = s
show (List is) = "(" ++ (concat $ intersperse " " $ map show is) ++ ")" show (List is) = "(" ++ (concat $ intersperse " " $ map show is) ++ ")"
nodeToSExp :: Node -> SExp nodeToSExp :: N.Node -> SExp
nodeToSExp node nodeToSExp node
= case node of = case node of
OcDecl a b -> wrap2 ":" (top a) (top b) N.Decl a b -> wrap2 ":" (top a) (top b)
OcAlt a -> wrapl "alt" (map top a) N.Alt a -> wrapl "alt" (map top a)
OcAltRep a b -> wrap2 "alt-rep" (top a) (top b) N.AltRep a b -> wrap2 "alt-rep" (top a) (top b)
OcPriAlt a -> wrapl "pri-alt" (map top a) N.PriAlt a -> wrapl "pri-alt" (map top a)
OcPriAltRep a b -> wrap2 "pri-alt-rep" (top a) (top b) N.PriAltRep a b -> wrap2 "pri-alt-rep" (top a) (top b)
OcIn a b -> wrapl1 "?" (top a) (map top b) N.In a b -> wrapl1 "?" (top a) (map top b)
OcVariant a b -> wrap2 "variant" (top a) (top b) N.Variant a b -> wrap2 "variant" (top a) (top b)
OcInCase a b -> wrapl1 "?case" (top a) (map top b) N.InCase a b -> wrapl1 "?case" (top a) (map top b)
OcInCaseGuard a b c -> wrapl2 "?case-guarded" (top a) (top b) (map top c) N.InCaseGuard a b c -> wrapl2 "?case-guarded" (top a) (top b) (map top c)
OcInTag a b -> wrap2 "?case-tag" (top a) (top b) N.InTag a b -> wrap2 "?case-tag" (top a) (top b)
OcInAfter a b -> wrap2 "?after" (top a) (top b) N.InAfter a b -> wrap2 "?after" (top a) (top b)
OcOut a b -> wrapl1 "!" (top a) (map top b) N.Out a b -> wrapl1 "!" (top a) (map top b)
OcOutCase a b c -> wrapl2 "!case" (top a) (top b) (map top c) N.OutCase a b c -> wrapl2 "!case" (top a) (top b) (map top c)
OcExpList a -> wrapl "exp-list" (map top a) N.ExpList a -> wrapl "exp-list" (map top a)
OcAssign a b -> wrap2 ":=" (List $ map top a) (top b) N.Assign a b -> wrap2 ":=" (List $ map top a) (top b)
OcIf a -> wrapl "if" (map top a) N.If a -> wrapl "if" (map top a)
OcIfRep a b -> wrap2 "if-rep" (top a) (top b) N.IfRep a b -> wrap2 "if-rep" (top a) (top b)
OcWhile a b -> wrap2 "while" (top a) (top b) N.While a b -> wrap2 "while" (top a) (top b)
OcPar a -> wrapl "par" (map top a) N.Par a -> wrapl "par" (map top a)
OcParRep a b -> wrap2 "par-rep" (top a) (top b) N.ParRep a b -> wrap2 "par-rep" (top a) (top b)
OcPriPar a -> wrapl "pri-par" (map top a) N.PriPar a -> wrapl "pri-par" (map top a)
OcPriParRep a b -> wrap2 "pri-par-rep" (top a) (top b) N.PriParRep a b -> wrap2 "pri-par-rep" (top a) (top b)
OcPlacedPar a -> wrapl "placed-par" (map top a) N.PlacedPar a -> wrapl "placed-par" (map top a)
OcPlacedParRep a b -> wrap2 "placed-par-rep" (top a) (top b) N.PlacedParRep a b -> wrap2 "placed-par-rep" (top a) (top b)
OcProcessor a b -> wrap2 "processor" (top a) (top b) N.Processor a b -> wrap2 "processor" (top a) (top b)
OcSkip -> Item "skip" N.Skip -> Item "skip"
OcStop -> Item "stop" N.Stop -> Item "stop"
OcCase a b -> wrapl1 "case" (top a) (map top b) N.Case a b -> wrapl1 "case" (top a) (map top b)
OcSeq a -> wrapl "seq" (map top a) N.Seq a -> wrapl "seq" (map top a)
OcSeqRep a b -> wrap2 "seq-rep" (top a) (top b) N.SeqRep a b -> wrap2 "seq-rep" (top a) (top b)
OcProcCall a b -> wrapl1 "proc-call" (top a) (map top b) N.ProcCall a b -> wrapl1 "proc-call" (top a) (map top b)
OcMainProcess -> Item "main" N.MainProcess -> Item "main"
OcVars a b -> wrapl1 "vars" (top a) (map top b) N.Vars a b -> wrapl1 "vars" (top a) (map top b)
OcIs a b -> wrap2 "is" (top a) (top b) N.Is a b -> wrap2 "is" (top a) (top b)
OcIsType a b c -> wrap3 "is-type" (top a) (top b) (top c) N.IsType a b c -> wrap3 "is-type" (top a) (top b) (top c)
OcValIs a b -> wrap2 "val-is" (top a) (top b) N.ValIs a b -> wrap2 "val-is" (top a) (top b)
OcValIsType a b c -> wrap3 "val-is-type" (top a) (top b) (top c) N.ValIsType a b c -> wrap3 "val-is-type" (top a) (top b) (top c)
OcPlace a b -> wrap2 "place-at" (top a) (top b) N.Place a b -> wrap2 "place-at" (top a) (top b)
OcDataType a b -> wrap2 "data-type" (top a) (top b) N.DataType a b -> wrap2 "data-type" (top a) (top b)
OcRecord a -> wrapl "record" (map top a) N.Record a -> wrapl "record" (map top a)
OcPackedRecord a -> wrapl "packed-record" (map top a) N.PackedRecord a -> wrapl "packed-record" (map top a)
OcFields a b -> wrapl1 "fields" (top a) (map top b) N.Fields a b -> wrapl1 "fields" (top a) (map top b)
OcProtocol a b -> wrapl1 "protocol" (top a) (map top b) N.Protocol a b -> wrapl1 "protocol" (top a) (map top b)
OcTaggedProtocol a b -> wrapl1 "protocol-tagged" (top a) (map top b) N.TaggedProtocol a b -> wrapl1 "protocol-tagged" (top a) (map top b)
OcTag a b -> wrapl1 "tag" (top a) (map top b) N.Tag a b -> wrapl1 "tag" (top a) (map top b)
OcFormal a b -> wrap2 "formal" (top a) (top b) N.Formal a b -> wrap2 "formal" (top a) (top b)
OcProc a b c -> wrap3 "proc" (top a) (List $ map top b) (top c) N.Proc a b c -> wrap3 "proc" (top a) (List $ map top b) (top c)
OcFunc a b c d -> wrap4 "function" (top a) (List $ map top b) (List $ map top c) (top d) N.Func a b c d -> wrap4 "function" (top a) (List $ map top b) (List $ map top c) (top d)
OcFuncIs a b c d -> wrap4 "function-is" (top a) (List $ map top b) (List $ map top c) (top d) N.FuncIs a b c d -> wrap4 "function-is" (top a) (List $ map top b) (List $ map top c) (top d)
OcRetypes a b c -> wrap3 "retypes" (top a) (top b) (top c) N.Retypes a b c -> wrap3 "retypes" (top a) (top b) (top c)
OcValRetypes a b c -> wrap3 "val-retypes" (top a) (top b) (top c) N.ValRetypes a b c -> wrap3 "val-retypes" (top a) (top b) (top c)
OcReshapes a b c -> wrap3 "reshapes" (top a) (top b) (top c) N.Reshapes a b c -> wrap3 "reshapes" (top a) (top b) (top c)
OcValReshapes a b c -> wrap3 "val-reshapes" (top a) (top b) (top c) N.ValReshapes a b c -> wrap3 "val-reshapes" (top a) (top b) (top c)
OcValOf a b -> wrap2 "valof" (top a) (top b) N.ValOf a b -> wrap2 "valof" (top a) (top b)
OcSub a b -> wrap2 "sub" (top a) (top b) N.Sub a b -> wrap2 "sub" (top a) (top b)
OcSubFromFor a b c -> wrap3 "sub-from-for" (top a) (top b) (top c) N.SubFromFor a b c -> wrap3 "sub-from-for" (top a) (top b) (top c)
OcSubFrom a b -> wrap2 "sub-from" (top a) (top b) N.SubFrom a b -> wrap2 "sub-from" (top a) (top b)
OcSubFor a b -> wrap2 "sub-for" (top a) (top b) N.SubFor a b -> wrap2 "sub-for" (top a) (top b)
OcCaseExps a b -> wrap2 "case-exps" (List $ map top a) (top b) N.CaseExps a b -> wrap2 "case-exps" (List $ map top a) (top b)
OcElse a -> wrap "else" (top a) N.Else a -> wrap "else" (top a)
OcFor a b c -> wrap3 "for" (top a) (top b) (top c) N.For a b c -> wrap3 "for" (top a) (top b) (top c)
OcConv a b -> wrap2 "conv" (top a) (top b) N.Conv a b -> wrap2 "conv" (top a) (top b)
OcRound a b -> wrap2 "round" (top a) (top b) N.Round a b -> wrap2 "round" (top a) (top b)
OcTrunc a b -> wrap2 "trunc" (top a) (top b) N.Trunc a b -> wrap2 "trunc" (top a) (top b)
OcAdd a b -> wrap2 "+" (top a) (top b) N.Add a b -> wrap2 "+" (top a) (top b)
OcSubtr a b -> wrap2 "-" (top a) (top b) N.Subtr a b -> wrap2 "-" (top a) (top b)
OcMul a b -> wrap2 "*" (top a) (top b) N.Mul a b -> wrap2 "*" (top a) (top b)
OcDiv a b -> wrap2 "/" (top a) (top b) N.Div a b -> wrap2 "/" (top a) (top b)
OcRem a b -> wrap2 "mod" (top a) (top b) N.Rem a b -> wrap2 "mod" (top a) (top b)
OcPlus a b -> wrap2 "plus" (top a) (top b) N.Plus a b -> wrap2 "plus" (top a) (top b)
OcMinus a b -> wrap2 "minus" (top a) (top b) N.Minus a b -> wrap2 "minus" (top a) (top b)
OcTimes a b -> wrap2 "times" (top a) (top b) N.Times a b -> wrap2 "times" (top a) (top b)
OcBitAnd a b -> wrap2 "bitand" (top a) (top b) N.BitAnd a b -> wrap2 "bitand" (top a) (top b)
OcBitOr a b -> wrap2 "bitor" (top a) (top b) N.BitOr a b -> wrap2 "bitor" (top a) (top b)
OcBitXor a b -> wrap2 "bitxor" (top a) (top b) N.BitXor a b -> wrap2 "bitxor" (top a) (top b)
OcAnd a b -> wrap2 "and" (top a) (top b) N.And a b -> wrap2 "and" (top a) (top b)
OcOr a b -> wrap2 "or" (top a) (top b) N.Or a b -> wrap2 "or" (top a) (top b)
OcEq a b -> wrap2 "=" (top a) (top b) N.Eq a b -> wrap2 "=" (top a) (top b)
OcNEq a b -> wrap2 "<>" (top a) (top b) N.NEq a b -> wrap2 "<>" (top a) (top b)
OcLess a b -> wrap2 "<" (top a) (top b) N.Less a b -> wrap2 "<" (top a) (top b)
OcMore a b -> wrap2 ">" (top a) (top b) N.More a b -> wrap2 ">" (top a) (top b)
OcLessEq a b -> wrap2 "<=" (top a) (top b) N.LessEq a b -> wrap2 "<=" (top a) (top b)
OcMoreEq a b -> wrap2 ">=" (top a) (top b) N.MoreEq a b -> wrap2 ">=" (top a) (top b)
OcAfter a b -> wrap2 "after" (top a) (top b) N.After a b -> wrap2 "after" (top a) (top b)
OcMonSub a -> wrap "-" (top a) N.MonSub a -> wrap "-" (top a)
OcMonBitNot a -> wrap "bitnot" (top a) N.MonBitNot a -> wrap "bitnot" (top a)
OcMonNot a -> wrap "not" (top a) N.MonNot a -> wrap "not" (top a)
OcMostPos a -> wrap "mostpos" (top a) N.MostPos a -> wrap "mostpos" (top a)
OcMostNeg a -> wrap "mostneg" (top a) N.MostNeg a -> wrap "mostneg" (top a)
OcSize a -> wrap "size" (top a) N.Size a -> wrap "size" (top a)
OcCall a b -> wrapl1 "call" (top a) (map top b) N.Call a b -> wrapl1 "call" (top a) (map top b)
OcBytesIn a -> wrap "bytesin" (top a) N.BytesIn a -> wrap "bytesin" (top a)
OcOffsetOf a b -> wrap2 "offsetof" (top a) (top b) N.OffsetOf a b -> wrap2 "offsetof" (top a) (top b)
OcGuarded a b -> wrap2 "guarded" (top a) (top b) N.Guarded a b -> wrap2 "guarded" (top a) (top b)
OcVal a -> wrap "val" (top a) N.Val a -> wrap "val" (top a)
OcChanOf a -> wrap "chan" (top a) N.ChanOf a -> wrap "chan" (top a)
OcPortOf a -> wrap "port" (top a) N.PortOf a -> wrap "port" (top a)
OcTimer -> Item "timer" N.Timer -> Item "timer"
OcArray a b -> wrap2 "array" (top a) (top b) N.Array a b -> wrap2 "array" (top a) (top b)
OcArrayUnsized a -> wrap "array-unsized" (top a) N.ArrayUnsized a -> wrap "array-unsized" (top a)
OcCounted a b -> wrap2 "::" (top a) (top b) N.Counted a b -> wrap2 "::" (top a) (top b)
OcBool -> Item "bool" N.Bool -> Item "bool"
OcByte -> Item "byte" N.Byte -> Item "byte"
OcInt -> Item "int" N.Int -> Item "int"
OcInt16 -> Item "int16" N.Int16 -> Item "int16"
OcInt32 -> Item "int32" N.Int32 -> Item "int32"
OcInt64 -> Item "int64" N.Int64 -> Item "int64"
OcReal32 -> Item "real32" N.Real32 -> Item "real32"
OcReal64 -> Item "real64" N.Real64 -> Item "real64"
OcAny -> Item "any" N.Any -> Item "any"
OcTypedLit a b -> wrap2 "typed-literal" (top a) (top b) N.TypedLit a b -> wrap2 "typed-literal" (top a) (top b)
OcLitReal a -> wrap "real-literal" (Item a) N.LitReal a -> wrap "real-literal" (Item a)
OcLitInt a -> wrap "integer-literal" (Item a) N.LitInt a -> wrap "integer-literal" (Item a)
OcLitHex a -> wrap "hex-literal" (Item a) N.LitHex a -> wrap "hex-literal" (Item a)
OcLitByte a -> wrap "byte-literal" (Item ("'" ++ a ++ "'")) N.LitByte a -> wrap "byte-literal" (Item ("'" ++ a ++ "'"))
OcLitString a -> wrap "string-literal" (Item ("\"" ++ a ++ "\"")) N.LitString a -> wrap "string-literal" (Item ("\"" ++ a ++ "\""))
OcLitArray a -> wrapl "array-literal" (map top a) N.LitArray a -> wrapl "array-literal" (map top a)
OcTrue -> Item "true" N.True -> Item "true"
OcFalse -> Item "false" N.False -> Item "false"
OcName a -> wrap "name" (Item a) N.Name a -> wrap "name" (Item a)
_ -> error $ "Unsupported node: " ++ (show node) _ -> error $ "Unsupported node: " ++ (show node)
where top = nodeToSExp where top = nodeToSExp
wrap name arg = List [Item name, arg] wrap name arg = List [Item name, arg]
@ -144,129 +144,129 @@ nodeToSExp node
wrapl1 name arg1 args = List ((Item name) : arg1 : args) wrapl1 name arg1 args = List ((Item name) : arg1 : args)
wrapl2 name arg1 arg2 args = List ((Item name) : arg1 : arg2 : args) wrapl2 name arg1 arg2 args = List ((Item name) : arg1 : arg2 : args)
nodeToSOccam :: Node -> SExp nodeToSOccam :: N.Node -> SExp
nodeToSOccam node nodeToSOccam node
= case node of = case node of
OcDecl a b -> wrap2 ":" (top a) (top b) N.Decl a b -> wrap2 ":" (top a) (top b)
OcAlt a -> wrapl "alt" (map top a) N.Alt a -> wrapl "alt" (map top a)
OcAltRep a b -> wrap2 "alt" (top a) (top b) N.AltRep a b -> wrap2 "alt" (top a) (top b)
OcPriAlt a -> wrapl "pri-alt" (map top a) N.PriAlt a -> wrapl "pri-alt" (map top a)
OcPriAltRep a b -> wrap2 "pri-alt" (top a) (top b) N.PriAltRep a b -> wrap2 "pri-alt" (top a) (top b)
OcIn a b -> wrapl1 "?" (top a) (map top b) N.In a b -> wrapl1 "?" (top a) (map top b)
OcVariant a b -> l2 (top a) (top b) N.Variant a b -> l2 (top a) (top b)
OcInCase a b -> wrapl1 "?case" (top a) (map top b) N.InCase a b -> wrapl1 "?case" (top a) (map top b)
OcInCaseGuard a b c -> wrapl2 "?case-guarded" (top a) (top b) (map top c) N.InCaseGuard a b c -> wrapl2 "?case-guarded" (top a) (top b) (map top c)
OcInTag a b -> wrap2 "?case" (top a) (top b) N.InTag a b -> wrap2 "?case" (top a) (top b)
OcInAfter a b -> wrap2 "?after" (top a) (top b) N.InAfter a b -> wrap2 "?after" (top a) (top b)
OcOut a b -> wrapl1 "!" (top a) (map top b) N.Out a b -> wrapl1 "!" (top a) (map top b)
OcOutCase a b c -> wrapl2 "!case" (top a) (top b) (map top c) N.OutCase a b c -> wrapl2 "!case" (top a) (top b) (map top c)
OcExpList a -> List (map top a) N.ExpList a -> List (map top a)
OcAssign a b -> wrap2 ":=" (List $ map top a) (top b) N.Assign a b -> wrap2 ":=" (List $ map top a) (top b)
OcIf a -> wrapl "if" (map top a) N.If a -> wrapl "if" (map top a)
OcIfRep a b -> wrap2 "if" (top a) (top b) N.IfRep a b -> wrap2 "if" (top a) (top b)
OcWhile a b -> wrap2 "while" (top a) (top b) N.While a b -> wrap2 "while" (top a) (top b)
OcPar a -> wrapl "par" (map top a) N.Par a -> wrapl "par" (map top a)
OcParRep a b -> wrap2 "par" (top a) (top b) N.ParRep a b -> wrap2 "par" (top a) (top b)
OcPriPar a -> wrapl "pri-par" (map top a) N.PriPar a -> wrapl "pri-par" (map top a)
OcPriParRep a b -> wrap2 "pri-par" (top a) (top b) N.PriParRep a b -> wrap2 "pri-par" (top a) (top b)
OcPlacedPar a -> wrapl "placed-par" (map top a) N.PlacedPar a -> wrapl "placed-par" (map top a)
OcPlacedParRep a b -> wrap2 "placed-par" (top a) (top b) N.PlacedParRep a b -> wrap2 "placed-par" (top a) (top b)
OcProcessor a b -> wrap2 "processor" (top a) (top b) N.Processor a b -> wrap2 "processor" (top a) (top b)
OcSkip -> Item "skip" N.Skip -> Item "skip"
OcStop -> Item "stop" N.Stop -> Item "stop"
OcCase a b -> wrapl1 "case" (top a) (map top b) N.Case a b -> wrapl1 "case" (top a) (map top b)
OcSeq a -> wrapl "seq" (map top a) N.Seq a -> wrapl "seq" (map top a)
OcSeqRep a b -> wrap2 "seq" (top a) (top b) N.SeqRep a b -> wrap2 "seq" (top a) (top b)
OcProcCall a b -> List ((top a) : (map top b)) N.ProcCall a b -> List ((top a) : (map top b))
OcMainProcess -> Item "main" N.MainProcess -> Item "main"
OcVars a b -> List ((top a) : (map top b)) N.Vars a b -> List ((top a) : (map top b))
OcIs a b -> wrap2 "is" (top a) (top b) N.Is a b -> wrap2 "is" (top a) (top b)
OcIsType a b c -> wrap3 "is" (top a) (top b) (top c) N.IsType a b c -> wrap3 "is" (top a) (top b) (top c)
OcValIs a b -> wrap2 "val-is" (top a) (top b) N.ValIs a b -> wrap2 "val-is" (top a) (top b)
OcValIsType a b c -> wrap3 "val-is" (top a) (top b) (top c) N.ValIsType a b c -> wrap3 "val-is" (top a) (top b) (top c)
OcPlace a b -> wrap2 "place-at" (top a) (top b) N.Place a b -> wrap2 "place-at" (top a) (top b)
OcDataType a b -> wrap2 "data-type" (top a) (top b) N.DataType a b -> wrap2 "data-type" (top a) (top b)
OcRecord a -> wrapl "record" (map top a) N.Record a -> wrapl "record" (map top a)
OcPackedRecord a -> wrapl "packed-record" (map top a) N.PackedRecord a -> wrapl "packed-record" (map top a)
OcFields a b -> List ((top a) : (map top b)) N.Fields a b -> List ((top a) : (map top b))
OcProtocol a b -> wrapl1 "protocol" (top a) (map top b) N.Protocol a b -> wrapl1 "protocol" (top a) (map top b)
OcTaggedProtocol a b -> wrapl1 "protocol" (top a) (map top b) N.TaggedProtocol a b -> wrapl1 "protocol" (top a) (map top b)
OcTag a b -> List ((top a) : (map top b)) N.Tag a b -> List ((top a) : (map top b))
OcFormal a b -> l2 (top a) (top b) N.Formal a b -> l2 (top a) (top b)
OcProc a b c -> wrap3 "proc" (top a) (List $ map top b) (top c) N.Proc a b c -> wrap3 "proc" (top a) (List $ map top b) (top c)
OcFunc a b c d -> wrap4 "function" (top a) (List $ map top b) (List $ map top c) (top d) N.Func a b c d -> wrap4 "function" (top a) (List $ map top b) (List $ map top c) (top d)
OcFuncIs a b c d -> wrap4 "function-is" (top a) (List $ map top b) (List $ map top c) (top d) N.FuncIs a b c d -> wrap4 "function-is" (top a) (List $ map top b) (List $ map top c) (top d)
OcRetypes a b c -> wrap3 "retypes" (top a) (top b) (top c) N.Retypes a b c -> wrap3 "retypes" (top a) (top b) (top c)
OcValRetypes a b c -> wrap3 "val-retypes" (top a) (top b) (top c) N.ValRetypes a b c -> wrap3 "val-retypes" (top a) (top b) (top c)
OcReshapes a b c -> wrap3 "reshapes" (top a) (top b) (top c) N.Reshapes a b c -> wrap3 "reshapes" (top a) (top b) (top c)
OcValReshapes a b c -> wrap3 "val-reshapes" (top a) (top b) (top c) N.ValReshapes a b c -> wrap3 "val-reshapes" (top a) (top b) (top c)
OcValOf a b -> wrap2 "valof" (top a) (top b) N.ValOf a b -> wrap2 "valof" (top a) (top b)
OcSub a b -> wrap2 "sub" (top a) (top b) N.Sub a b -> wrap2 "sub" (top a) (top b)
OcSubFromFor a b c -> wrap3 "sub-from-for" (top a) (top b) (top c) N.SubFromFor a b c -> wrap3 "sub-from-for" (top a) (top b) (top c)
OcSubFrom a b -> wrap2 "sub-from" (top a) (top b) N.SubFrom a b -> wrap2 "sub-from" (top a) (top b)
OcSubFor a b -> wrap2 "sub-for" (top a) (top b) N.SubFor a b -> wrap2 "sub-for" (top a) (top b)
OcCaseExps a b -> l2 (List $ map top a) (top b) N.CaseExps a b -> l2 (List $ map top a) (top b)
OcElse a -> wrap "else" (top a) N.Else a -> wrap "else" (top a)
OcFor a b c -> wrap3 "for" (top a) (top b) (top c) N.For a b c -> wrap3 "for" (top a) (top b) (top c)
OcConv a b -> wrap2 "conv" (top a) (top b) N.Conv a b -> wrap2 "conv" (top a) (top b)
OcRound a b -> wrap2 "round" (top a) (top b) N.Round a b -> wrap2 "round" (top a) (top b)
OcTrunc a b -> wrap2 "trunc" (top a) (top b) N.Trunc a b -> wrap2 "trunc" (top a) (top b)
OcAdd a b -> wrap2 "+" (top a) (top b) N.Add a b -> wrap2 "+" (top a) (top b)
OcSubtr a b -> wrap2 "-" (top a) (top b) N.Subtr a b -> wrap2 "-" (top a) (top b)
OcMul a b -> wrap2 "*" (top a) (top b) N.Mul a b -> wrap2 "*" (top a) (top b)
OcDiv a b -> wrap2 "/" (top a) (top b) N.Div a b -> wrap2 "/" (top a) (top b)
OcRem a b -> wrap2 "mod" (top a) (top b) N.Rem a b -> wrap2 "mod" (top a) (top b)
OcPlus a b -> wrap2 "plus" (top a) (top b) N.Plus a b -> wrap2 "plus" (top a) (top b)
OcMinus a b -> wrap2 "minus" (top a) (top b) N.Minus a b -> wrap2 "minus" (top a) (top b)
OcTimes a b -> wrap2 "times" (top a) (top b) N.Times a b -> wrap2 "times" (top a) (top b)
OcBitAnd a b -> wrap2 "bitand" (top a) (top b) N.BitAnd a b -> wrap2 "bitand" (top a) (top b)
OcBitOr a b -> wrap2 "bitor" (top a) (top b) N.BitOr a b -> wrap2 "bitor" (top a) (top b)
OcBitXor a b -> wrap2 "bitxor" (top a) (top b) N.BitXor a b -> wrap2 "bitxor" (top a) (top b)
OcAnd a b -> wrap2 "and" (top a) (top b) N.And a b -> wrap2 "and" (top a) (top b)
OcOr a b -> wrap2 "or" (top a) (top b) N.Or a b -> wrap2 "or" (top a) (top b)
OcEq a b -> wrap2 "=" (top a) (top b) N.Eq a b -> wrap2 "=" (top a) (top b)
OcNEq a b -> wrap2 "<>" (top a) (top b) N.NEq a b -> wrap2 "<>" (top a) (top b)
OcLess a b -> wrap2 "<" (top a) (top b) N.Less a b -> wrap2 "<" (top a) (top b)
OcMore a b -> wrap2 ">" (top a) (top b) N.More a b -> wrap2 ">" (top a) (top b)
OcLessEq a b -> wrap2 "<=" (top a) (top b) N.LessEq a b -> wrap2 "<=" (top a) (top b)
OcMoreEq a b -> wrap2 ">=" (top a) (top b) N.MoreEq a b -> wrap2 ">=" (top a) (top b)
OcAfter a b -> wrap2 "after" (top a) (top b) N.After a b -> wrap2 "after" (top a) (top b)
OcMonSub a -> wrap "-" (top a) N.MonSub a -> wrap "-" (top a)
OcMonBitNot a -> wrap "bitnot" (top a) N.MonBitNot a -> wrap "bitnot" (top a)
OcMonNot a -> wrap "not" (top a) N.MonNot a -> wrap "not" (top a)
OcMostPos a -> wrap "mostpos" (top a) N.MostPos a -> wrap "mostpos" (top a)
OcMostNeg a -> wrap "mostneg" (top a) N.MostNeg a -> wrap "mostneg" (top a)
OcSize a -> wrap "size" (top a) N.Size a -> wrap "size" (top a)
OcCall a b -> wrapl1 "call" (top a) (map top b) N.Call a b -> wrapl1 "call" (top a) (map top b)
OcBytesIn a -> wrap "bytesin" (top a) N.BytesIn a -> wrap "bytesin" (top a)
OcOffsetOf a b -> wrap2 "offsetof" (top a) (top b) N.OffsetOf a b -> wrap2 "offsetof" (top a) (top b)
OcGuarded a b -> wrap2 "guarded" (top a) (top b) N.Guarded a b -> wrap2 "guarded" (top a) (top b)
OcVal a -> wrap "val" (top a) N.Val a -> wrap "val" (top a)
OcChanOf a -> wrap "chan" (top a) N.ChanOf a -> wrap "chan" (top a)
OcPortOf a -> wrap "port" (top a) N.PortOf a -> wrap "port" (top a)
OcTimer -> Item "timer" N.Timer -> Item "timer"
OcArray a b -> wrap2 "array" (top a) (top b) N.Array a b -> wrap2 "array" (top a) (top b)
OcArrayUnsized a -> wrap "array" (top a) N.ArrayUnsized a -> wrap "array" (top a)
OcCounted a b -> wrap2 "::" (top a) (top b) N.Counted a b -> wrap2 "::" (top a) (top b)
OcBool -> Item "bool" N.Bool -> Item "bool"
OcByte -> Item "byte" N.Byte -> Item "byte"
OcInt -> Item "int" N.Int -> Item "int"
OcInt16 -> Item "int16" N.Int16 -> Item "int16"
OcInt32 -> Item "int32" N.Int32 -> Item "int32"
OcInt64 -> Item "int64" N.Int64 -> Item "int64"
OcReal32 -> Item "real32" N.Real32 -> Item "real32"
OcReal64 -> Item "real64" N.Real64 -> Item "real64"
OcAny -> Item "any" N.Any -> Item "any"
OcTypedLit a b -> l2 (top a) (top b) N.TypedLit a b -> l2 (top a) (top b)
OcLitReal a -> Item a N.LitReal a -> Item a
OcLitInt a -> Item a N.LitInt a -> Item a
OcLitHex a -> Item a N.LitHex a -> Item a
OcLitByte a -> Item ("'" ++ a ++ "'") N.LitByte a -> Item ("'" ++ a ++ "'")
OcLitString a -> Item ("\"" ++ a ++ "\"") N.LitString a -> Item ("\"" ++ a ++ "\"")
OcLitArray a -> List (map top a) N.LitArray a -> List (map top a)
OcTrue -> Item "true" N.True -> Item "true"
OcFalse -> Item "false" N.False -> Item "false"
OcName a -> Item a N.Name a -> Item a
_ -> error $ "Unsupported node: " ++ (show node) _ -> error $ "Unsupported node: " ++ (show node)
where top = nodeToSOccam where top = nodeToSOccam
wrap name arg = List [Item name, arg] wrap name arg = List [Item name, arg]

248
fco/Tree.hs
View File

@ -1,141 +1,143 @@
-- Tree datatype and operations -- Tree datatype and operations
-- This is intended to be imported qualified:
-- import qualified Tree as N
module Tree where module Tree where
data Node = data Node =
-- {{{ BEGIN baseTransformOc -- {{{ BEGIN baseTransformOc
OcDecl Node Node Decl Node Node
| OcAlt [Node] | Alt [Node]
| OcAltRep Node Node | AltRep Node Node
| OcPriAlt [Node] | PriAlt [Node]
| OcPriAltRep Node Node | PriAltRep Node Node
| OcIn Node [Node] | In Node [Node]
-- e.g. OcInCase (OcName "c") [OcVariant .., OcVariant ..] -- e.g. InCase (Name "c") [Variant .., Variant ..]
| OcVariant Node Node | Variant Node Node
| OcInCase Node [Node] | InCase Node [Node]
| OcInCaseGuard Node Node [Node] | InCaseGuard Node Node [Node]
-- FIXME can turn into OcInCase ... (OcVariant .. OcSkip) -- FIXME can turn into InCase ... (Variant .. Skip)
| OcInTag Node Node | InTag Node Node
| OcOut Node [Node] | Out Node [Node]
| OcOutCase Node Node [Node] | OutCase Node Node [Node]
| OcExpList [Node] | ExpList [Node]
| OcAssign [Node] Node | Assign [Node] Node
| OcIf [Node] | If [Node]
| OcIfRep Node Node | IfRep Node Node
| OcInAfter Node Node | InAfter Node Node
| OcWhile Node Node | While Node Node
| OcPar [Node] | Par [Node]
| OcParRep Node Node | ParRep Node Node
| OcPriPar [Node] | PriPar [Node]
| OcPriParRep Node Node | PriParRep Node Node
| OcPlacedPar [Node] | PlacedPar [Node]
| OcPlacedParRep Node Node | PlacedParRep Node Node
| OcProcessor Node Node | Processor Node Node
| OcSkip | Skip
| OcStop | Stop
| OcCase Node [Node] | Case Node [Node]
| OcSeq [Node] | Seq [Node]
| OcSeqRep Node Node | SeqRep Node Node
| OcProcCall Node [Node] | ProcCall Node [Node]
| OcMainProcess | MainProcess
| OcVars Node [Node] | Vars Node [Node]
| OcIs Node Node | Is Node Node
| OcIsType Node Node Node | IsType Node Node Node
| OcValIs Node Node | ValIs Node Node
| OcValIsType Node Node Node | ValIsType Node Node Node
| OcPlace Node Node | Place Node Node
| OcDataType Node Node | DataType Node Node
| OcRecord [Node] | Record [Node]
| OcPackedRecord [Node] | PackedRecord [Node]
| OcFields Node [Node] | Fields Node [Node]
| OcProtocol Node [Node] | Protocol Node [Node]
| OcTaggedProtocol Node [Node] | TaggedProtocol Node [Node]
| OcTag Node [Node] | Tag Node [Node]
-- e.g. OcProc (OcName "out.string") [OcFormal OcInt (OcName "x"), OcFormal OcBool (OcName "y")] -- e.g. Proc (Name "out.string") [Formal Int (Name "x"), Formal Bool (Name "y")]
| OcFormal Node Node | Formal Node Node
| OcProc Node [Node] Node | Proc Node [Node] Node
| OcFunc Node [Node] [Node] Node | Func Node [Node] [Node] Node
| OcFuncIs Node [Node] [Node] Node | FuncIs Node [Node] [Node] Node
| OcRetypes Node Node Node | Retypes Node Node Node
| OcValRetypes Node Node Node | ValRetypes Node Node Node
| OcReshapes Node Node Node | Reshapes Node Node Node
| OcValReshapes Node Node Node | ValReshapes Node Node Node
| OcValOf Node Node | ValOf Node Node
| OcSub Node Node | Sub Node Node
| OcSubFromFor Node Node Node | SubFromFor Node Node Node
| OcSubFrom Node Node | SubFrom Node Node
| OcSubFor Node Node | SubFor Node Node
| OcCaseExps [Node] Node | CaseExps [Node] Node
| OcElse Node | Else Node
| OcFor Node Node Node | For Node Node Node
| OcConv Node Node | Conv Node Node
| OcRound Node Node | Round Node Node
| OcTrunc Node Node | Trunc Node Node
| OcAdd Node Node | Add Node Node
| OcSubtr Node Node | Subtr Node Node
| OcMul Node Node | Mul Node Node
| OcDiv Node Node | Div Node Node
| OcRem Node Node | Rem Node Node
| OcPlus Node Node | Plus Node Node
| OcMinus Node Node | Minus Node Node
| OcTimes Node Node | Times Node Node
| OcBitAnd Node Node | BitAnd Node Node
| OcBitOr Node Node | BitOr Node Node
| OcBitXor Node Node | BitXor Node Node
| OcAnd Node Node | And Node Node
| OcOr Node Node | Or Node Node
| OcEq Node Node | Eq Node Node
| OcNEq Node Node | NEq Node Node
| OcLess Node Node | Less Node Node
| OcMore Node Node | More Node Node
| OcLessEq Node Node | LessEq Node Node
| OcMoreEq Node Node | MoreEq Node Node
| OcAfter Node Node | After Node Node
| OcMonSub Node | MonSub Node
| OcMonBitNot Node | MonBitNot Node
| OcMonNot Node | MonNot Node
| OcMostPos Node | MostPos Node
| OcMostNeg Node | MostNeg Node
| OcSize Node | Size Node
| OcCall Node [Node] | Call Node [Node]
| OcBytesIn Node | BytesIn Node
| OcOffsetOf Node Node | OffsetOf Node Node
| OcGuarded Node Node | Guarded Node Node
| OcVal Node | Val Node
| OcChanOf Node | ChanOf Node
| OcPortOf Node | PortOf Node
| OcTimer | Timer
| OcArray Node Node | Array Node Node
| OcArrayUnsized Node | ArrayUnsized Node
| OcCounted Node Node | Counted Node Node
| OcBool | Bool
| OcByte | Byte
| OcInt | Int
| OcInt16 | Int16
| OcInt32 | Int32
| OcInt64 | Int64
| OcReal32 | Real32
| OcReal64 | Real64
| OcAny | Any
| OcTypedLit Node Node | TypedLit Node Node
| OcLitReal String | LitReal String
| OcLitInt String | LitInt String
| OcLitHex String | LitHex String
| OcLitByte String | LitByte String
| OcLitString String | LitString String
| OcLitArray [Node] | LitArray [Node]
| OcTrue | True
| OcFalse | False
| OcName String | Name String
-- }}} END -- }}} END
-- {{{ BEGIN baseTransformInt -- {{{ BEGIN baseTransformInt

4
fco/make-passthrough.py
View File

@ -24,7 +24,7 @@ def update_def(func, f, newf):
s = s.replace("| ", "") s = s.replace("| ", "")
fields = s.split() fields = s.split()
name = fields[0] name = "N." + fields[0]
args = fields[1:] args = fields[1:]
lhs = [] lhs = []
@ -64,7 +64,7 @@ def main():
module BaseTransforms where module BaseTransforms where
import Tree import qualified Tree as N
import Pass import Pass
import Control.Monad import Control.Monad
""") """)