hedgewars-draft: comparison tools/PascalParser.hs

equal deleted inserted replaced

-:eca20f8990e2
+:1a49a8fcca56
 data Identifier = Identifier String
 deriving Show
 data TypesAndVars = TypesAndVars [TypeVarDeclaration]
 deriving Show
 data TypeVarDeclaration = TypeDeclaration Identifier TypeDecl
-| VarDeclaration Bool ([Identifier], TypeDecl) (Maybe Expression)
+| VarDeclaration Bool ([Identifier], TypeDecl) (Maybe InitExpression)
 | FunctionDeclaration Identifier TypeDecl (Maybe Phrase)
 deriving Show
 data TypeDecl = SimpleType Identifier
 | RangeType Range
 | Sequence [Identifier]
 data Phrase = ProcCall Identifier [Expression]
 | IfThenElse Expression Phrase (Maybe Phrase)
 | WhileCycle Expression Phrase
 | RepeatCycle Expression [Phrase]
 | ForCycle Identifier Expression Expression Phrase
-| WithBlock Expression Phrase
+| WithBlock Reference Phrase
 | Phrases [Phrase]
 | SwitchCase Expression [(Expression, Phrase)] (Maybe Phrase)
 | Assignment Reference Expression
 deriving Show
 data Expression = Expression String
 | PostfixOp String Expression
 | BinOp String Expression Expression
 | StringLiteral String
 | CharCode String
 | NumberLiteral String
+| FloatLiteral String
 | HexNumber String
 | Reference Reference
 | Null
 deriving Show
 data Reference = ArrayElement [Expression] Reference
 | FunCall [Expression] Reference
+| BuiltInFunCall [Expression] Reference
 | SimpleReference Identifier
 | Dereference Reference
 | RecordField Reference Reference
 | Address Reference
 deriving Show
+data InitExpression = InitBinOp String InitExpression InitExpression
+| InitPrefixOp String InitExpression
+| InitReference Identifier
+| InitArray [InitExpression]
+| InitRecord [(Identifier, InitExpression)]
+| InitFloat String
+| InitNumber String
+| InitHexNumber String
+| InitString String
+| InitChar String
+| InitNull
+deriving Show
 pascalLanguageDef
 = emptyDef
 { commentStart   = "(*"
 , commentEnd     = "*)"
 , "implementation", "and", "or", "xor", "shl"
 , "shr", "while", "do", "repeat", "until", "case", "of"
 , "type", "var", "const", "out", "array", "packed"
 , "procedure", "function", "with", "for", "to"
 , "downto", "div", "mod", "record", "set", "nil"
-, "string", "shortstring"
+, "string", "shortstring", "succ", "pred", "low"
+, "high"
 ]
 , reservedOpNames= []
 , caseSensitive  = False
 }
 t <- typeDecl <?> "variable type declaration"
 comments
 init <- option Nothing $ do
 char '='
 comments
-e <- expression
+e <- initExpression
 comments
 return (Just e)
 return $ VarDeclaration False (ids, t) init
 comments
 t <- typeDecl
 return ()
 char '='
 comments
-e <- expression
+e <- initExpression
 comments
 return $ VarDeclaration False ([i], UnknownType) (Just e)
 typeDecl = choice [
 char '^' >> typeDecl >>= return . PointerTo
 , try (string "shortstring") >> return String
 , arrayDecl
 , recordDecl
+, sequenceDecl >>= return . Sequence
+, try (identifier pas) >>= return . SimpleType . Identifier
 , rangeDecl >>= return . RangeType
-, sequenceDecl >>= return . Sequence
-, identifier pas >>= return . SimpleType . Identifier
 ] <?> "type declaration"
 where
 arrayDecl = do
 try $ string "array"
 comments
 optional $ typeVarDeclaration True
 comments
 liftM Just functionBody
 else
 return Nothing
-return $ [FunctionDeclaration i ret Nothing]
+return $ [FunctionDeclaration i ret b]
 program = do
 string "program"
 comments
 name <- iD
 expression = buildExpressionParser table term <?> "expression"
 where
 term = comments >> choice [
 parens pas $ expression
+, try $ integer pas >>= \i -> notFollowedBy (char '.') >> (return . NumberLiteral . show) i
+, try $ float pas >>= return . FloatLiteral . show
 , try $ integer pas >>= return . NumberLiteral . show
 , stringLiteral pas >>= return . StringLiteral
 , char '#' >> many digit >>= return . CharCode
 , char '$' >> many hexDigit >>= return . HexNumber
 , try $ string "nil" >> return Null
 ]
 , [  Infix (try $ string "and" >> return (BinOp "and")) AssocLeft
 , Infix (try $ string "or" >> return (BinOp "or")) AssocLeft
 , Infix (try $ string "xor" >> return (BinOp "xor")) AssocLeft
 ]
-, [  Infix (try $ string "shl" >> return (BinOp "and")) AssocNone
+, [  Infix (try $ string "shl" >> return (BinOp "shl")) AssocNone
-, Infix (try $ string "shr" >> return (BinOp "or")) AssocNone
+, Infix (try $ string "shr" >> return (BinOp "shr")) AssocNone
 ]
 , [Prefix (try (string "not") >> return (PrefixOp "not"))]
 ]
 phrasesBlock = do
 return $ WhileCycle e o
 withBlock = do
 try $ string "with"
 comments
-e <- expression
+r <- reference
 comments
 string "do"
 comments
 o <- phrase
-return $ WithBlock e o
+return $ WithBlock r o
 repeatCycle = do
 try $ string "repeat"
 comments
 o <- many phrase
 comments
 u <- (iD >>= \i -> comments >> return i) `sepBy1` (char ',' >> comments)
 char ';'
 comments
 return u
+initExpression = buildExpressionParser table term <?> "initialization expression"
+where
+term = comments >> choice [
+try $ parens pas (commaSep pas $ initExpression) >>= return . InitArray
+, parens pas (semiSep pas $ recField) >>= return . InitRecord
+, try $ integer pas >>= \i -> notFollowedBy (char '.') >> (return . InitNumber . show) i
+, try $ float pas >>= return . InitFloat . show
+, stringLiteral pas >>= return . InitString
+, char '#' >> many digit >>= return . InitChar
+, char '$' >> many hexDigit >>= return . InitHexNumber
+, try $ string "nil" >> return InitNull
+, iD >>= return . InitReference
+]
+recField = do
+i <- iD
+spaces
+char ':'
+spaces
+e <- initExpression
+spaces
+return (i ,e)
+table = [
+[  Infix (char '*' >> return (InitBinOp "*")) AssocLeft
+, Infix (char '/' >> return (InitBinOp "/")) AssocLeft
+, Infix (try (string "div") >> return (InitBinOp "div")) AssocLeft
+, Infix (try (string "mod") >> return (InitBinOp "mod")) AssocLeft
+]
+, [  Infix (char '+' >> return (InitBinOp "+")) AssocLeft
+, Infix (char '-' >> return (InitBinOp "-")) AssocLeft
+, Prefix (char '-' >> return (InitPrefixOp "-"))
+]
+, [  Infix (try (string "<>") >> return (InitBinOp "<>")) AssocNone
+, Infix (try (string "<=") >> return (InitBinOp "<=")) AssocNone
+, Infix (try (string ">=") >> return (InitBinOp ">=")) AssocNone
+, Infix (char '<' >> return (InitBinOp "<")) AssocNone
+, Infix (char '>' >> return (InitBinOp ">")) AssocNone
+, Infix (char '=' >> return (InitBinOp "=")) AssocNone
+]
+, [  Infix (try $ string "and" >> return (InitBinOp "and")) AssocLeft
+, Infix (try $ string "or" >> return (InitBinOp "or")) AssocLeft
+, Infix (try $ string "xor" >> return (InitBinOp "xor")) AssocLeft
+]
+, [  Infix (try $ string "shl" >> return (InitBinOp "and")) AssocNone
+, Infix (try $ string "shr" >> return (InitBinOp "or")) AssocNone
+]
+, [Prefix (try (string "not") >> return (InitPrefixOp "not"))]
+]

branch	0.9.17
changeset 6366	1a49a8fcca56
parent 6357	52cb4807a78c
child 6386	7d7703b26bda