First stuff for fco2 -- copied from fco
This commit is contained in:
Adam Sampson
parent
6dbb86f610
commit
c8c7935905
199
fco2/AST.hs
Normal file
199
fco2/AST.hs
Normal file
|
|
@ -0,0 +1,199 @@
|
||||||
|
-- Data types for occam abstract syntax
|
||||||
|
-- This is intended to be imported qualified:
|
||||||
|
-- import qualified AST as O
|
||||||
|
|
||||||
|
module AST where
|
||||||
|
|
||||||
|
import Data.Generics
|
||||||
|
import Metadata
|
||||||
|
|
||||||
|
data Name = Name Meta String
|
||||||
|
deriving (Show, Eq, Typeable, Data)
|
||||||
|
|
||||||
|
data Tag = Tag Meta String
|
||||||
|
deriving (Show, Eq, Typeable, Data)
|
||||||
|
|
||||||
|
data Type =
|
||||||
|
Bool
|
||||||
|
| Byte
|
||||||
|
| Int | Int16 | Int32 | Int64
|
||||||
|
| Real32 | Real64
|
||||||
|
| Array Expression Type
|
||||||
|
| ArrayUnsized Type
|
||||||
|
| UserType Name
|
||||||
|
| Chan Type
|
||||||
|
| Counted Type Type
|
||||||
|
| Any
|
||||||
|
| Timer
|
||||||
|
| Port Type
|
||||||
|
| Val Type
|
||||||
|
| Infer -- for where the type is not given but can be worked out (e.g. "x IS y:")
|
||||||
|
deriving (Show, Eq, Typeable, Data)
|
||||||
|
|
||||||
|
data ConversionMode =
|
||||||
|
DefaultConversion
|
||||||
|
| Round
|
||||||
|
| Trunc
|
||||||
|
deriving (Show, Eq, Typeable, Data)
|
||||||
|
|
||||||
|
data Subscript =
|
||||||
|
Subscript Meta Expression
|
||||||
|
| SubscriptTag Meta Tag
|
||||||
|
| SubFromFor Meta Expression Expression
|
||||||
|
| SubFrom Meta Expression
|
||||||
|
| SubFor Meta Expression
|
||||||
|
deriving (Show, Eq, Typeable, Data)
|
||||||
|
|
||||||
|
data LiteralRepr =
|
||||||
|
RealLiteral Meta String
|
||||||
|
| IntLiteral Meta String
|
||||||
|
| HexLiteral Meta String
|
||||||
|
| ByteLiteral Meta String
|
||||||
|
| StringLiteral Meta String
|
||||||
|
| ArrayLiteral Meta [Expression]
|
||||||
|
deriving (Show, Eq, Typeable, Data)
|
||||||
|
|
||||||
|
data Literal =
|
||||||
|
Literal Meta Type LiteralRepr
|
||||||
|
| SubscriptedLiteral Meta Subscript Literal
|
||||||
|
deriving (Show, Eq, Typeable, Data)
|
||||||
|
|
||||||
|
data Variable =
|
||||||
|
Variable Meta Name
|
||||||
|
| SubscriptedVariable Meta Subscript Variable
|
||||||
|
deriving (Show, Eq, Typeable, Data)
|
||||||
|
|
||||||
|
data Expression =
|
||||||
|
Monadic Meta MonadicOp Expression
|
||||||
|
| Dyadic Meta DyadicOp Expression Expression
|
||||||
|
| MostPos Meta Type
|
||||||
|
| MostNeg Meta Type
|
||||||
|
| Size Meta Type
|
||||||
|
| Conversion Meta ConversionMode Type Expression
|
||||||
|
| ExprVariable Meta Variable
|
||||||
|
| ExprLiteral Meta Literal
|
||||||
|
| True Meta
|
||||||
|
| False Meta
|
||||||
|
| FunctionCall Meta Name [Expression]
|
||||||
|
| BytesInType Meta Type
|
||||||
|
| OffsetOf Meta Type Tag
|
||||||
|
deriving (Show, Eq, Typeable, Data)
|
||||||
|
|
||||||
|
data ExpressionList =
|
||||||
|
FunctionCallList Meta Name [Expression]
|
||||||
|
| ExpressionList Meta [Expression]
|
||||||
|
deriving (Show, Eq, Typeable, Data)
|
||||||
|
|
||||||
|
data MonadicOp =
|
||||||
|
MonadicBytesIn
|
||||||
|
| MonadicSubtr
|
||||||
|
| MonadicBitNot
|
||||||
|
| MonadicNot
|
||||||
|
| MonadicSize
|
||||||
|
deriving (Show, Eq, Typeable, Data)
|
||||||
|
|
||||||
|
data DyadicOp =
|
||||||
|
Add | Subtr | Mul | Div | Rem
|
||||||
|
| Plus | Minus | Times
|
||||||
|
| BitAnd | BitOr | BitXor
|
||||||
|
| And | Or
|
||||||
|
| Eq | NotEq | Less | More | LessEq | MoreEq
|
||||||
|
| After
|
||||||
|
deriving (Show, Eq, Typeable, Data)
|
||||||
|
|
||||||
|
data InputItem =
|
||||||
|
InCounted Meta Variable Variable
|
||||||
|
| InVariable Meta Variable
|
||||||
|
deriving (Show, Eq, Typeable, Data)
|
||||||
|
|
||||||
|
data OutputItem =
|
||||||
|
OutCounted Meta Expression Expression
|
||||||
|
| OutExpression Meta Expression
|
||||||
|
deriving (Show, Eq, Typeable, Data)
|
||||||
|
|
||||||
|
data Replicator = For Meta Name Expression Expression
|
||||||
|
deriving (Show, Eq, Typeable, Data)
|
||||||
|
|
||||||
|
data Choice = Choice Meta Expression Process
|
||||||
|
deriving (Show, Eq, Typeable, Data)
|
||||||
|
|
||||||
|
data Alternative =
|
||||||
|
Alternative Meta Variable InputMode Process
|
||||||
|
| AlternativeCond Meta Expression Variable InputMode Process
|
||||||
|
| AlternativeSkip Meta Expression Process
|
||||||
|
deriving (Show, Eq, Typeable, Data)
|
||||||
|
|
||||||
|
data Option =
|
||||||
|
Option Meta [Expression] Process
|
||||||
|
| Else Meta Process
|
||||||
|
deriving (Show, Eq, Typeable, Data)
|
||||||
|
|
||||||
|
data Variant = Variant Meta Tag [InputItem] Process
|
||||||
|
deriving (Show, Eq, Typeable, Data)
|
||||||
|
|
||||||
|
-- This represents something that can contain local replicators and specifications.
|
||||||
|
-- (This ought to be a parametric type, "Structured Variant" etc., but doing so
|
||||||
|
-- makes using generic functions across it hard.)
|
||||||
|
data Structured =
|
||||||
|
Rep Meta Replicator Structured
|
||||||
|
| Spec Meta Specification Structured
|
||||||
|
| OnlyV Meta Variant
|
||||||
|
| OnlyC Meta Choice
|
||||||
|
| OnlyO Meta Option
|
||||||
|
| OnlyP Meta Process
|
||||||
|
| OnlyA Meta Alternative
|
||||||
|
| Several Meta [Structured]
|
||||||
|
deriving (Show, Eq, Typeable, Data)
|
||||||
|
|
||||||
|
data InputMode =
|
||||||
|
InputSimple Meta [InputItem]
|
||||||
|
| InputCase Meta Structured
|
||||||
|
| InputAfter Meta Expression
|
||||||
|
deriving (Show, Eq, Typeable, Data)
|
||||||
|
|
||||||
|
type Formals = [(Type, Name)]
|
||||||
|
type Specification = (Name, SpecType)
|
||||||
|
data SpecType =
|
||||||
|
Place Meta Expression
|
||||||
|
| Declaration Meta Type
|
||||||
|
| Is Meta Type Variable
|
||||||
|
| ValIs Meta Type Expression
|
||||||
|
| DataTypeIs Meta Type
|
||||||
|
| DataTypeRecord Meta Bool [(Type, Tag)]
|
||||||
|
| ProtocolIs Meta [Type]
|
||||||
|
| ProtocolCase Meta [(Tag, [Type])]
|
||||||
|
| Proc Meta Formals Process
|
||||||
|
| Function Meta [Type] Formals ValueProcess
|
||||||
|
| Retypes Meta Type Variable
|
||||||
|
| Reshapes Meta Type Variable
|
||||||
|
| ValRetypes Meta Type Variable
|
||||||
|
| ValReshapes Meta Type Variable
|
||||||
|
deriving (Show, Eq, Typeable, Data)
|
||||||
|
|
||||||
|
data ValueProcess =
|
||||||
|
ValOfSpec Meta Specification ValueProcess
|
||||||
|
| ValOf Meta Process ExpressionList
|
||||||
|
deriving (Show, Eq, Typeable, Data)
|
||||||
|
|
||||||
|
data Process =
|
||||||
|
ProcSpec Meta Specification Process
|
||||||
|
| Assign Meta [Variable] ExpressionList
|
||||||
|
| Input Meta Variable InputMode
|
||||||
|
| Output Meta Variable [OutputItem]
|
||||||
|
| OutputCase Meta Variable Tag [OutputItem]
|
||||||
|
| Skip Meta
|
||||||
|
| Stop Meta
|
||||||
|
| Main Meta
|
||||||
|
| Seq Meta [Process]
|
||||||
|
| SeqRep Meta Replicator Process
|
||||||
|
| If Meta Structured
|
||||||
|
| Case Meta Expression Structured
|
||||||
|
| While Meta Expression Process
|
||||||
|
| Par Meta Bool [Process]
|
||||||
|
| ParRep Meta Bool Replicator Process
|
||||||
|
| PlacedPar Meta Structured
|
||||||
|
| Processor Meta Expression Process
|
||||||
|
| Alt Meta Bool Structured
|
||||||
|
| ProcCall Meta Name [Expression]
|
||||||
|
deriving (Show, Eq, Typeable, Data)
|
||||||
|
|
||||||
87
fco2/Main.hs
Normal file
87
fco2/Main.hs
Normal file
|
|
@ -0,0 +1,87 @@
|
||||||
|
-- Driver for FCO
|
||||||
|
|
||||||
|
module Main where
|
||||||
|
|
||||||
|
import List
|
||||||
|
import System
|
||||||
|
import System.Console.GetOpt
|
||||||
|
import System.IO
|
||||||
|
|
||||||
|
import PrettyShow
|
||||||
|
import Parse
|
||||||
|
import SExpression
|
||||||
|
import Pass
|
||||||
|
import PTPasses
|
||||||
|
import PTToAST
|
||||||
|
import ASTPasses
|
||||||
|
import COutput
|
||||||
|
|
||||||
|
data Flag = ParseOnly | SOccamOnly | Verbose
|
||||||
|
deriving (Eq, Show)
|
||||||
|
|
||||||
|
options :: [OptDescr Flag]
|
||||||
|
options =
|
||||||
|
[ Option [] ["parse-tree"] (NoArg ParseOnly) "parse input files and output S-expression parse tree"
|
||||||
|
, Option [] ["soccam"] (NoArg SOccamOnly) "parse input files and output soccam"
|
||||||
|
, Option ['v'] ["verbose"] (NoArg Verbose) "show more detail about what's going on"
|
||||||
|
]
|
||||||
|
|
||||||
|
getOpts :: [String] -> IO ([Flag], [String])
|
||||||
|
getOpts argv =
|
||||||
|
case getOpt RequireOrder options argv of
|
||||||
|
(o,n,[] ) -> return (o,n)
|
||||||
|
(_,_,errs) -> error (concat errs ++ usageInfo header options)
|
||||||
|
where header = "Usage: fco [OPTION...] SOURCEFILE"
|
||||||
|
|
||||||
|
numberedListing :: String -> String
|
||||||
|
numberedListing s = concat $ intersperse "\n" $ [(show n) ++ ": " ++ s | (n, s) <- zip [1..] (lines s)]
|
||||||
|
|
||||||
|
main :: IO ()
|
||||||
|
main = do
|
||||||
|
argv <- getArgs
|
||||||
|
(opts, args) <- getOpts argv
|
||||||
|
|
||||||
|
let fn = case args of
|
||||||
|
[fn] -> fn
|
||||||
|
_ -> error "Must specify a single input file"
|
||||||
|
|
||||||
|
let progress = if Verbose `elem` opts then hPutStrLn stderr else (\s -> return ())
|
||||||
|
|
||||||
|
progress $ "Options: " ++ (show opts)
|
||||||
|
progress $ "Compiling " ++ fn
|
||||||
|
progress ""
|
||||||
|
|
||||||
|
progress "{{{ Preprocessor"
|
||||||
|
preprocessed <- readSource fn
|
||||||
|
progress $ numberedListing preprocessed
|
||||||
|
progress "}}}"
|
||||||
|
|
||||||
|
progress "{{{ Parser"
|
||||||
|
let pt = parseSource preprocessed fn
|
||||||
|
progress $ pshow pt
|
||||||
|
progress "}}}"
|
||||||
|
|
||||||
|
if ParseOnly `elem` opts then do
|
||||||
|
putStrLn $ show (nodeToSExp pt)
|
||||||
|
else if SOccamOnly `elem` opts then do
|
||||||
|
putStrLn $ show (nodeToSOccam pt)
|
||||||
|
else do
|
||||||
|
progress "{{{ PT passes"
|
||||||
|
pt' <- runPasses ptPasses progress pt
|
||||||
|
progress "}}}"
|
||||||
|
|
||||||
|
progress "{{{ PT to AST"
|
||||||
|
let ast = ptToAST pt'
|
||||||
|
progress $ pshow ast
|
||||||
|
progress "}}}"
|
||||||
|
|
||||||
|
progress "{{{ AST passes"
|
||||||
|
ast' <- runPasses astPasses progress ast
|
||||||
|
progress "}}}"
|
||||||
|
|
||||||
|
progress "{{{ C output"
|
||||||
|
putStr $ writeC ast'
|
||||||
|
progress "}}}"
|
||||||
|
|
||||||
|
progress "Done"
|
||||||
|
|
||||||
38
fco2/Makefile
Normal file
38
fco2/Makefile
Normal file
|
|
@ -0,0 +1,38 @@
|
||||||
|
targets = fco
|
||||||
|
|
||||||
|
all: $(targets)
|
||||||
|
|
||||||
|
sources = \
|
||||||
|
AST.hs \
|
||||||
|
ASTPasses.hs \
|
||||||
|
COutput.hs \
|
||||||
|
Main.hs \
|
||||||
|
Metadata.hs \
|
||||||
|
Parse.hs \
|
||||||
|
Pass.hs \
|
||||||
|
PrettyShow.hs \
|
||||||
|
PT.hs \
|
||||||
|
PTPasses.hs \
|
||||||
|
SExpression.hs \
|
||||||
|
PTToAST.hs
|
||||||
|
|
||||||
|
$(targets): $(sources)
|
||||||
|
ghc -fglasgow-exts -o fco --make Main
|
||||||
|
|
||||||
|
tests = $(wildcard testcases/*.occ)
|
||||||
|
|
||||||
|
test: $(targets) $(tests)
|
||||||
|
@set -e; for x in $(tests); do \
|
||||||
|
echo -n "$$x: " ; \
|
||||||
|
if ! ./fco --parse-tree $$x >$$x.log 2>&1 ; then \
|
||||||
|
echo "parse failed" ; \
|
||||||
|
elif ! ./fco -v $$x >$$x.log 2>&1 ; then \
|
||||||
|
echo "full failed" ; \
|
||||||
|
else \
|
||||||
|
echo "ok" ; \
|
||||||
|
fi ; \
|
||||||
|
done
|
||||||
|
|
||||||
|
clean:
|
||||||
|
rm -f $(targets) *.o *.hi
|
||||||
|
|
||||||
30
fco2/Metadata.hs
Normal file
30
fco2/Metadata.hs
Normal file
|
|
@ -0,0 +1,30 @@
|
||||||
|
-- Metadata types
|
||||||
|
|
||||||
|
module Metadata where
|
||||||
|
|
||||||
|
import Data.Generics
|
||||||
|
import Data.List
|
||||||
|
|
||||||
|
type Meta = [Metadatum]
|
||||||
|
|
||||||
|
data Metadatum =
|
||||||
|
SourcePos String Int Int
|
||||||
|
deriving (Show, Eq, Typeable, Data)
|
||||||
|
|
||||||
|
findSourcePos :: Meta -> Maybe Metadatum
|
||||||
|
findSourcePos ms = find (\x -> case x of SourcePos _ _ _ -> True
|
||||||
|
otherwise -> False) ms
|
||||||
|
|
||||||
|
formatSourcePos :: Meta -> String
|
||||||
|
formatSourcePos m = case findSourcePos m of
|
||||||
|
Just (SourcePos f l c) -> "<@" ++ show l ++ ":" ++ show c ++ ">"
|
||||||
|
Nothing -> "<?>"
|
||||||
|
|
||||||
|
die :: Monad m => String -> m a
|
||||||
|
die s = error $ "error: " ++ s
|
||||||
|
|
||||||
|
dieP :: Monad m => Meta -> String -> m a
|
||||||
|
dieP m s = case findSourcePos m of
|
||||||
|
Just (SourcePos f l c) -> die $ f ++ ":" ++ (show l) ++ ":" ++ (show c) ++ ": " ++ s
|
||||||
|
Nothing -> die $ "unknown position: " ++ s
|
||||||
|
|
||||||
803
fco2/Parse.hs
Normal file
803
fco2/Parse.hs
Normal file
|
|
@ -0,0 +1,803 @@
|
||||||
|
-- Parse occam code
|
||||||
|
|
||||||
|
module Parse (readSource, parseSource) where
|
||||||
|
|
||||||
|
import Data.List
|
||||||
|
import Text.ParserCombinators.Parsec
|
||||||
|
import qualified Text.ParserCombinators.Parsec.Token as P
|
||||||
|
import Text.ParserCombinators.Parsec.Language (emptyDef)
|
||||||
|
import qualified IO
|
||||||
|
|
||||||
|
import qualified PT as N
|
||||||
|
import Metadata
|
||||||
|
|
||||||
|
-- -------------------------------------------------------------
|
||||||
|
|
||||||
|
md :: Parser Meta
|
||||||
|
md = do
|
||||||
|
pos <- getPosition
|
||||||
|
return $ [SourcePos (sourceName pos) (sourceLine pos) (sourceColumn pos)]
|
||||||
|
|
||||||
|
nd :: Meta -> N.NodeType -> N.Node
|
||||||
|
nd = N.Node
|
||||||
|
|
||||||
|
-- -------------------------------------------------------------
|
||||||
|
|
||||||
|
mainMarker = "##MAGIC-FCO-MAIN-PROCESS##"
|
||||||
|
|
||||||
|
occamStyle
|
||||||
|
= emptyDef
|
||||||
|
{ P.commentLine = "--"
|
||||||
|
, P.nestedComments = False
|
||||||
|
, P.identStart = letter
|
||||||
|
, P.identLetter = alphaNum <|> char '.'
|
||||||
|
, P.opStart = oneOf "+-*/\\>=<~"
|
||||||
|
, P.opLetter = oneOf "/\\>=<"
|
||||||
|
, P.reservedOpNames= [
|
||||||
|
"+",
|
||||||
|
"-",
|
||||||
|
"*",
|
||||||
|
"/",
|
||||||
|
"\\",
|
||||||
|
"/\\",
|
||||||
|
"\\/",
|
||||||
|
"><",
|
||||||
|
"=",
|
||||||
|
"<>",
|
||||||
|
"<",
|
||||||
|
">",
|
||||||
|
">=",
|
||||||
|
"<=",
|
||||||
|
"-",
|
||||||
|
"~"
|
||||||
|
]
|
||||||
|
, P.reservedNames = [
|
||||||
|
"AFTER",
|
||||||
|
"ALT",
|
||||||
|
"AND",
|
||||||
|
"ANY",
|
||||||
|
"AT",
|
||||||
|
"BITAND",
|
||||||
|
"BITNOT",
|
||||||
|
"BITOR",
|
||||||
|
"BOOL",
|
||||||
|
"BYTE",
|
||||||
|
"BYTESIN",
|
||||||
|
"CASE",
|
||||||
|
"CHAN",
|
||||||
|
"DATA",
|
||||||
|
"ELSE",
|
||||||
|
"FALSE",
|
||||||
|
"FOR",
|
||||||
|
"FROM",
|
||||||
|
"FUNCTION",
|
||||||
|
"IF",
|
||||||
|
"INT",
|
||||||
|
"INT16",
|
||||||
|
"INT32",
|
||||||
|
"INT64",
|
||||||
|
"IS",
|
||||||
|
"MINUS",
|
||||||
|
"MOSTNEG",
|
||||||
|
"MOSTPOS",
|
||||||
|
"NOT",
|
||||||
|
"OF",
|
||||||
|
"OFFSETOF",
|
||||||
|
"OR",
|
||||||
|
"PACKED",
|
||||||
|
"PAR",
|
||||||
|
"PLACE",
|
||||||
|
"PLACED",
|
||||||
|
"PLUS",
|
||||||
|
"PORT",
|
||||||
|
"PRI",
|
||||||
|
"PROC",
|
||||||
|
"PROCESSOR",
|
||||||
|
"PROTOCOL",
|
||||||
|
"REAL32",
|
||||||
|
"REAL64",
|
||||||
|
"RECORD",
|
||||||
|
"REM",
|
||||||
|
"RESHAPES",
|
||||||
|
"RESULT",
|
||||||
|
"RETYPES",
|
||||||
|
"ROUND",
|
||||||
|
"SEQ",
|
||||||
|
"SIZE",
|
||||||
|
"SKIP",
|
||||||
|
"STOP",
|
||||||
|
"TIMER",
|
||||||
|
"TIMES",
|
||||||
|
"TRUE",
|
||||||
|
"TRUNC",
|
||||||
|
"TYPE",
|
||||||
|
"VAL",
|
||||||
|
"VALOF",
|
||||||
|
"WHILE",
|
||||||
|
mainMarker
|
||||||
|
]
|
||||||
|
, P.caseSensitive = True
|
||||||
|
}
|
||||||
|
|
||||||
|
lexer :: P.TokenParser ()
|
||||||
|
lexer = P.makeTokenParser occamStyle
|
||||||
|
-- XXX replace whitespace with something that doesn't eat \ns
|
||||||
|
|
||||||
|
whiteSpace = P.whiteSpace lexer
|
||||||
|
lexeme = P.lexeme lexer
|
||||||
|
symbol = P.symbol lexer
|
||||||
|
natural = P.natural lexer
|
||||||
|
parens = P.parens lexer
|
||||||
|
semi = P.semi lexer
|
||||||
|
identifier= P.identifier lexer
|
||||||
|
reserved = P.reserved lexer
|
||||||
|
reservedOp= P.reservedOp lexer
|
||||||
|
|
||||||
|
sLeft = try $ symbol "["
|
||||||
|
sRight = try $ symbol "]"
|
||||||
|
sLeftR = try $ symbol "("
|
||||||
|
sRightR = try $ symbol ")"
|
||||||
|
sAssign = try $ symbol ":="
|
||||||
|
sColon = try $ symbol ":"
|
||||||
|
sColons = try $ symbol "::"
|
||||||
|
sComma = try $ symbol ","
|
||||||
|
sSemi = try $ symbol ";"
|
||||||
|
sAmp = try $ symbol "&"
|
||||||
|
sQuest = try $ symbol "?"
|
||||||
|
sBang = try $ symbol "!"
|
||||||
|
sEq = try $ symbol "="
|
||||||
|
|
||||||
|
sAFTER = reserved "AFTER"
|
||||||
|
sALT = reserved "ALT"
|
||||||
|
sAND = reserved "AND"
|
||||||
|
sANY = reserved "ANY"
|
||||||
|
sAT = reserved "AT"
|
||||||
|
sBITAND = reserved "BITAND"
|
||||||
|
sBITNOT = reserved "BITNOT"
|
||||||
|
sBITOR = reserved "BITOR"
|
||||||
|
sBOOL = reserved "BOOL"
|
||||||
|
sBYTE = reserved "BYTE"
|
||||||
|
sBYTESIN = reserved "BYTESIN"
|
||||||
|
sCASE = reserved "CASE"
|
||||||
|
sCHAN = reserved "CHAN"
|
||||||
|
sDATA = reserved "DATA"
|
||||||
|
sELSE = reserved "ELSE"
|
||||||
|
sFALSE = reserved "FALSE"
|
||||||
|
sFOR = reserved "FOR"
|
||||||
|
sFROM = reserved "FROM"
|
||||||
|
sFUNCTION = reserved "FUNCTION"
|
||||||
|
sIF = reserved "IF"
|
||||||
|
sINT = reserved "INT"
|
||||||
|
sINT16 = reserved "INT16"
|
||||||
|
sINT32 = reserved "INT32"
|
||||||
|
sINT64 = reserved "INT64"
|
||||||
|
sIS = reserved "IS"
|
||||||
|
sMINUS = reserved "MINUS"
|
||||||
|
sMOSTNEG = reserved "MOSTNEG"
|
||||||
|
sMOSTPOS = reserved "MOSTPOS"
|
||||||
|
sNOT = reserved "NOT"
|
||||||
|
sOF = reserved "OF"
|
||||||
|
sOFFSETOF = reserved "OFFSETOF"
|
||||||
|
sOR = reserved "OR"
|
||||||
|
sPACKED = reserved "PACKED"
|
||||||
|
sPAR = reserved "PAR"
|
||||||
|
sPLACE = reserved "PLACE"
|
||||||
|
sPLACED = reserved "PLACED"
|
||||||
|
sPLUS = reserved "PLUS"
|
||||||
|
sPORT = reserved "PORT"
|
||||||
|
sPRI = reserved "PRI"
|
||||||
|
sPROC = reserved "PROC"
|
||||||
|
sPROCESSOR = reserved "PROCESSOR"
|
||||||
|
sPROTOCOL = reserved "PROTOCOL"
|
||||||
|
sREAL32 = reserved "REAL32"
|
||||||
|
sREAL64 = reserved "REAL64"
|
||||||
|
sRECORD = reserved "RECORD"
|
||||||
|
sREM = reserved "REM"
|
||||||
|
sRESHAPES = reserved "RESHAPES"
|
||||||
|
sRESULT = reserved "RESULT"
|
||||||
|
sRETYPES = reserved "RETYPES"
|
||||||
|
sROUND = reserved "ROUND"
|
||||||
|
sSEQ = reserved "SEQ"
|
||||||
|
sSIZE = reserved "SIZE"
|
||||||
|
sSKIP = reserved "SKIP"
|
||||||
|
sSTOP = reserved "STOP"
|
||||||
|
sTIMER = reserved "TIMER"
|
||||||
|
sTIMES = reserved "TIMES"
|
||||||
|
sTRUE = reserved "TRUE"
|
||||||
|
sTRUNC = reserved "TRUNC"
|
||||||
|
sTYPE = reserved "TYPE"
|
||||||
|
sVAL = reserved "VAL"
|
||||||
|
sVALOF = reserved "VALOF"
|
||||||
|
sWHILE = reserved "WHILE"
|
||||||
|
sMainMarker = reserved mainMarker
|
||||||
|
|
||||||
|
-- XXX could handle VALOF by translating each step to one { and matching multiple ones?
|
||||||
|
indent = symbol "{"
|
||||||
|
outdent = symbol "}"
|
||||||
|
eol = symbol "@"
|
||||||
|
|
||||||
|
-- -------------------------------------------------------------
|
||||||
|
|
||||||
|
-- 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
|
||||||
|
= try (do { m <- md ; n <- name ; sIS ; v <- variable ; sColon ; eol ; return $ nd m $ N.Is n v })
|
||||||
|
<|> try (do { m <- md ; s <- specifier ; n <- name ; sIS ; v <- variable ; sColon ; eol ; return $ nd m $ N.IsType s n v })
|
||||||
|
<|> do { m <- md ; sVAL ;
|
||||||
|
try (do { n <- name ; sIS ; e <- expression ; sColon ; eol ; return $ nd m $ N.ValIs n e })
|
||||||
|
<|> do { s <- specifier ; n <- name ; sIS ; e <- expression ; sColon ; eol ; return $ nd m $ N.ValIsType s n e } }
|
||||||
|
<?> "abbreviation"
|
||||||
|
|
||||||
|
actual
|
||||||
|
= expression
|
||||||
|
<|> variable
|
||||||
|
<|> channel
|
||||||
|
<?> "actual"
|
||||||
|
|
||||||
|
allocation
|
||||||
|
= do { m <- md ; sPLACE ; n <- name ; sAT ; e <- expression ; sColon ; eol ; return $ nd m $ N.Place n e }
|
||||||
|
<?> "allocation"
|
||||||
|
|
||||||
|
alternation
|
||||||
|
= do { m <- md ; sALT ;
|
||||||
|
do { eol ; indent ; as <- many1 alternative ; outdent ; return $ nd m $ N.Alt as }
|
||||||
|
<|> do { r <- replicator ; eol ; indent ; a <- alternative ; outdent ; return $ nd m $ N.AltRep r a } }
|
||||||
|
<|> do { m <- md ; sPRI ; sALT ;
|
||||||
|
do { eol ; indent ; as <- many1 alternative ; outdent ; return $ nd m $ N.PriAlt as }
|
||||||
|
<|> do { r <- replicator ; eol ; indent ; a <- alternative ; outdent ; return $ nd m $ N.PriAltRep r a } }
|
||||||
|
<?> "alternation"
|
||||||
|
|
||||||
|
-- The reason the CASE guards end up here is because they have to be handled
|
||||||
|
-- specially: you can't tell until parsing the guts of the CASE what the processes
|
||||||
|
-- are.
|
||||||
|
alternative
|
||||||
|
= guardedAlternative
|
||||||
|
<|> alternation
|
||||||
|
<|> try (do { m <- md ; b <- boolean ; sAmp ; c <- channel ; sQuest ; sCASE ; eol ; indent ; vs <- many1 variant ; outdent ; return $ nd m $ N.CondGuard b (nd m $ N.In c (nd m $ N.InCase vs)) })
|
||||||
|
<|> try (do { m <- md ; c <- channel ; sQuest ; sCASE ; eol ; indent ; vs <- many1 variant ; outdent ; return $ nd m $ N.In c (nd m $ N.InCase vs) })
|
||||||
|
<|> do { m <- md ; s <- specification ; a <- alternative ; return $ nd m $ N.Decl s a }
|
||||||
|
<?> "alternative"
|
||||||
|
|
||||||
|
assignment
|
||||||
|
= do { m <- md ; vs <- variableList ; sAssign ; es <- expressionList ; eol ; return $ nd m $ N.Assign vs es }
|
||||||
|
<?> "assignment"
|
||||||
|
|
||||||
|
base
|
||||||
|
= expression
|
||||||
|
<?> "base"
|
||||||
|
|
||||||
|
boolean
|
||||||
|
= expression
|
||||||
|
<?> "boolean"
|
||||||
|
|
||||||
|
byte
|
||||||
|
= lexeme (do { m <- md ; char '\'' ; s <- character ; char '\'' ; return $ nd m $ N.LitByte s })
|
||||||
|
<?> "byte"
|
||||||
|
|
||||||
|
caseExpression
|
||||||
|
= expression
|
||||||
|
<?> "caseExpression"
|
||||||
|
|
||||||
|
caseInput
|
||||||
|
= do { m <- md ; c <- channel ; sQuest ; sCASE ; eol ; indent ; vs <- many1 variant ; outdent ; return $ nd m $ N.In c (nd m $ N.InCase vs) }
|
||||||
|
<?> "caseInput"
|
||||||
|
|
||||||
|
-- This is also used for timers and ports, since the syntax is identical (and
|
||||||
|
-- the parser really can't tell at this stage which is which).
|
||||||
|
channel
|
||||||
|
= do { m <- md ; v <- channel' ; es <- many (do { sLeft ; e <- expression ; sRight ; return e }) ; return $ foldl (\e s -> nd m $ N.Sub (nd m $ N.SubPlain s) e) v es }
|
||||||
|
<?> "channel"
|
||||||
|
|
||||||
|
channel'
|
||||||
|
= try name
|
||||||
|
<|> try (do { m <- md ; sLeft ; n <- channel ; sFROM ; e <- expression ; sFOR ; f <- expression ; sRight ; return $ nd m $ N.Sub (nd m $ N.SubFromFor e f) n })
|
||||||
|
<|> try (do { m <- md ; sLeft ; n <- channel ; sFROM ; e <- expression ; sRight ; return $ nd m $ N.Sub (nd m $ N.SubFrom e) n })
|
||||||
|
<|> do { m <- md ; sLeft ; n <- channel ; sFOR ; e <- expression ; sRight ; return $ nd m $ N.Sub (nd m $ N.SubFor e) n }
|
||||||
|
<?> "channel'"
|
||||||
|
|
||||||
|
-- FIXME should probably make CHAN INT work, since that'd be trivial...
|
||||||
|
channelType
|
||||||
|
= do { m <- md ; sCHAN ; sOF ; p <- protocol ; return $ nd m $ N.ChanOf p }
|
||||||
|
<|> try (do { m <- md ; sLeft ; s <- expression ; sRight ; t <- channelType ; return $ nd m $ N.Array s t })
|
||||||
|
<?> "channelType"
|
||||||
|
|
||||||
|
-- FIXME this isn't at all the right way to return the character!
|
||||||
|
character
|
||||||
|
= try (do { char '*' ;
|
||||||
|
do { char '#' ; a <- hexDigit ; b <- hexDigit ; return $ ['*', '#', a, b] }
|
||||||
|
<|> do { c <- anyChar ; return $ ['*', c] } })
|
||||||
|
<|> do { c <- anyChar ; return $ [c] }
|
||||||
|
<?> "character"
|
||||||
|
|
||||||
|
occamChoice
|
||||||
|
= guardedChoice
|
||||||
|
<|> conditional
|
||||||
|
<|> do { m <- md ; s <- try specification ; c <- occamChoice ; return $ nd m $ N.Decl s c }
|
||||||
|
<?> "choice"
|
||||||
|
|
||||||
|
conditional
|
||||||
|
= do { m <- md ; sIF ;
|
||||||
|
do { eol ; indent ; cs <- many1 occamChoice ; outdent ; return $ nd m $ N.If cs }
|
||||||
|
<|> do { r <- replicator ; eol ; indent ; c <- occamChoice ; outdent ; return $ nd m $ N.IfRep r c } }
|
||||||
|
<?> "conditional"
|
||||||
|
|
||||||
|
-- This uses operandNotTable to resolve the "x[y]" ambiguity.
|
||||||
|
conversion
|
||||||
|
= try (do { m <- md ; t <- dataType; do { sROUND ; o <- operand ; return $ nd m $ N.Round t o } <|> do { sTRUNC ; o <- operand ; return $ nd m $ N.Trunc t o } <|> do { o <- operandNotTable ; return $ nd m $ N.Conv t o } })
|
||||||
|
<?> "conversion"
|
||||||
|
|
||||||
|
occamCount
|
||||||
|
= expression
|
||||||
|
<?> "count"
|
||||||
|
|
||||||
|
dataType
|
||||||
|
= do { m <- md ; sBOOL ; return $ nd m $ N.Bool }
|
||||||
|
<|> do { m <- md ; sBYTE ; return $ nd m $ N.Byte }
|
||||||
|
<|> do { m <- md ; sINT ; return $ nd m $ N.Int }
|
||||||
|
<|> do { m <- md ; sINT16 ; return $ nd m $ N.Int16 }
|
||||||
|
<|> do { m <- md ; sINT32 ; return $ nd m $ N.Int32 }
|
||||||
|
<|> do { m <- md ; sINT64 ; return $ nd m $ N.Int64 }
|
||||||
|
<|> do { m <- md ; sREAL32 ; return $ nd m $ N.Real32 }
|
||||||
|
<|> do { m <- md ; sREAL64 ; return $ nd m $ N.Real64 }
|
||||||
|
<|> try (do { m <- md ; sLeft ; s <- expression ; sRight ; t <- dataType ; return $ nd m $ N.Array s t })
|
||||||
|
<|> name
|
||||||
|
<?> "data type"
|
||||||
|
|
||||||
|
declType
|
||||||
|
= dataType
|
||||||
|
<|> channelType
|
||||||
|
<|> timerType
|
||||||
|
<|> portType
|
||||||
|
|
||||||
|
-- FIXME this originally had four lines like this, one for each of the above;
|
||||||
|
-- it might be nicer to generate a different nd m $ N.Node for each type of declaration
|
||||||
|
declaration
|
||||||
|
= do { m <- md ; d <- declType ; ns <- sepBy1 name sComma ; sColon ; eol ; return $ nd m $ N.Vars d ns }
|
||||||
|
<?> "declaration"
|
||||||
|
|
||||||
|
definition
|
||||||
|
= do { m <- md ; sDATA ; sTYPE ; n <- name ;
|
||||||
|
do {sIS ; t <- dataType ; sColon ; eol ; return $ nd m $ N.DataType n t }
|
||||||
|
<|> do { eol ; indent ; t <- structuredType ; outdent ; sColon ; eol ; return $ nd m $ N.DataType n t } }
|
||||||
|
<|> do { m <- md ; sPROTOCOL ; n <- name ;
|
||||||
|
do { sIS ; p <- sequentialProtocol ; sColon ; eol ; return $ nd m $ N.Protocol n p }
|
||||||
|
<|> do { eol ; indent ; sCASE ; eol ; indent ; ps <- many1 taggedProtocol ; outdent ; outdent ; sColon ; eol ; return $ nd m $ N.TaggedProtocol n ps } }
|
||||||
|
<|> do { m <- md ; sPROC ; n <- name ; fs <- formalList ; eol ; indent ; p <- process ; outdent ; sColon ; eol ; return $ nd m $ N.Proc n fs p }
|
||||||
|
<|> try (do { m <- md ; rs <- sepBy1 dataType sComma ; (n, fs) <- functionHeader ;
|
||||||
|
do { sIS ; el <- expressionList ; sColon ; eol ; return $ nd m $ N.FuncIs n rs fs el }
|
||||||
|
<|> do { eol ; indent ; vp <- valueProcess ; outdent ; sColon ; eol ; return $ nd m $ N.Func n rs fs vp } })
|
||||||
|
<|> try (do { m <- md ; s <- specifier ; n <- name ;
|
||||||
|
do { sRETYPES ; v <- variable ; sColon ; eol ; return $ nd m $ N.Retypes s n v }
|
||||||
|
<|> do { try sRESHAPES ; v <- variable ; sColon ; eol ; return $ nd m $ N.Reshapes s n v } })
|
||||||
|
<|> do { m <- md ; sVAL ; s <- specifier ; n <- name ;
|
||||||
|
do { sRETYPES ; v <- variable ; sColon ; eol ; return $ nd m $ N.ValRetypes s n v }
|
||||||
|
<|> do { sRESHAPES ; v <- variable ; sColon ; eol ; return $ nd m $ N.ValReshapes s n v } }
|
||||||
|
<?> "definition"
|
||||||
|
|
||||||
|
digits
|
||||||
|
= many1 digit
|
||||||
|
<?> "digits"
|
||||||
|
|
||||||
|
dyadicOperator
|
||||||
|
= do { m <- md ; reservedOp "+" ; return $ nd m $ N.Add }
|
||||||
|
<|> do { m <- md ; reservedOp "-" ; return $ nd m $ N.Subtr }
|
||||||
|
<|> do { m <- md ; reservedOp "*" ; return $ nd m $ N.Mul }
|
||||||
|
<|> do { m <- md ; reservedOp "/" ; return $ nd m $ N.Div }
|
||||||
|
<|> do { m <- md ; reservedOp "\\" ; return $ nd m $ N.Rem }
|
||||||
|
<|> do { m <- md ; sREM ; return $ nd m $ N.Rem }
|
||||||
|
<|> do { m <- md ; sPLUS ; return $ nd m $ N.Plus }
|
||||||
|
<|> do { m <- md ; sMINUS ; return $ nd m $ N.Minus }
|
||||||
|
<|> do { m <- md ; sTIMES ; return $ nd m $ N.Times }
|
||||||
|
<|> do { m <- md ; reservedOp "/\\" ; return $ nd m $ N.BitAnd }
|
||||||
|
<|> do { m <- md ; reservedOp "\\/" ; return $ nd m $ N.BitOr }
|
||||||
|
<|> do { m <- md ; reservedOp "><" ; return $ nd m $ N.BitXor }
|
||||||
|
<|> do { m <- md ; sBITAND ; return $ nd m $ N.BitAnd }
|
||||||
|
<|> do { m <- md ; sBITOR ; return $ nd m $ N.BitOr }
|
||||||
|
<|> do { m <- md ; sAND ; return $ nd m $ N.And }
|
||||||
|
<|> do { m <- md ; sOR ; return $ nd m $ N.Or }
|
||||||
|
<|> do { m <- md ; reservedOp "=" ; return $ nd m $ N.Eq }
|
||||||
|
<|> do { m <- md ; reservedOp "<>" ; return $ nd m $ N.NEq }
|
||||||
|
<|> do { m <- md ; reservedOp "<" ; return $ nd m $ N.Less }
|
||||||
|
<|> do { m <- md ; reservedOp ">" ; return $ nd m $ N.More }
|
||||||
|
<|> do { m <- md ; reservedOp "<=" ; return $ nd m $ N.LessEq }
|
||||||
|
<|> do { m <- md ; reservedOp ">=" ; return $ nd m $ N.MoreEq }
|
||||||
|
<|> do { m <- md ; sAFTER ; return $ nd m $ N.After }
|
||||||
|
<?> "dyadicOperator"
|
||||||
|
|
||||||
|
occamExponent
|
||||||
|
= try (do { c <- oneOf "+-" ; d <- digits ; return $ c : d })
|
||||||
|
<?> "exponent"
|
||||||
|
|
||||||
|
expression
|
||||||
|
= try (do { m <- md ; o <- monadicOperator ; v <- operand ; return $ nd m $ N.MonadicOp o v })
|
||||||
|
<|> do { m <- md ; a <- sMOSTPOS ; t <- dataType ; return $ nd m $ N.MostPos t }
|
||||||
|
<|> do { m <- md ; a <- sMOSTNEG ; t <- dataType ; return $ nd m $ N.MostNeg t }
|
||||||
|
<|> do { m <- md ; a <- sSIZE ; t <- dataType ; return $ nd m $ N.Size t }
|
||||||
|
<|> try (do { m <- md ; a <- operand ; o <- dyadicOperator ; b <- operand ; return $ nd m $ N.DyadicOp o a b })
|
||||||
|
<|> try conversion
|
||||||
|
<|> operand
|
||||||
|
<?> "expression"
|
||||||
|
|
||||||
|
expressionList
|
||||||
|
= try (do { m <- md ; n <- name ; sLeftR ; as <- sepBy expression sComma ; sRightR ; return $ nd m $ N.Call n as })
|
||||||
|
<|> do { m <- md ; es <- sepBy1 expression sComma ; return $ nd m $ N.ExpList es }
|
||||||
|
-- XXX value process
|
||||||
|
<?> "expressionList"
|
||||||
|
|
||||||
|
fieldName
|
||||||
|
= name
|
||||||
|
<?> "fieldName"
|
||||||
|
|
||||||
|
-- This is rather different from the grammar, since I had some difficulty
|
||||||
|
-- getting Parsec to parse it as a list of lists of arguments.
|
||||||
|
formalList
|
||||||
|
= do { m <- md ; sLeftR ; fs <- sepBy formalArg sComma ; sRightR ; return $ markTypes m fs }
|
||||||
|
<?> "formalList"
|
||||||
|
where
|
||||||
|
formalArg :: Parser (Maybe N.Node, N.Node)
|
||||||
|
formalArg = try (do { m <- md ; sVAL ; s <- specifier ; n <- name ; return $ (Just (nd m $ N.Val s), n) })
|
||||||
|
<|> try (do { s <- specifier ; n <- name ; return $ (Just s, n) })
|
||||||
|
<|> try (do { n <- name ; return $ (Nothing, n) })
|
||||||
|
|
||||||
|
markTypes :: Meta -> [(Maybe N.Node, N.Node)] -> [N.Node]
|
||||||
|
markTypes _ [] = []
|
||||||
|
markTypes _ ((Nothing, _):_) = error "Formal list must start with a type"
|
||||||
|
markTypes m ((Just ft, fn):is) = markRest m ft [fn] is
|
||||||
|
|
||||||
|
markRest :: Meta -> N.Node -> [N.Node] -> [(Maybe N.Node, N.Node)] -> [N.Node]
|
||||||
|
markRest m lt ns [] = [nd m $ N.Formals lt ns]
|
||||||
|
markRest m lt ns ((Nothing, n):is) = markRest m lt (ns ++ [n]) is
|
||||||
|
markRest m lt ns ((Just t, n):is) = (markRest m lt ns []) ++ (markRest m t [n] is)
|
||||||
|
|
||||||
|
functionHeader
|
||||||
|
= do { sFUNCTION ; n <- name ; fs <- formalList ; return $ (n, fs) }
|
||||||
|
<?> "functionHeader"
|
||||||
|
|
||||||
|
guard
|
||||||
|
= try input
|
||||||
|
<|> try (do { m <- md ; b <- boolean ; sAmp ; i <- input ; return $ nd m $ N.CondGuard b i })
|
||||||
|
<|> try (do { m <- md ; b <- boolean ; sAmp ; sSKIP ; eol ; return $ nd m $ N.CondGuard b (nd m $ N.Skip) })
|
||||||
|
<?> "guard"
|
||||||
|
|
||||||
|
guardedAlternative
|
||||||
|
= do { m <- md ; g <- guard ; indent ; p <- process ; outdent ; return $ nd m $ N.Guard g p }
|
||||||
|
<?> "guardedAlternative"
|
||||||
|
|
||||||
|
guardedChoice
|
||||||
|
= do { m <- md ; b <- boolean ; eol ; indent ; p <- process ; outdent ; return $ nd m $ N.Choice b p }
|
||||||
|
<?> "guardedChoice"
|
||||||
|
|
||||||
|
hexDigits
|
||||||
|
= do { m <- md ; d <- many1 hexDigit ; return $ nd m $ N.LitHex d }
|
||||||
|
<?> "hexDigits"
|
||||||
|
|
||||||
|
input
|
||||||
|
= do m <- md
|
||||||
|
c <- channel
|
||||||
|
sQuest
|
||||||
|
(do { sCASE ; tl <- taggedList ; eol ; return $ nd m $ N.In c (nd m $ N.InTag tl) }
|
||||||
|
<|> do { sAFTER ; e <- expression ; eol ; return $ nd m $ N.In c (nd m $ N.InAfter e) }
|
||||||
|
<|> do { is <- sepBy1 inputItem sSemi ; eol ; return $ nd m $ N.In c (nd m $ N.InSimple is) })
|
||||||
|
<?> "input"
|
||||||
|
|
||||||
|
inputItem
|
||||||
|
= try (do { m <- md ; v <- variable ; sColons ; w <- variable ; return $ nd m $ N.Counted v w })
|
||||||
|
<|> variable
|
||||||
|
<?> "inputItem"
|
||||||
|
|
||||||
|
integer
|
||||||
|
= try (do { m <- md ; d <- lexeme digits ; return $ nd m $ N.LitInt d })
|
||||||
|
<|> do { char '#' ; d <- lexeme hexDigits ; return $ d }
|
||||||
|
<?> "integer"
|
||||||
|
|
||||||
|
literal
|
||||||
|
= try real
|
||||||
|
<|> try integer
|
||||||
|
<|> try byte
|
||||||
|
<|> try (do { m <- md ; v <- real ; sLeftR ; t <- dataType ; sRightR ; return $ nd m $ N.TypedLit t v })
|
||||||
|
<|> try (do { m <- md ; v <- integer ; sLeftR ; t <- dataType ; sRightR ; return $ nd m $ N.TypedLit t v })
|
||||||
|
<|> try (do { m <- md ; v <- byte ; sLeftR ; t <- dataType ; sRightR ; return $ nd m $ N.TypedLit t v })
|
||||||
|
<|> try (do { m <- md ; sTRUE ; return $ nd m $ N.True })
|
||||||
|
<|> do { m <- md ; sFALSE ; return $ nd m $ N.False }
|
||||||
|
<?> "literal"
|
||||||
|
|
||||||
|
loop
|
||||||
|
= do { m <- md ; sWHILE ; b <- boolean ; eol ; indent ; p <- process ; outdent ; return $ nd m $ N.While b p }
|
||||||
|
|
||||||
|
monadicOperator
|
||||||
|
= do { m <- md ; reservedOp "-" ; return $ nd m $ N.MonSub }
|
||||||
|
<|> do { m <- md ; sMINUS ; return $ nd m $ N.MonSub }
|
||||||
|
<|> do { m <- md ; reservedOp "~" ; return $ nd m $ N.MonBitNot }
|
||||||
|
<|> do { m <- md ; sBITNOT ; return $ nd m $ N.MonBitNot }
|
||||||
|
<|> do { m <- md ; sNOT ; return $ nd m $ N.MonNot }
|
||||||
|
<|> do { m <- md ; sSIZE ; return $ nd m $ N.MonSize }
|
||||||
|
<?> "monadicOperator"
|
||||||
|
|
||||||
|
name
|
||||||
|
= do { m <- md ; s <- identifier ; return $ nd m $ N.Name s }
|
||||||
|
<?> "name"
|
||||||
|
|
||||||
|
occamString
|
||||||
|
= lexeme (do { m <- md ; char '"' ; s <- many (noneOf "\"") ; char '"' ; return $ nd m $ N.LitString s })
|
||||||
|
<?> "string"
|
||||||
|
|
||||||
|
operandNotTable
|
||||||
|
= do { m <- md ; v <- operandNotTable' ; es <- many (do { sLeft ; e <- expression ; sRight ; return e }) ; return $ foldl (\e s -> nd m $ N.Sub (nd m $ N.SubPlain s) e) v es }
|
||||||
|
<?> "operandNotTable"
|
||||||
|
|
||||||
|
operandNotTable'
|
||||||
|
= try variable
|
||||||
|
<|> try literal
|
||||||
|
<|> try (do { sLeftR ; e <- expression ; sRightR ; return e })
|
||||||
|
-- XXX value process
|
||||||
|
<|> try (do { m <- md ; n <- name ; sLeftR ; as <- sepBy expression sComma ; sRightR ; return $ nd m $ N.Call n as })
|
||||||
|
<|> try (do { m <- md ; sBYTESIN ; sLeftR ; o <- operand ; sRightR ; return $ nd m $ N.BytesIn o })
|
||||||
|
<|> try (do { m <- md ; sBYTESIN ; sLeftR ; o <- dataType ; sRightR ; return $ nd m $ N.BytesIn o })
|
||||||
|
<|> try (do { m <- md ; sOFFSETOF ; sLeftR ; n <- name ; sComma ; f <- fieldName ; sRightR ; return $ nd m $ N.OffsetOf n f })
|
||||||
|
<?> "operandNotTable'"
|
||||||
|
|
||||||
|
operand
|
||||||
|
= do { m <- md ; v <- operand' ; es <- many (do { sLeft ; e <- expression ; sRight ; return e }) ; return $ foldl (\e s -> nd m $ N.Sub (nd m $ N.SubPlain s) e) v es }
|
||||||
|
<?> "operand"
|
||||||
|
|
||||||
|
operand'
|
||||||
|
= try table
|
||||||
|
<|> operandNotTable'
|
||||||
|
<?> "operand'"
|
||||||
|
|
||||||
|
occamOption
|
||||||
|
= try (do { m <- md ; ces <- sepBy caseExpression sComma ; eol ; indent ; p <- process ; outdent ; return $ nd m $ N.CaseExps ces p })
|
||||||
|
<|> try (do { m <- md ; sELSE ; eol ; indent ; p <- process ; outdent ; return $ nd m $ N.Else p })
|
||||||
|
<|> do { m <- md ; s <- specification ; o <- occamOption ; return $ nd m $ N.Decl s o }
|
||||||
|
<?> "option"
|
||||||
|
|
||||||
|
-- XXX This can't tell at parse time in "c ! x; y" whether x is a variable or a tag...
|
||||||
|
-- ... so this now wants "c ! CASE x" if it's a tag, to match input.
|
||||||
|
-- We can fix this with a pass later...
|
||||||
|
output
|
||||||
|
= do m <- md
|
||||||
|
c <- channel
|
||||||
|
sBang
|
||||||
|
(do { sCASE ; t <- tag ; sSemi ; os <- sepBy1 outputItem sSemi ; eol ; return $ nd m $ N.OutCase c t os }
|
||||||
|
<|> do { sCASE ; t <- tag ; eol ; return $ nd m $ N.OutCase c t [] }
|
||||||
|
<|> do { os <- sepBy1 outputItem sSemi ; eol ; return $ nd m $ N.Out c os })
|
||||||
|
<?> "output"
|
||||||
|
|
||||||
|
outputItem
|
||||||
|
= try (do { m <- md ; a <- expression ; sColons ; b <- expression ; return $ nd m $ N.Counted a b })
|
||||||
|
<|> expression
|
||||||
|
<?> "outputItem"
|
||||||
|
|
||||||
|
parallel
|
||||||
|
= do { m <- md ; sPAR ; do { eol ; indent ; ps <- many1 process ; outdent ; return $ nd m $ N.Par ps } <|> do { r <- replicator ; eol ; indent ; p <- process ; outdent ; return $ nd m $ N.ParRep r p } }
|
||||||
|
<|> do { m <- md ; sPRI ; sPAR ; do { eol ; indent ; ps <- many1 process ; outdent ; return $ nd m $ N.PriPar ps } <|> do { r <- replicator ; eol ; indent ; p <- process ; outdent ; return $ nd m $ N.PriParRep r p } }
|
||||||
|
<|> placedpar
|
||||||
|
<?> "parallel"
|
||||||
|
|
||||||
|
-- XXX PROCESSOR as a process isn't really legal, surely?
|
||||||
|
placedpar
|
||||||
|
= do { m <- md ; sPLACED ; sPAR ; do { eol ; indent ; ps <- many1 placedpar ; outdent ; return $ nd m $ N.PlacedPar ps } <|> do { r <- replicator ; eol ; indent ; p <- placedpar ; outdent ; return $ nd m $ N.PlacedParRep r p } }
|
||||||
|
<|> do { m <- md ; sPROCESSOR ; e <- expression ; eol ; indent ; p <- process ; outdent ; return $ nd m $ N.Processor e p }
|
||||||
|
<?> "placedpar"
|
||||||
|
|
||||||
|
portType
|
||||||
|
= do { m <- md ; sPORT ; sOF ; p <- protocol ; return $ nd m $ N.PortOf p }
|
||||||
|
<|> do { m <- md ; try sLeft ; s <- try expression ; try sRight ; t <- portType ; return $ nd m $ N.Array s t }
|
||||||
|
<?> "portType"
|
||||||
|
|
||||||
|
procInstance
|
||||||
|
= do { m <- md ; n <- name ; sLeftR ; as <- sepBy actual sComma ; sRightR ; eol ; return $ nd m $ N.ProcCall n as }
|
||||||
|
<?> "procInstance"
|
||||||
|
|
||||||
|
process
|
||||||
|
= try assignment
|
||||||
|
<|> try input
|
||||||
|
<|> try output
|
||||||
|
<|> do { m <- md ; sSKIP ; eol ; return $ nd m $ N.Skip }
|
||||||
|
<|> do { m <- md ; sSTOP ; eol ; return $ nd m $ N.Stop }
|
||||||
|
<|> occamSequence
|
||||||
|
<|> conditional
|
||||||
|
<|> selection
|
||||||
|
<|> loop
|
||||||
|
<|> try parallel
|
||||||
|
<|> alternation
|
||||||
|
<|> try caseInput
|
||||||
|
<|> try procInstance
|
||||||
|
<|> do { m <- md ; sMainMarker ; eol ; return $ nd m $ N.MainProcess }
|
||||||
|
<|> do { m <- md ; a <- allocation ; p <- process ; return $ nd m $ N.Decl a p }
|
||||||
|
<|> do { m <- md ; s <- specification ; p <- process ; return $ nd m $ N.Decl s p }
|
||||||
|
<?> "process"
|
||||||
|
|
||||||
|
protocol
|
||||||
|
= try name
|
||||||
|
<|> simpleProtocol
|
||||||
|
<?> "protocol"
|
||||||
|
|
||||||
|
real
|
||||||
|
= try (do { m <- md ; l <- digits ; char '.' ; r <- digits ; char 'e' ; e <- lexeme occamExponent ; return $ nd m $ N.LitReal (l ++ "." ++ r ++ "e" ++ e) })
|
||||||
|
<|> do { m <- md ; l <- digits ; char '.' ; r <- lexeme digits ; return $ nd m $ N.LitReal (l ++ "." ++ r) }
|
||||||
|
<?> "real"
|
||||||
|
|
||||||
|
replicator
|
||||||
|
= do { m <- md ; n <- name ; sEq ; b <- base ; sFOR ; c <- occamCount ; return $ nd m $ N.For n b c }
|
||||||
|
<?> "replicator"
|
||||||
|
|
||||||
|
selection
|
||||||
|
= do { m <- md ; sCASE ; s <- selector ; eol ; indent ; os <- many1 occamOption ; outdent ; return $ nd m $ N.Case s os }
|
||||||
|
<?> "selection"
|
||||||
|
|
||||||
|
selector
|
||||||
|
= expression
|
||||||
|
<?> "selector"
|
||||||
|
|
||||||
|
occamSequence
|
||||||
|
= do m <- md
|
||||||
|
sSEQ
|
||||||
|
(do { eol ; indent ; ps <- many1 process ; outdent ; return $ nd m $ N.Seq ps }
|
||||||
|
<|> do { r <- replicator ; eol ; indent ; p <- process ; outdent ; return $ nd m $ N.SeqRep r p })
|
||||||
|
<?> "sequence"
|
||||||
|
|
||||||
|
sequentialProtocol
|
||||||
|
= do { l <- try $ sepBy1 simpleProtocol sSemi ; return $ l }
|
||||||
|
<?> "sequentialProtocol"
|
||||||
|
|
||||||
|
simpleProtocol
|
||||||
|
= try (do { m <- md ; l <- dataType ; sColons ; sLeft ; sRight ; r <- dataType ; return $ nd m $ N.Counted l r })
|
||||||
|
<|> dataType
|
||||||
|
<|> do { m <- md ; sANY ; return $ nd m $ N.Any }
|
||||||
|
<?> "simpleProtocol"
|
||||||
|
|
||||||
|
specification
|
||||||
|
= try declaration
|
||||||
|
<|> try abbreviation
|
||||||
|
<|> definition
|
||||||
|
<?> "specification"
|
||||||
|
|
||||||
|
specifier
|
||||||
|
= try dataType
|
||||||
|
<|> try channelType
|
||||||
|
<|> try timerType
|
||||||
|
<|> try portType
|
||||||
|
<|> try (do { m <- md ; sLeft ; sRight ; s <- specifier ; return $ nd m $ N.ArrayUnsized s })
|
||||||
|
<|> do { m <- md ; sLeft ; e <- expression ; sRight ; s <- specifier ; return $ nd m $ N.Array e s }
|
||||||
|
<?> "specifier"
|
||||||
|
|
||||||
|
structuredType
|
||||||
|
= try (do { m <- md ; sRECORD ; eol ; indent ; fs <- many1 structuredTypeField ; outdent ; return $ nd m $ N.Record fs })
|
||||||
|
<|> do { m <- md ; sPACKED ; sRECORD ; eol ; indent ; fs <- many1 structuredTypeField ; outdent ; return $ nd m $ N.PackedRecord fs }
|
||||||
|
<?> "structuredType"
|
||||||
|
|
||||||
|
-- FIXME this should use the same type-folding code as proc/func definitions
|
||||||
|
structuredTypeField
|
||||||
|
= do { m <- md ; t <- dataType ; fs <- many1 fieldName ; sColon ; eol ; return $ nd m $ N.Fields t fs }
|
||||||
|
<?> "structuredTypeField"
|
||||||
|
|
||||||
|
-- i.e. array literal
|
||||||
|
table
|
||||||
|
= do { m <- md ; v <- table' ; es <- many (do { sLeft ; e <- expression ; sRight ; return e }) ; return $ foldl (\e s -> nd m $ N.Sub (nd m $ N.SubPlain s) e) v es }
|
||||||
|
<?> "table"
|
||||||
|
|
||||||
|
table'
|
||||||
|
= try occamString
|
||||||
|
<|> try (do { m <- md ; s <- occamString ; sLeftR ; n <- name ; sRightR ; return $ nd m $ N.TypedLit n s })
|
||||||
|
<|> do { sLeft ;
|
||||||
|
try (do { m <- md ; es <- sepBy1 expression sComma ; sRight ; return $ nd m $ N.LitArray es })
|
||||||
|
<|> try (do { m <- md ; n <- table ; sFROM ; e <- expression ; sFOR ; f <- expression ; sRight ; return $ nd m $ N.Sub (nd m $ N.SubFromFor e f) n })
|
||||||
|
<|> try (do { m <- md ; n <- table ; sFROM ; e <- expression ; sRight ; return $ nd m $ N.Sub (nd m $ N.SubFrom e) n })
|
||||||
|
<|> do { m <- md ; n <- table ; sFOR ; e <- expression ; sRight ; return $ nd m $ N.Sub (nd m $ N.SubFor e) n } }
|
||||||
|
<?> "table'"
|
||||||
|
|
||||||
|
tag
|
||||||
|
= name
|
||||||
|
<?> "tag"
|
||||||
|
|
||||||
|
taggedList
|
||||||
|
= try (do { m <- md ; t <- tag ; sSemi ; is <- sepBy1 inputItem sSemi ; return $ nd m $ N.Tag t is })
|
||||||
|
<|> do { m <- md ; t <- tag ; return $ nd m $ N.Tag t [] }
|
||||||
|
<?> "taggedList"
|
||||||
|
|
||||||
|
taggedProtocol
|
||||||
|
= try (do { m <- md ; t <- tag ; eol ; return $ nd m $ N.Tag t [] })
|
||||||
|
<|> try (do { m <- md ; t <- tag ; sSemi ; sp <- sequentialProtocol ; eol ; return $ nd m $ N.Tag t sp })
|
||||||
|
|
||||||
|
timerType
|
||||||
|
= do { m <- md ; sTIMER ; return $ nd m $ N.Timer }
|
||||||
|
<|> do { m <- md ; try sLeft ; s <- try expression ; try sRight ; t <- timerType ; return $ nd m $ N.Array s t }
|
||||||
|
<?> "timerType"
|
||||||
|
|
||||||
|
valueProcess
|
||||||
|
= try (do { m <- md ; sVALOF ; eol ; indent ; p <- process ; sRESULT ; el <- expressionList ; eol ; outdent ; return $ nd m $ N.ValOf p el })
|
||||||
|
<|> do { m <- md ; s <- specification ; v <- valueProcess ; return $ nd m $ N.Decl s v }
|
||||||
|
|
||||||
|
variable
|
||||||
|
= do { m <- md ; v <- variable' ; es <- many (do { sLeft ; e <- expression ; sRight ; return e }) ; return $ foldl (\e s -> nd m $ N.Sub (nd m $ N.SubPlain s) e) v es }
|
||||||
|
<?> "variable"
|
||||||
|
|
||||||
|
variable'
|
||||||
|
= try name
|
||||||
|
<|> try (do { m <- md ; sLeft ; n <- variable ; sFROM ; e <- expression ; sFOR ; f <- expression ; sRight ; return $ nd m $ N.Sub (nd m $ N.SubFromFor e f) n })
|
||||||
|
<|> try (do { m <- md ; sLeft ; n <- variable ; sFROM ; e <- expression ; sRight ; return $ nd m $ N.Sub (nd m $ N.SubFrom e) n })
|
||||||
|
<|> do { m <- md ; sLeft ; n <- variable ; sFOR ; e <- expression ; sRight ; return $ nd m $ N.Sub (nd m $ N.SubFor e) n }
|
||||||
|
<?> "variable'"
|
||||||
|
|
||||||
|
variableList
|
||||||
|
= do { vs <- sepBy1 variable sComma ; return $ vs }
|
||||||
|
<?> "variableList"
|
||||||
|
|
||||||
|
variant
|
||||||
|
= try (do { m <- md ; t <- taggedList ; eol ; indent ; p <- process ; outdent ; return $ nd m $ N.Variant t p })
|
||||||
|
<|> do { m <- md ; s <- specification ; v <- variant ; return $ nd m $ N.Decl s v }
|
||||||
|
<?> "variant"
|
||||||
|
|
||||||
|
-- -------------------------------------------------------------
|
||||||
|
|
||||||
|
-- This is only really true once we've tacked a process onto the bottom; a
|
||||||
|
-- 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.
|
||||||
|
|
||||||
|
sourceFile = do { whiteSpace ; process }
|
||||||
|
|
||||||
|
-- -------------------------------------------------------------
|
||||||
|
|
||||||
|
-- XXX this doesn't handle multi-line strings
|
||||||
|
-- XXX or VALOF processes
|
||||||
|
|
||||||
|
countIndent :: String -> Int
|
||||||
|
countIndent (' ':' ':cs) = 1 + (countIndent cs)
|
||||||
|
countIndent (' ':cs) = error "Bad indentation"
|
||||||
|
countIndent _ = 0
|
||||||
|
|
||||||
|
stripIndent :: String -> String
|
||||||
|
stripIndent (' ':cs) = stripIndent cs
|
||||||
|
stripIndent cs = cs
|
||||||
|
|
||||||
|
stripComment :: String -> String
|
||||||
|
stripComment [] = []
|
||||||
|
stripComment ('-':'-':s) = []
|
||||||
|
stripComment ('"':s) = '"' : stripCommentInString s
|
||||||
|
stripComment (c:s) = c : stripComment s
|
||||||
|
|
||||||
|
stripCommentInString :: String -> String
|
||||||
|
stripCommentInString [] = error "In string at end of line"
|
||||||
|
stripCommentInString ('"':s) = '"' : stripComment s
|
||||||
|
stripCommentInString (c:s) = c : stripCommentInString s
|
||||||
|
|
||||||
|
flatten :: [String] -> String
|
||||||
|
flatten ls = concat $ intersperse "\n" $ flatten' ls 0
|
||||||
|
where
|
||||||
|
rep n i = take n (repeat i)
|
||||||
|
flatten' [] level = [rep level '}']
|
||||||
|
flatten' (s:ss) level
|
||||||
|
| stripped == "" = "" : flatten' ss level
|
||||||
|
| newLevel > level = (rep (newLevel - level) '{' ++ stripped) : rest
|
||||||
|
| newLevel < level = (rep (level - newLevel) '}' ++ stripped) : rest
|
||||||
|
| otherwise = stripped : rest
|
||||||
|
where newLevel = countIndent s
|
||||||
|
stripped' = stripComment s
|
||||||
|
stripped = if stripIndent stripped' == "" then "" else (stripped' ++ "@")
|
||||||
|
rest = flatten' ss newLevel
|
||||||
|
|
||||||
|
-- -------------------------------------------------------------
|
||||||
|
|
||||||
|
-- XXX Doesn't handle preprocessor instructions.
|
||||||
|
|
||||||
|
preprocess :: String -> String
|
||||||
|
preprocess d = flatten $ lines (d ++ "\n" ++ mainMarker)
|
||||||
|
|
||||||
|
readSource :: String -> IO String
|
||||||
|
readSource fn = do
|
||||||
|
f <- IO.openFile fn IO.ReadMode
|
||||||
|
d <- IO.hGetContents f
|
||||||
|
let prep = preprocess d
|
||||||
|
return prep
|
||||||
|
|
||||||
|
-- -------------------------------------------------------------
|
||||||
|
|
||||||
|
parseSource :: String -> String -> N.Node
|
||||||
|
parseSource prep sourceFileName
|
||||||
|
= case (parse sourceFile sourceFileName prep) of
|
||||||
|
Left err -> error ("Parsing error: " ++ (show err))
|
||||||
|
Right defs -> defs
|
||||||
|
|
||||||
49
fco2/PrettyShow.hs
Normal file
49
fco2/PrettyShow.hs
Normal file
|
|
@ -0,0 +1,49 @@
|
||||||
|
-- A generic show implementation that pretty-prints expressions
|
||||||
|
-- This ought to use a class (like show does), so that it can be extended
|
||||||
|
-- properly without me needing to have FCO-specific cases in here -- see the
|
||||||
|
-- appropriate SYB paper.
|
||||||
|
|
||||||
|
module PrettyShow (pshow) where
|
||||||
|
|
||||||
|
import Data.Generics
|
||||||
|
import Text.PrettyPrint.HughesPJ
|
||||||
|
import Metadata
|
||||||
|
|
||||||
|
-- This is ugly -- but it looks like you can't easily define a generic function
|
||||||
|
-- even for a single tuple type, since it has to parameterise over multiple Data
|
||||||
|
-- types...
|
||||||
|
isTupleCtr :: String -> Bool
|
||||||
|
isTupleCtr ('(':cs) = checkRest cs
|
||||||
|
where
|
||||||
|
checkRest ",)" = True
|
||||||
|
checkRest (',':cs) = checkRest cs
|
||||||
|
checkRest _ = False
|
||||||
|
isTupleCtr _ = False
|
||||||
|
|
||||||
|
doGeneral :: Data a => a -> Doc
|
||||||
|
doGeneral t =
|
||||||
|
if isTupleCtr cn then
|
||||||
|
parens $ sep $ punctuate (text ",") l
|
||||||
|
else case l of
|
||||||
|
[] -> con
|
||||||
|
otherwise -> parens $ sep (con : l)
|
||||||
|
where
|
||||||
|
cn = showConstr (toConstr t)
|
||||||
|
con = text $ cn
|
||||||
|
l = gmapQ doAny t
|
||||||
|
|
||||||
|
doList :: Data a => [a] -> Doc
|
||||||
|
doList t = brackets $ sep $ punctuate (text ",") (map doAny t)
|
||||||
|
|
||||||
|
doString :: String -> Doc
|
||||||
|
doString s = text $ show s
|
||||||
|
|
||||||
|
doMeta :: Meta -> Doc
|
||||||
|
doMeta m = text $ formatSourcePos m
|
||||||
|
|
||||||
|
doAny :: Data a => a -> Doc
|
||||||
|
doAny = doGeneral `ext1Q` doList `extQ` doString `extQ` doMeta
|
||||||
|
|
||||||
|
pshow :: Data a => a -> String
|
||||||
|
pshow x = render $ doAny x
|
||||||
|
|
||||||
Loading…
Reference in New Issue
Block a user