--- a/tools/PascalParser.hs Sat Nov 05 06:06:04 2011 +0100
+++ b/tools/PascalParser.hs Sat Nov 05 09:38:07 2011 +0300
@@ -14,7 +14,6 @@
Program Identifier Implementation
| Unit Identifier Interface Implementation (Maybe Initialize) (Maybe Finalize)
deriving Show
-
data Interface = Interface Uses TypesAndVars
deriving Show
data Implementation = Implementation Uses TypesAndVars
@@ -23,16 +22,19 @@
deriving Show
data TypesAndVars = TypesAndVars [TypeVarDeclaration]
deriving Show
-data TypeVarDeclaration = TypeDeclaration TypeDecl
- | ConstDeclaration String
- | VarDeclaration String
+data TypeVarDeclaration = TypeDeclaration Identifier TypeDecl
+ | VarDeclaration Bool ([Identifier], TypeDecl) (Maybe Expression)
| FunctionDeclaration Identifier Identifier (Maybe Phrase)
deriving Show
data TypeDecl = SimpleType Identifier
| RangeType Range
+ | Sequence [Identifier]
| ArrayDecl Range TypeDecl
+ | RecordType [TypeVarDeclaration]
+ | UnknownType
deriving Show
-data Range = Range Identifier
+data Range = Range Identifier
+ | RangeFromTo Expression Expression
deriving Show
data Initialize = Initialize String
deriving Show
@@ -43,19 +45,31 @@
data Phrase = ProcCall Identifier [Expression]
| IfThenElse Expression Phrase (Maybe Phrase)
| WhileCycle Expression Phrase
- | RepeatCycle Expression Phrase
- | ForCycle
+ | RepeatCycle Expression [Phrase]
+ | ForCycle Identifier Expression Expression Phrase
+ | WithBlock Expression Phrase
| Phrases [Phrase]
| SwitchCase Expression [(Expression, Phrase)] (Maybe Phrase)
- | Assignment Identifier Expression
+ | Assignment Reference Expression
deriving Show
data Expression = Expression String
- | FunCall Identifier [Expression]
+ | FunCall Reference [Expression]
| PrefixOp String Expression
+ | PostfixOp String Expression
| BinOp String Expression Expression
+ | StringLiteral String
+ | CharCode String
+ | NumberLiteral String
+ | HexNumber String
+ | Address Reference
+ | Reference Reference
+ deriving Show
+data Reference = ArrayElement Identifier Expression
+ | SimpleReference Identifier
+ | RecordField Reference Reference
+ | Dereference Reference
deriving Show
-
pascalLanguageDef
= emptyDef
{ commentStart = "(*"
@@ -69,13 +83,27 @@
, "implementation", "and", "or", "xor", "shl"
, "shr", "while", "do", "repeat", "until", "case", "of"
, "type", "var", "const", "out", "array"
- , "procedure", "function"
+ , "procedure", "function", "with", "for", "to"
+ , "downto", "div", "mod", "record", "set"
]
, reservedOpNames= []
, caseSensitive = False
}
-pas = makeTokenParser pascalLanguageDef
+pas = patch $ makeTokenParser pascalLanguageDef
+ where
+ patch tp = tp {stringLiteral = sl}
+ sl = do
+ (char '\'')
+ s <- (many $ noneOf "'")
+ (char '\'')
+ ss <- many $ do
+ (char '\'')
+ s' <- (many $ noneOf "'")
+ (char '\'')
+ return $ '\'' : s'
+ comments
+ return $ concat (s:ss)
comments = do
spaces
@@ -95,33 +123,93 @@
, (try $ string "//") >> manyTill anyChar (try newline)
]
+iD = do
+ i <- liftM Identifier (identifier pas)
+ comments
+ return i
+
unit = do
- name <- liftM Identifier unitName
+ string "unit" >> comments
+ name <- iD
+ semi pas
comments
int <- interface
impl <- implementation
comments
return $ Unit name int impl Nothing Nothing
+
+
+reference = buildExpressionParser table term <?> "reference"
where
- unitName = between (string "unit" >> comments) (semi pas) (identifier pas)
+ term = comments >> choice [
+ parens pas reference
+ , try $ iD >>= \i -> (brackets pas) expression >>= return . ArrayElement i
+ , iD >>= return . SimpleReference
+ ] <?> "simple reference"
-varsDecl endsWithSemi = do
- vs <- many (try (aVarDecl >> semi pas) >> comments)
- when (not endsWithSemi) $ aVarDecl >> return ()
+ table = [
+ [Postfix (char '^' >> return Dereference)]
+ , [Infix (char '.' >> return RecordField) AssocLeft]
+ ]
+
+varsDecl1 = varsParser many1
+varsDecl = varsParser many
+varsParser m endsWithSemi = do
+ vs <- m (aVarDecl >>= \i -> semi pas >> comments >> return i)
+ v <- if not endsWithSemi then liftM (\a -> [a]) aVarDecl else return []
comments
- return $ VarDeclaration $ show vs
+ return $ vs ++ v
where
aVarDecl = do
- ids <- (commaSep1 pas) $ ((identifier pas) <?> "variable declaration") >>= \i -> comments >> return (Identifier i)
- char ':'
+ when (not endsWithSemi) $
+ optional $ choice [
+ try $ string "var"
+ , try $ string "const"
+ , try $ string "out"
+ ]
+ comments
+ ids <- try $ do
+ i <- (commaSep1 pas) $ (iD <?> "variable declaration")
+ char ':'
+ return i
+ comments
+ t <- typeDecl <?> "variable type declaration"
comments
- t <- typeDecl
+ init <- option Nothing $ do
+ char '='
+ comments
+ e <- expression
+ comments
+ char ';'
+ comments
+ return (Just e)
+ return $ VarDeclaration False (ids, t) init
+
+
+constsDecl = do
+ vs <- many (try (aConstDecl >>= \i -> semi pas >> return i) >>= \i -> comments >> return i)
+ comments
+ return vs
+ where
+ aConstDecl = do
comments
- return (ids, t)
+ i <- iD <?> "const declaration"
+ optional $ do
+ char ':'
+ comments
+ t <- typeDecl
+ return ()
+ char '='
+ comments
+ e <- expression
+ comments
+ return $ VarDeclaration False ([i], UnknownType) (Just e)
typeDecl = choice [
arrayDecl
+ , recordDecl
, rangeDecl >>= return . RangeType
+ , seqenceDecl >>= return . Sequence
, identifier pas >>= return . SimpleType . Identifier
] <?> "type declaration"
where
@@ -136,13 +224,44 @@
comments
t <- typeDecl
return $ ArrayDecl r t
+ recordDecl = do
+ try $ string "record"
+ comments
+ vs <- varsDecl True
+ string "end"
+ return $ RecordType vs
+ seqenceDecl = (parens pas) $ (commaSep pas) iD
+typesDecl = many (aTypeDecl >>= \t -> comments >> return t)
+ where
+ aTypeDecl = do
+ i <- try $ do
+ i <- iD <?> "type declaration"
+ comments
+ char '='
+ return i
+ comments
+ t <- typeDecl
+ comments
+ semi pas
+ comments
+ return $ TypeDeclaration i t
+
rangeDecl = choice [
- identifier pas >>= return . Range . Identifier
+ try $ rangeft
+ , iD >>= return . Range
] <?> "range declaration"
-
-typeVarDeclaration isImpl = choice [
+ where
+ rangeft = do
+ e1 <- expression
+ string ".."
+ e2 <- expression
+ return $ RangeFromTo e1 e2
+
+typeVarDeclaration isImpl = (liftM concat . many . choice) [
varSection,
+ constSection,
+ typeSection,
funcDecl,
procDecl
]
@@ -150,14 +269,28 @@
varSection = do
try $ string "var"
comments
- v <- varsDecl True
+ v <- varsDecl1 True
comments
return v
-
+
+ constSection = do
+ try $ string "const"
+ comments
+ c <- constsDecl
+ comments
+ return c
+
+ typeSection = do
+ try $ string "type"
+ comments
+ t <- typesDecl
+ comments
+ return t
+
procDecl = do
string "procedure"
comments
- i <- liftM Identifier $ identifier pas
+ i <- iD
optional $ do
char '('
varsDecl False
@@ -167,51 +300,53 @@
b <- if isImpl then
do
comments
- typeVarDeclaration isImpl
+ optional $ typeVarDeclaration True
comments
liftM Just functionBody
else
return Nothing
comments
- return $ FunctionDeclaration i (Identifier "") b
+ return $ [FunctionDeclaration i (Identifier "") b]
funcDecl = do
string "function"
comments
+ i <- iD
optional $ do
char '('
varsDecl False
char ')'
comments
char ':'
- ret <- identifier pas
+ ret <- iD
comments
char ';'
b <- if isImpl then
do
comments
- typeVarDeclaration isImpl
+ optional $ typeVarDeclaration True
comments
liftM Just functionBody
else
return Nothing
- return $ FunctionDeclaration (Identifier "function") (Identifier ret) Nothing
+ return $ [FunctionDeclaration i ret Nothing]
program = do
- name <- liftM Identifier programName
+ string "program"
+ comments
+ name <- iD
+ (char ';')
comments
impl <- implementation
comments
return $ Program name impl
- where
- programName = between (string "program") (char ';') (identifier pas)
interface = do
string "interface"
comments
u <- uses
comments
- tv <- many (typeVarDeclaration False)
+ tv <- typeVarDeclaration False
comments
return $ Interface u (TypesAndVars tv)
@@ -220,7 +355,7 @@
comments
u <- uses
comments
- tv <- many (typeVarDeclaration True)
+ tv <- typeVarDeclaration True
string "end."
comments
return $ Implementation u (TypesAndVars tv)
@@ -229,30 +364,37 @@
where
term = comments >> choice [
parens pas $ expression
- , natural pas >>= return . Expression . show
- , funCall
+ , integer pas >>= return . NumberLiteral . show
+ , stringLiteral pas >>= return . StringLiteral
+ , char '#' >> many digit >>= return . CharCode
+ , char '$' >> many hexDigit >>= return . HexNumber
+ , char '@' >> reference >>= return . Address
+ , try $ funCall
+ , reference >>= return . Reference
] <?> "simple expression"
table = [
- [Infix (string "^." >> return (BinOp "^.")) AssocLeft]
- , [Prefix (string "not" >> return (PrefixOp "not"))]
+ [Prefix (string "not" >> return (PrefixOp "not"))]
, [ Infix (char '*' >> return (BinOp "*")) AssocLeft
, Infix (char '/' >> return (BinOp "/")) AssocLeft
- ]
+ , Infix (try (string "div") >> return (BinOp "div")) AssocLeft
+ , Infix (try (string "mod") >> return (BinOp "mod")) AssocLeft
+ ]
, [ Infix (char '+' >> return (BinOp "+")) AssocLeft
, Infix (char '-' >> return (BinOp "-")) AssocLeft
- ]
- , [ Infix (try (string "<>" )>> return (BinOp "<>")) AssocNone
+ , Prefix (char '-' >> return (PrefixOp "-"))
+ ]
+ , [ Infix (try (string "<>") >> return (BinOp "<>")) AssocNone
, Infix (try (string "<=") >> return (BinOp "<=")) AssocNone
, Infix (try (string ">=") >> return (BinOp ">=")) AssocNone
, Infix (char '<' >> return (BinOp "<")) AssocNone
, Infix (char '>' >> return (BinOp ">")) AssocNone
, Infix (char '=' >> return (BinOp "=")) AssocNone
- ]
- , [ Infix (try $ string "and" >> return (BinOp "and")) AssocNone
- , Infix (try $ string "or" >> return (BinOp "or")) AssocNone
- , Infix (try $ string "xor" >> return (BinOp "xor")) AssocNone
- ]
+ ]
+ , [ Infix (try $ string "and" >> return (BinOp "and")) AssocLeft
+ , Infix (try $ string "or" >> return (BinOp "or")) AssocLeft
+ , Infix (try $ string "xor" >> return (BinOp "xor")) AssocLeft
+ ]
]
phrasesBlock = do
@@ -267,8 +409,11 @@
phrasesBlock
, ifBlock
, whileCycle
+ , repeatCycle
, switchCase
- , try $ identifier pas >>= \i -> string ":=" >> expression >>= return . Assignment (Identifier i)
+ , withBlock
+ , forCycle
+ , (try $ reference >>= \r -> string ":=" >> return r) >>= \r -> expression >>= return . Assignment r
, procCall
]
optional $ char ';'
@@ -290,7 +435,6 @@
o <- phrase
comments
return o
- optional $ char ';'
return $ IfThenElse e o1 o2
whileCycle = do
@@ -301,9 +445,47 @@
string "do"
comments
o <- phrase
- optional $ char ';'
return $ WhileCycle e o
+withBlock = do
+ try $ string "with"
+ comments
+ e <- expression
+ comments
+ string "do"
+ comments
+ o <- phrase
+ return $ WithBlock e o
+
+repeatCycle = do
+ try $ string "repeat"
+ comments
+ o <- many phrase
+ string "until"
+ comments
+ e <- expression
+ comments
+ return $ RepeatCycle e o
+
+forCycle = do
+ try $ string "for"
+ comments
+ i <- iD
+ comments
+ string ":="
+ comments
+ e1 <- expression
+ comments
+ choice [string "to", string "downto"]
+ comments
+ e2 <- expression
+ comments
+ string "do"
+ comments
+ p <- phrase
+ comments
+ return $ ForCycle i e1 e2 p
+
switchCase = do
try $ string "case"
comments
@@ -319,7 +501,6 @@
comments
return o
string "end"
- optional $ char ';'
return $ SwitchCase e cs o2
where
aCase = do
@@ -332,16 +513,16 @@
return (e, p)
procCall = do
- i <- liftM Identifier $ identifier pas
+ i <- iD
p <- option [] $ (parens pas) parameters
return $ ProcCall i p
funCall = do
- i <- liftM Identifier $ identifier pas
- p <- option [] $ (parens pas) parameters
- return $ FunCall i p
+ r <- reference
+ p <- (parens pas) $ option [] parameters
+ return $ FunCall r p
-parameters = expression `sepBy` (char ',' >> comments)
+parameters = (commaSep pas) expression <?> "parameters"
functionBody = do
p <- phrasesBlock
@@ -354,7 +535,7 @@
u = do
string "uses"
comments
- u <- (identifier pas >>= \i -> comments >> return (Identifier i)) `sepBy1` (char ',' >> comments)
+ u <- (iD >>= \i -> comments >> return i) `sepBy1` (char ',' >> comments)
char ';'
comments
return u