hedgewars: comparison tools/PascalParser.hs

equal deleted inserted replaced

-:8b3575750cd2
+:514138949c76
 import Data.Maybe
 import Data.Char
 import PascalBasics
 import PascalUnitSyntaxTree
 knownTypes = ["shortstring", "ansistring", "char", "byte"]
 pascalUnit = do
 comments
 u <- choice [program, unit, systemUnit]
 iD = do
 i <- liftM (flip Identifier BTUnknown) (identifier pas)
 comments
 return i
 unit = do
 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
 term = comments >> choice [
 parens pas (liftM RefExpression expression >>= postfixes) >>= postfixes
 , try $ typeCast >>= postfixes
 , char '@' >> liftM Address reference >>= postfixes
 , liftM SimpleReference iD >>= postfixes
 ] <?> "simple reference"
 table = [
 ]
 postfixes r = many postfix >>= return . foldl (flip ($)) r
 postfix = choice [
 parens pas (option [] parameters) >>= return . FunCall
 , char '^' >> return Dereference
 , (brackets pas) (commaSep1 pas $ expression) >>= return . ArrayElement
 typeCast = do
 t <- choice $ map (\s -> try $ caseInsensitiveString s >>= \i -> notFollowedBy alphaNum >> return i) knownTypes
 e <- parens pas expression
 comments
 return $ TypeCast (Identifier t BTUnknown) e
+varsDecl1 = varsParser sepEndBy1
-varsDecl1 = varsParser sepEndBy1
 varsDecl = varsParser sepEndBy
 varsParser m endsWithSemi = do
 vs <- m (aVarDecl endsWithSemi) (semi pas)
 return vs
 aVarDecl endsWithSemi = do
-unless endsWithSemi $
+isVar <- liftM (== Just "var") $
-optional $ choice [
+if not endsWithSemi then
-try $ string "var"
+optionMaybe $ choice [
-, try $ string "const"
+try $ string "var"
-, try $ string "out"
+, try $ string "const"
-]
+, try $ string "out"
+]
+else
+return Nothing
 comments
 ids <- do
 i <- (commaSep1 pas) $ (try iD <?> "variable declaration")
 char ':'
 return i
 char '='
 comments
 e <- initExpression
 comments
 return (Just e)
-return $ VarDeclaration False (ids, t) init
+return $ VarDeclaration isVar False (ids, t) init
 constsDecl = do
 vs <- many1 (try (aConstDecl >>= \i -> semi pas >> return i) >>= \i -> comments >> return i)
 comments
 return t
 char '='
 comments
 e <- initExpression
 comments
-return $ VarDeclaration (isNothing t) ([i], fromMaybe (DeriveType e) t) (Just e)
+return $ VarDeclaration False (isNothing t) ([i], fromMaybe (DeriveType e) t) (Just e)
 typeDecl = choice [
 char '^' >> typeDecl >>= return . PointerTo
 , try (string "shortstring") >> return (String 255)
 , try (string "string") >> optionMaybe (brackets pas $ integer pas) >>= return . String . fromMaybe 255
 , try (string "ansistring") >> optionMaybe (brackets pas $ integer pas) >>= return . String . fromMaybe 255
 comments
 semi pas
 comments
 return $ TypeDeclaration i t
 rangeDecl = choice [
 try $ rangeft
 , iD >>= return . Range
 ] <?> "range declaration"
 where
 rangeft = do
 e1 <- initExpression
 string ".."
 e2 <- initExpression
 return $ RangeFromTo e1 e2
 typeVarDeclaration isImpl = (liftM concat . many . choice) [
 varSection,
 constSection,
 typeSection,
 funcDecl,
 try $ string "type"
 comments
 t <- typesDecl <?> "type declaration"
 comments
 return t
 operatorDecl = do
 try $ string "operator"
 comments
 i <- manyTill anyChar space
 comments
 liftM Just functionBody
 else
 return Nothing
 return $ [OperatorDeclaration i rid ret vs b]
 funcDecl = do
 fp <- try (string "function") <|> try (string "procedure")
 comments
 i <- iD
 vs <- option [] $ parens pas $ varsDecl False
 b <- if isImpl && (not forward) then
 liftM Just functionBody
 else
 return Nothing
 return $ [FunctionDeclaration i ret vs b]
 functionDecorator = choice [
 try $ string "inline;"
 , try $ caseInsensitiveString "cdecl;"
 , try $ string "overload;"
 , try $ string "export;"
 , try $ string "varargs;"
 , try (string "external") >> comments >> iD >> optional (string "name" >> comments >> stringLiteral pas)>> string ";"
 ] >> comments
 program = do
 string "program"
 comments
 name <- iD
 (char ';')
 , [
 Infix (char '=' >> return (BinOp "=")) AssocNone
 ]
 ]
 strOrChar [a] = CharCode . show . ord $ a
 strOrChar a = StringLiteral a
 phrasesBlock = do
 try $ string "begin"
 comments
 p <- manyTill phrase (try $ string "end" >> notFollowedBy alphaNum)
 comments
 return $ Phrases p
 phrase = do
 o <- choice [
 phrasesBlock
 , ifBlock
 , whileCycle
 comments
 string "do"
 comments
 o <- phrase
 return $ foldr WithBlock o rs
 repeatCycle = do
 try $ string "repeat" >> space
 comments
 o <- many phrase
 string "until"
 string "do"
 comments
 p <- phrase
 comments
 return $ ForCycle i e1 e2 p
 switchCase = do
 try $ string "case"
 comments
 e <- expression
 comments
 char ':'
 comments
 p <- phrase
 comments
 return (e, p)
 procCall = do
 r <- reference
 p <- option [] $ (parens pas) parameters
 return $ ProcCall r p
 parameters = (commaSep pas) expression <?> "parameters"
 functionBody = do
 tv <- typeVarDeclaration True
 comments
 p <- phrasesBlock
 char ';'
 , char '@' >> initExpression >>= \c -> comments >> return (InitAddress c)
 , try $ string "nil" >> return InitNull
 , itypeCast
 , iD >>= return . InitReference
 ]
 recField = do
 i <- iD
 spaces
 char ':'
 spaces
 e <- initExpression
 spaces
 return (i ,e)
 table = [
 [
 Prefix (char '-' >> return (InitPrefixOp "-"))
 ]
 , [  Infix (char '*' >> return (InitBinOp "*")) AssocLeft
 , Infix (char '/' >> return (InitBinOp "/")) AssocLeft
 itypeCast = do
 t <- choice $ map (\s -> try $ caseInsensitiveString s >>= \i -> notFollowedBy alphaNum >> return i) knownTypes
 i <- parens pas initExpression
 comments
 return $ InitTypeCast (Identifier t BTUnknown) i
 builtInFunction e = do
 name <- choice $ map (\s -> try $ caseInsensitiveString s >>= \i -> notFollowedBy alphaNum >> return i) builtin
 spaces
 exprs <- option [] $ parens pas $ option [] $ commaSep1 pas $ e
 spaces

changeset 7374	514138949c76
parent 7317	3534a264b27a
child 7429	fcf13e40d6b6