Mercurial Mercurial > hedgewars / comparison
summary | shortlog | changelog | graph | tags | bookmarks | branches | files | changeset | file | latest | revisions | annotate | diff | comparison | raw | help
Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
tools/PascalParser.hs
changeset 7429 fcf13e40d6b6
parent 7317 3534a264b27a
child 7513 39866eb9e4a6
equal deleted inserted replaced
7426:55b49cc1f33a 7429:fcf13e40d6b6 
    17 
    17 
    18 knownTypes = ["shortstring", "ansistring", "char", "byte"]
 
    18 knownTypes = ["shortstring", "ansistring", "char", "byte"]
 
    19 
    19 
    20 pascalUnit = do
 
    20 pascalUnit = do
 
    21     comments
 
    21     comments
 
    22     u <- choice [program, unit, systemUnit]
 
    22     u <- choice [program, unit, systemUnit, redoUnit]
 
    23     comments
 
    23     comments
 
    24     return u
 
    24     return u
 
    25 
    25 
    26 iD = do
 
    26 iD = do
 
    27     i <- liftM (flip Identifier BTUnknown) (identifier pas)
 
    27     i <- liftM (flip Identifier BTUnknown) (identifier pas)
 
   346     tv <- typeVarDeclaration True
 
   346     tv <- typeVarDeclaration True
 
   347     string "end."
 
   347     string "end."
 
   348     comments
 
   348     comments
 
   349     return $ Implementation u (TypesAndVars tv)
 
   349     return $ Implementation u (TypesAndVars tv)
 
   350 
   350 
   351 expression = buildExpressionParser table term <?> "expression"
 
   351 expression = do
 
       
   352     buildExpressionParser table term <?> "expression"
 
   352     where
 
   353     where
 
   353     term = comments >> choice [
 
   354     term = comments >> choice [
 
   354         builtInFunction expression >>= \(n, e) -> return $ BuiltInFunCall e (SimpleReference (Identifier n BTUnknown))
 
   355         builtInFunction expression >>= \(n, e) -> return $ BuiltInFunCall e (SimpleReference (Identifier n BTUnknown))
 
   355         , try (parens pas $ expression >>= \e -> notFollowedBy (comments >> char '.') >> return e)
 
   356         , try (parens pas $ expression >>= \e -> notFollowedBy (comments >> char '.') >> return e)
 
   356         , brackets pas (commaSep pas iD) >>= return . SetExpression
 
   357         , brackets pas (commaSep pas iD) >>= return . SetExpression
 
   357         , try $ natural pas >>= \i -> notFollowedBy (char '.') >> (return . NumberLiteral . show) i
 
   358         , try $ integer pas >>= \i -> notFollowedBy (char '.') >> (return . NumberLiteral . show) i
 
   358         , float pas >>= return . FloatLiteral . show
 
   359         , float pas >>= return . FloatLiteral . show
 
   359         , natural pas >>= return . NumberLiteral . show
 
   360         , try $ integer pas >>= return . NumberLiteral . show
 
   360         , try (string "_S" >> stringLiteral pas) >>= return . StringLiteral
 
   361         , try (string "_S" >> stringLiteral pas) >>= return . StringLiteral
 
   361         , try (string "_P" >> stringLiteral pas) >>= return . PCharLiteral
 
   362         , try (string "_P" >> stringLiteral pas) >>= return . PCharLiteral
 
   362         , stringLiteral pas >>= return . strOrChar
 
   363         , stringLiteral pas >>= return . strOrChar
 
   363         , try (string "#$") >> many hexDigit >>= \c -> comments >> return (HexCharCode c)
 
   364         , try (string "#$") >> many hexDigit >>= \c -> comments >> return (HexCharCode c)
 
   364         , char '#' >> many digit >>= \c -> comments >> return (CharCode c)
 
   365         , char '#' >> many digit >>= \c -> comments >> return (CharCode c)
 
   365         , char '$' >> many hexDigit >>=  \h -> comments >> return (HexNumber h)
 
   366         , char '$' >> many hexDigit >>=  \h -> comments >> return (HexNumber h)
 
   366         , char '-' >> expression >>= return . PrefixOp "-"
 
   367         --, char '-' >> expression >>= return . PrefixOp "-"
 
       
   368         , char '-' >> reference >>= return . PrefixOp "-" . Reference
 
       
   369         , try $ string "not" >> error "unexpected not in term"
 
   367         , try $ string "nil" >> return Null
 
   370         , try $ string "nil" >> return Null
 
   368         , try $ string "not" >> expression >>= return . PrefixOp "not"
 
       
   369         , reference >>= return . Reference
 
   371         , reference >>= return . Reference
 
   370         ] <?> "simple expression"
 
   372         ] <?> "simple expression"
 
   371 
   373 
   372     table = [ 
   374     table = [
 
       
   375           [  Prefix (try (string "not") >> return (PrefixOp "not"))
 
       
   376            , Prefix (try (char '-') >> return (PrefixOp "-"))]
 
       
   377         ,
 
   373           [  Infix (char '*' >> return (BinOp "*")) AssocLeft
 
   378           [  Infix (char '*' >> return (BinOp "*")) AssocLeft
 
   374            , Infix (char '/' >> return (BinOp "/")) AssocLeft
 
   379            , Infix (char '/' >> return (BinOp "/")) AssocLeft
 
   375            , Infix (try (string "div") >> return (BinOp "div")) AssocLeft
 
   380            , Infix (try (string "div") >> return (BinOp "div")) AssocLeft
 
   376            , Infix (try (string "mod") >> return (BinOp "mod")) AssocLeft
 
   381            , Infix (try (string "mod") >> return (BinOp "mod")) AssocLeft
 
   377            , Infix (try (string "in") >> return (BinOp "in")) AssocNone
 
   382            , Infix (try (string "in") >> return (BinOp "in")) AssocNone
 
       
   383            , Infix (try $ string "and" >> return (BinOp "and")) AssocLeft
 
       
   384            , Infix (try $ string "shl" >> return (BinOp "shl")) AssocLeft
 
       
   385            , Infix (try $ string "shr" >> return (BinOp "shr")) AssocLeft
 
   378           ]
 
   386           ]
 
   379         , [  Infix (char '+' >> return (BinOp "+")) AssocLeft
 
   387         , [  Infix (char '+' >> return (BinOp "+")) AssocLeft
 
   380            , Infix (char '-' >> return (BinOp "-")) AssocLeft
 
   388            , Infix (char '-' >> return (BinOp "-")) AssocLeft
 
       
   389            , Infix (try $ string "or" >> return (BinOp "or")) AssocLeft
 
       
   390            , Infix (try $ string "xor" >> return (BinOp "xor")) AssocLeft
 
   381           ]
 
   391           ]
 
   382         , [  Infix (try (string "<>") >> return (BinOp "<>")) AssocNone
 
   392         , [  Infix (try (string "<>") >> return (BinOp "<>")) AssocNone
 
   383            , Infix (try (string "<=") >> return (BinOp "<=")) AssocNone
 
   393            , Infix (try (string "<=") >> return (BinOp "<=")) AssocNone
 
   384            , Infix (try (string ">=") >> return (BinOp ">=")) AssocNone
 
   394            , Infix (try (string ">=") >> return (BinOp ">=")) AssocNone
 
   385            , Infix (char '<' >> return (BinOp "<")) AssocNone
 
   395            , Infix (char '<' >> return (BinOp "<")) AssocNone
 
   386            , Infix (char '>' >> return (BinOp ">")) AssocNone
 
   396            , Infix (char '>' >> return (BinOp ">")) AssocNone
 
   387           ]
 
   397           ]
 
   388         , [  Infix (try $ string "shl" >> return (BinOp "shl")) AssocNone
 
   398         {-, [  Infix (try $ string "shl" >> return (BinOp "shl")) AssocNone
 
   389            , Infix (try $ string "shr" >> return (BinOp "shr")) AssocNone
 
   399              , Infix (try $ string "shr" >> return (BinOp "shr")) AssocNone
 
   390           ]
 
   400           ]
 
   391         , [  Infix (try $ string "and" >> return (BinOp "and")) AssocLeft
 
   401         , [ 
   392            , Infix (try $ string "or" >> return (BinOp "or")) AssocLeft
 
   402              Infix (try $ string "or" >> return (BinOp "or")) AssocLeft
 
   393            , Infix (try $ string "xor" >> return (BinOp "xor")) AssocLeft
 
   403            , Infix (try $ string "xor" >> return (BinOp "xor")) AssocLeft
 
   394           ]
 
   404           ]-}
 
   395         , [
 
   405         , [
 
   396              Infix (char '=' >> return (BinOp "=")) AssocNone
 
   406              Infix (char '=' >> return (BinOp "=")) AssocNone
 
   397           ]
 
   407           ]
 
   398         ]
 
   408         ]
 
   399     strOrChar [a] = CharCode . show . ord $ a
 
   409     strOrChar [a] = CharCode . show . ord $ a
 
   413         , whileCycle
 
   423         , whileCycle
 
   414         , repeatCycle
 
   424         , repeatCycle
 
   415         , switchCase
 
   425         , switchCase
 
   416         , withBlock
 
   426         , withBlock
 
   417         , forCycle
 
   427         , forCycle
 
   418         , (try $ reference >>= \r -> string ":=" >> return r) >>= \r -> expression >>= return . Assignment r
 
   428         , (try $ reference >>= \r -> string ":=" >> return r) >>= \r -> comments >> expression >>= return . Assignment r
 
   419         , builtInFunction expression >>= \(n, e) -> return $ BuiltInFunctionCall e (SimpleReference (Identifier n BTUnknown))
 
   429         , builtInFunction expression >>= \(n, e) -> return $ BuiltInFunctionCall e (SimpleReference (Identifier n BTUnknown))
 
   420         , procCall
 
   430         , procCall
 
   421         , char ';' >> comments >> return NOP
 
   431         , char ';' >> comments >> return NOP
 
   422         ]
 
   432         ]
 
   423     optional $ char ';'
 
   433     optional $ char ';'
 
   478     comments
 
   488     comments
 
   479     string ":="
 
   489     string ":="
 
   480     comments
 
   490     comments
 
   481     e1 <- expression
 
   491     e1 <- expression
 
   482     comments
 
   492     comments
 
   483     choice [string "to", string "downto"]
 
   493     up <- liftM (== Just "to") $
 
       
   494             optionMaybe $ choice [
 
       
   495                 try $ string "to"
 
       
   496                 , try $ string "downto"
 
       
   497                 ]   
       
   498     --choice [string "to", string "downto"]
 
   484     comments
 
   499     comments
 
   485     e2 <- expression
 
   500     e2 <- expression
 
   486     comments
 
   501     comments
 
   487     string "do"
 
   502     string "do"
 
   488     comments
 
   503     comments
 
   489     p <- phrase
 
   504     p <- phrase
 
   490     comments
 
   505     comments
 
   491     return $ ForCycle i e1 e2 p
 
   506     return $ ForCycle i e1 e2 p up
 
   492 
   507 
   493 switchCase = do
 
   508 switchCase = do
 
   494     try $ string "case"
 
   509     try $ string "case"
 
   495     comments
 
   510     comments
 
   496     e <- expression
 
   511     e <- expression
 
   571         return (i ,e)
 
   586         return (i ,e)
 
   572 
   587 
   573     table = [
 
   588     table = [
 
   574           [
 
   589           [
 
   575              Prefix (char '-' >> return (InitPrefixOp "-"))
 
   590              Prefix (char '-' >> return (InitPrefixOp "-"))
 
       
   591             ,Prefix (try (string "not") >> return (InitPrefixOp "not"))
 
   576           ]
 
   592           ]
 
   577         , [  Infix (char '*' >> return (InitBinOp "*")) AssocLeft
 
   593         , [  Infix (char '*' >> return (InitBinOp "*")) AssocLeft
 
   578            , Infix (char '/' >> return (InitBinOp "/")) AssocLeft
 
   594            , Infix (char '/' >> return (InitBinOp "/")) AssocLeft
 
   579            , Infix (try (string "div") >> return (InitBinOp "div")) AssocLeft
 
   595            , Infix (try (string "div") >> return (InitBinOp "div")) AssocLeft
 
   580            , Infix (try (string "mod") >> return (InitBinOp "mod")) AssocLeft
 
   596            , Infix (try (string "mod") >> return (InitBinOp "mod")) AssocLeft
 
       
   597            , Infix (try $ string "and" >> return (InitBinOp "and")) AssocLeft
 
       
   598            , Infix (try $ string "shl" >> return (InitBinOp "shl")) AssocNone
 
       
   599            , Infix (try $ string "shr" >> return (InitBinOp "shr")) AssocNone
 
   581           ]
 
   600           ]
 
   582         , [  Infix (char '+' >> return (InitBinOp "+")) AssocLeft
 
   601         , [  Infix (char '+' >> return (InitBinOp "+")) AssocLeft
 
   583            , Infix (char '-' >> return (InitBinOp "-")) AssocLeft
 
   602            , Infix (char '-' >> return (InitBinOp "-")) AssocLeft
 
       
   603            , Infix (try $ string "or" >> return (InitBinOp "or")) AssocLeft
 
       
   604            , Infix (try $ string "xor" >> return (InitBinOp "xor")) AssocLeft
 
   584           ]
 
   605           ]
 
   585         , [  Infix (try (string "<>") >> return (InitBinOp "<>")) AssocNone
 
   606         , [  Infix (try (string "<>") >> return (InitBinOp "<>")) AssocNone
 
   586            , Infix (try (string "<=") >> return (InitBinOp "<=")) AssocNone
 
   607            , Infix (try (string "<=") >> return (InitBinOp "<=")) AssocNone
 
   587            , Infix (try (string ">=") >> return (InitBinOp ">=")) AssocNone
 
   608            , Infix (try (string ">=") >> return (InitBinOp ">=")) AssocNone
 
   588            , Infix (char '<' >> return (InitBinOp "<")) AssocNone
 
   609            , Infix (char '<' >> return (InitBinOp "<")) AssocNone
 
   589            , Infix (char '>' >> return (InitBinOp ">")) AssocNone
 
   610            , Infix (char '>' >> return (InitBinOp ">")) AssocNone
 
   590            , Infix (char '=' >> return (InitBinOp "=")) AssocNone
 
   611            , Infix (char '=' >> return (InitBinOp "=")) AssocNone
 
   591           ]
 
   612           ]
 
   592         , [  Infix (try $ string "and" >> return (InitBinOp "and")) AssocLeft
 
   613         {--, [  Infix (try $ string "and" >> return (InitBinOp "and")) AssocLeft
 
   593            , Infix (try $ string "or" >> return (InitBinOp "or")) AssocLeft
 
   614            , Infix (try $ string "or" >> return (InitBinOp "or")) AssocLeft
 
   594            , Infix (try $ string "xor" >> return (InitBinOp "xor")) AssocLeft
 
   615            , Infix (try $ string "xor" >> return (InitBinOp "xor")) AssocLeft
 
   595           ]
 
   616           ]
 
   596         , [  Infix (try $ string "shl" >> return (InitBinOp "shl")) AssocNone
 
   617         , [  Infix (try $ string "shl" >> return (InitBinOp "shl")) AssocNone
 
   597            , Infix (try $ string "shr" >> return (InitBinOp "shr")) AssocNone
 
   618            , Infix (try $ string "shr" >> return (InitBinOp "shr")) AssocNone
 
   598           ]
 
   619           ]--}
 
   599         , [Prefix (try (string "not") >> return (InitPrefixOp "not"))]
 
   620         --, [Prefix (try (string "not") >> return (InitPrefixOp "not"))]
 
   600         ]
 
   621         ]
 
   601 
   622 
   602     itypeCast = do
 
   623     itypeCast = do
 
   603         t <- choice $ map (\s -> try $ caseInsensitiveString s >>= \i -> notFollowedBy alphaNum >> return i) knownTypes
 
   624         t <- choice $ map (\s -> try $ caseInsensitiveString s >>= \i -> notFollowedBy alphaNum >> return i) knownTypes
 
   604         i <- parens pas initExpression
 
   625         i <- parens pas initExpression
 
   619     comments
 
   640     comments
 
   620     t <- typesDecl
 
   641     t <- typesDecl
 
   621     string "var"
 
   642     string "var"
 
   622     v <- varsDecl True
 
   643     v <- varsDecl True
 
   623     return $ System (t ++ v)
 
   644     return $ System (t ++ v)
 
       
   645 
       
   646 redoUnit = do
 
       
   647     string "redo;"
 
       
   648     comments
 
       
   649     string "type"
 
       
   650     comments
 
       
   651     t <- typesDecl
 
       
   652     string "var"
 
       
   653     v <- varsDecl True
 
       
   654     return $ Redo (t ++ v)
 
       
   655
hedgewars