1 module PascalParser where

     2 

     3 import Text.Parsec

     4 import Text.Parsec.Char

     5 import Text.Parsec.Token

     6 import Text.Parsec.Language

     7 import Text.Parsec.Expr

     8 import Text.Parsec.Prim

     9 import Text.Parsec.Combinator

    10 import Text.Parsec.String

    11 import Control.Monad

    12 import Data.Maybe

    13 import Data.Char

    14 

    15 import PascalBasics

    16 import PascalUnitSyntaxTree

    17 

    18 knownTypes = ["shortstring", "ansistring", "char", "byte"]

    19 

    20 pascalUnit = do

    21     comments

    22     u <- choice [program, unit, systemUnit, redoUnit]

    23     comments

    24     return u

    25 

    26 iD = do

    27     i <- liftM (flip Identifier BTUnknown) (identifier pas)

    28     comments

    29     return i

    30 

    31 unit = do

    32     string "unit" >> comments

    33     name <- iD

    34     semi pas

    35     comments

    36     int <- interface

    37     impl <- implementation

    38     comments

    39     return $ Unit name int impl Nothing Nothing

    40 

    41 

    42 reference = buildExpressionParser table term <?> "reference"

    43     where

    44     term = comments >> choice [

    45         parens pas (liftM RefExpression expression >>= postfixes) >>= postfixes

    46         , try $ typeCast >>= postfixes

    47         , char '@' >> liftM Address reference >>= postfixes

    48         , liftM SimpleReference iD >>= postfixes 

    49         ] <?> "simple reference"

    50 

    51     table = [

    52         ]

    53 

    54     postfixes r = many postfix >>= return . foldl (flip ($)) r

    55     postfix = choice [

    56             parens pas (option [] parameters) >>= return . FunCall

    57           , char '^' >> return Dereference

    58           , (brackets pas) (commaSep1 pas $ expression) >>= return . ArrayElement

    59           , (char '.' >> notFollowedBy (char '.')) >> liftM (flip RecordField) reference

    60         ]

    61 

    62     typeCast = do

    63         t <- choice $ map (\s -> try $ caseInsensitiveString s >>= \i -> notFollowedBy alphaNum >> return i) knownTypes

    64         e <- parens pas expression

    65         comments

    66         return $ TypeCast (Identifier t BTUnknown) e

    67 

    68 varsDecl1 = varsParser sepEndBy1

    69 varsDecl = varsParser sepEndBy

    70 varsParser m endsWithSemi = do

    71     vs <- m (aVarDecl endsWithSemi) (semi pas)

    72     return vs

    73 

    74 aVarDecl endsWithSemi = do

    75     isVar <- liftM (== Just "var") $

    76         if not endsWithSemi then

    77             optionMaybe $ choice [

    78                 try $ string "var"

    79                 , try $ string "const"

    80                 , try $ string "out"

    81                 ]

    82             else

    83                 return Nothing

    84     comments

    85     ids <- do

    86         i <- (commaSep1 pas) $ (try iD <?> "variable declaration")

    87         char ':'

    88         return i

    89     comments

    90     t <- typeDecl <?> "variable type declaration"

    91     comments

    92     init <- option Nothing $ do

    93         char '='

    94         comments

    95         e <- initExpression

    96         comments

    97         return (Just e)

    98     return $ VarDeclaration isVar False (ids, t) init

    99 

   100 

   101 constsDecl = do

   102     vs <- many1 (try (aConstDecl >>= \i -> semi pas >> return i) >>= \i -> comments >> return i)

   103     comments

   104     return vs

   105     where

   106     aConstDecl = do

   107         comments

   108         i <- iD

   109         t <- optionMaybe $ do

   110             char ':'

   111             comments

   112             t <- typeDecl

   113             comments

   114             return t

   115         char '='

   116         comments

   117         e <- initExpression

   118         comments

   119         return $ VarDeclaration False (isNothing t) ([i], fromMaybe (DeriveType e) t) (Just e)

   120 

   121 typeDecl = choice [

   122     char '^' >> typeDecl >>= return . PointerTo

   123     , try (string "shortstring") >> return (String 255)

   124     , try (string "string") >> optionMaybe (brackets pas $ integer pas) >>= return . String . fromMaybe 255

   125     , try (string "ansistring") >> optionMaybe (brackets pas $ integer pas) >>= return . String . fromMaybe 255

   126     , arrayDecl

   127     , recordDecl

   128     , setDecl

   129     , functionType

   130     , sequenceDecl >>= return . Sequence

   131     , try iD >>= return . SimpleType

   132     , rangeDecl >>= return . RangeType

   133     ] <?> "type declaration"

   134     where

   135     arrayDecl = do

   136         try $ do

   137             optional $ (try $ string "packed") >> comments

   138             string "array"

   139         comments

   140         r <- option [] $ do

   141             char '['

   142             r <- commaSep pas rangeDecl

   143             char ']'

   144             comments

   145             return r

   146         string "of"

   147         comments

   148         t <- typeDecl

   149         if null r then

   150             return $ ArrayDecl Nothing t

   151             else

   152             return $ foldr (\a b -> ArrayDecl (Just a) b) (ArrayDecl (Just $ head r) t) (tail r) 

   153     recordDecl = do

   154         try $ do

   155             optional $ (try $ string "packed") >> comments

   156             string "record"

   157         comments

   158         vs <- varsDecl True

   159         union <- optionMaybe $ do

   160             string "case"

   161             comments

   162             iD

   163             comments

   164             string "of"

   165             comments

   166             many unionCase

   167         string "end"

   168         return $ RecordType vs union

   169     setDecl = do

   170         try $ string "set" >> space

   171         comments

   172         string "of"

   173         comments

   174         liftM Set typeDecl

   175     unionCase = do

   176         try $ commaSep pas $ (iD >> return ()) <|> (integer pas >> return ())

   177         char ':'

   178         comments

   179         u <- parens pas $ varsDecl True

   180         char ';'

   181         comments

   182         return u

   183     sequenceDecl = (parens pas) $ (commaSep pas) (iD >>= \i -> optional (spaces >> char '=' >> spaces >> integer pas) >> return i)

   184     functionType = do

   185         fp <- try (string "function") <|> try (string "procedure")

   186         comments

   187         vs <- option [] $ parens pas $ varsDecl False

   188         comments

   189         ret <- if (fp == "function") then do

   190             char ':'

   191             comments

   192             ret <- typeDecl

   193             comments

   194             return ret

   195             else

   196             return VoidType

   197         optional $ try $ char ';' >> comments >> string "cdecl"

   198         comments

   199         return $ FunctionType ret vs

   200 

   201 typesDecl = many (aTypeDecl >>= \t -> comments >> return t)

   202     where

   203     aTypeDecl = do

   204         i <- try $ do

   205             i <- iD <?> "type declaration"

   206             comments

   207             char '='

   208             return i

   209         comments

   210         t <- typeDecl

   211         comments

   212         semi pas

   213         comments

   214         return $ TypeDeclaration i t

   215 

   216 rangeDecl = choice [

   217     try $ rangeft

   218     , iD >>= return . Range

   219     ] <?> "range declaration"

   220     where

   221     rangeft = do

   222     e1 <- initExpression

   223     string ".."

   224     e2 <- initExpression

   225     return $ RangeFromTo e1 e2

   226 

   227 typeVarDeclaration isImpl = (liftM concat . many . choice) [

   228     varSection,

   229     constSection,

   230     typeSection,

   231     funcDecl,

   232     operatorDecl

   233     ]

   234     where

   235     varSection = do

   236         try $ string "var"

   237         comments

   238         v <- varsDecl1 True <?> "variable declaration"

   239         comments

   240         return v

   241 

   242     constSection = do

   243         try $ string "const"

   244         comments

   245         c <- constsDecl <?> "const declaration"

   246         comments

   247         return c

   248 

   249     typeSection = do

   250         try $ string "type"

   251         comments

   252         t <- typesDecl <?> "type declaration"

   253         comments

   254         return t

   255 

   256     operatorDecl = do

   257         try $ string "operator"

   258         comments

   259         i <- manyTill anyChar space

   260         comments

   261         vs <- parens pas $ varsDecl False

   262         comments

   263         rid <- iD

   264         comments

   265         char ':'

   266         comments

   267         ret <- typeDecl

   268         comments

   269         return ret

   270         char ';'

   271         comments

   272         forward <- liftM isJust $ optionMaybe (try (string "forward;") >> comments)

   273         inline <- liftM (any (== "inline;")) $ many functionDecorator

   274         b <- if isImpl && (not forward) then

   275                 liftM Just functionBody

   276                 else

   277                 return Nothing

   278         return $ [OperatorDeclaration i rid inline ret vs b]

   279 

   280 

   281     funcDecl = do

   282         fp <- try (string "function") <|> try (string "procedure")

   283         comments

   284         i <- iD

   285         vs <- option [] $ parens pas $ varsDecl False

   286         comments

   287         ret <- if (fp == "function") then do

   288             char ':'

   289             comments

   290             ret <- typeDecl

   291             comments

   292             return ret

   293             else

   294             return VoidType

   295         char ';'

   296         comments

   297         forward <- liftM isJust $ optionMaybe (try (string "forward;") >> comments)

   298         inline <- liftM (any (== "inline;")) $ many functionDecorator

   299         b <- if isImpl && (not forward) then

   300                 liftM Just functionBody

   301                 else

   302                 return Nothing

   303         return $ [FunctionDeclaration i inline ret vs b]

   304 

   305     functionDecorator = do

   306         d <- choice [

   307             try $ string "inline;"

   308             , try $ caseInsensitiveString "cdecl;"

   309             , try $ string "overload;"

   310             , try $ string "export;"

   311             , try $ string "varargs;"

   312             , try (string "external") >> comments >> iD >> optional (string "name" >> comments >> stringLiteral pas)>> string ";"

   313             ]

   314         comments

   315         return d

   316 

   317 

   318 program = do

   319     string "program"

   320     comments

   321     name <- iD

   322     (char ';')

   323     comments

   324     comments

   325     u <- uses

   326     comments

   327     tv <- typeVarDeclaration True

   328     comments

   329     p <- phrase

   330     comments

   331     char '.'

   332     comments

   333     return $ Program name (Implementation u (TypesAndVars tv)) p

   334 

   335 interface = do

   336     string "interface"

   337     comments

   338     u <- uses

   339     comments

   340     tv <- typeVarDeclaration False

   341     comments

   342     return $ Interface u (TypesAndVars tv)

   343 

   344 implementation = do

   345     string "implementation"

   346     comments

   347     u <- uses

   348     comments

   349     tv <- typeVarDeclaration True

   350     string "end."

   351     comments

   352     return $ Implementation u (TypesAndVars tv)

   353 

   354 expression = do

   355     buildExpressionParser table term <?> "expression"

   356     where

   357     term = comments >> choice [

   358         builtInFunction expression >>= \(n, e) -> return $ BuiltInFunCall e (SimpleReference (Identifier n BTUnknown))

   359         , try (parens pas $ expression >>= \e -> notFollowedBy (comments >> char '.') >> return e)

   360         , brackets pas (commaSep pas iD) >>= return . SetExpression

   361         , try $ integer pas >>= \i -> notFollowedBy (char '.') >> (return . NumberLiteral . show) i

   362         , float pas >>= return . FloatLiteral . show

   363         , try $ integer pas >>= return . NumberLiteral . show

   364         , try (string "_S" >> stringLiteral pas) >>= return . StringLiteral

   365         , try (string "_P" >> stringLiteral pas) >>= return . PCharLiteral

   366         , stringLiteral pas >>= return . strOrChar

   367         , try (string "#$") >> many hexDigit >>= \c -> comments >> return (HexCharCode c)

   368         , char '#' >> many digit >>= \c -> comments >> return (CharCode c)

   369         , char '$' >> many hexDigit >>=  \h -> comments >> return (HexNumber h)

   370         --, char '-' >> expression >>= return . PrefixOp "-"

   371         , char '-' >> reference >>= return . PrefixOp "-" . Reference

   372         , (try $ string "not" >> notFollowedBy comments) >> unexpected "'not'"

   373         , try $ string "nil" >> return Null

   374         , reference >>= return . Reference

   375         ] <?> "simple expression"

   376 

   377     table = [

   378           [  Prefix (try (string "not") >> return (PrefixOp "not"))

   379            , Prefix (try (char '-') >> return (PrefixOp "-"))]

   380         ,

   381           [  Infix (char '*' >> return (BinOp "*")) AssocLeft

   382            , Infix (char '/' >> return (BinOp "/")) AssocLeft

   383            , Infix (try (string "div") >> return (BinOp "div")) AssocLeft

   384            , Infix (try (string "mod") >> return (BinOp "mod")) AssocLeft

   385            , Infix (try (string "in") >> return (BinOp "in")) AssocNone

   386            , Infix (try $ string "and" >> return (BinOp "and")) AssocLeft

   387            , Infix (try $ string "shl" >> return (BinOp "shl")) AssocLeft

   388            , Infix (try $ string "shr" >> return (BinOp "shr")) AssocLeft

   389           ]

   390         , [  Infix (char '+' >> return (BinOp "+")) AssocLeft

   391            , Infix (char '-' >> return (BinOp "-")) AssocLeft

   392            , Infix (try $ string "or" >> return (BinOp "or")) AssocLeft

   393            , Infix (try $ string "xor" >> return (BinOp "xor")) AssocLeft

   394           ]

   395         , [  Infix (try (string "<>") >> return (BinOp "<>")) AssocNone

   396            , Infix (try (string "<=") >> return (BinOp "<=")) AssocNone

   397            , Infix (try (string ">=") >> return (BinOp ">=")) AssocNone

   398            , Infix (char '<' >> return (BinOp "<")) AssocNone

   399            , Infix (char '>' >> return (BinOp ">")) AssocNone

   400           ]

   401         {-, [  Infix (try $ string "shl" >> return (BinOp "shl")) AssocNone

   402              , Infix (try $ string "shr" >> return (BinOp "shr")) AssocNone

   403           ]

   404         , [ 

   405              Infix (try $ string "or" >> return (BinOp "or")) AssocLeft

   406            , Infix (try $ string "xor" >> return (BinOp "xor")) AssocLeft

   407           ]-}

   408         , [

   409              Infix (char '=' >> return (BinOp "=")) AssocNone

   410           ]

   411         ]

   412     strOrChar [a] = CharCode . show . ord $ a

   413     strOrChar a = StringLiteral a

   414 

   415 phrasesBlock = do

   416     try $ string "begin"

   417     comments

   418     p <- manyTill phrase (try $ string "end" >> notFollowedBy alphaNum)

   419     comments

   420     return $ Phrases p

   421 

   422 phrase = do

   423     o <- choice [

   424         phrasesBlock

   425         , ifBlock

   426         , whileCycle

   427         , repeatCycle

   428         , switchCase

   429         , withBlock

   430         , forCycle

   431         , (try $ reference >>= \r -> string ":=" >> return r) >>= \r -> comments >> expression >>= return . Assignment r

   432         , builtInFunction expression >>= \(n, e) -> return $ BuiltInFunctionCall e (SimpleReference (Identifier n BTUnknown))

   433         , procCall

   434         , char ';' >> comments >> return NOP

   435         ]

   436     optional $ char ';'

   437     comments

   438     return o

   439 

   440 ifBlock = do

   441     try $ string "if" >> notFollowedBy (alphaNum <|> char '_')

   442     comments

   443     e <- expression

   444     comments

   445     string "then"

   446     comments

   447     o1 <- phrase

   448     comments

   449     o2 <- optionMaybe $ do

   450         try $ string "else" >> space

   451         comments

   452         o <- option NOP phrase

   453         comments

   454         return o

   455     return $ IfThenElse e o1 o2

   456 

   457 whileCycle = do

   458     try $ string "while"

   459     comments

   460     e <- expression

   461     comments

   462     string "do"

   463     comments

   464     o <- phrase

   465     return $ WhileCycle e o

   466 

   467 withBlock = do

   468     try $ string "with" >> space

   469     comments

   470     rs <- (commaSep1 pas) reference

   471     comments

   472     string "do"

   473     comments

   474     o <- phrase

   475     return $ foldr WithBlock o rs

   476 

   477 repeatCycle = do

   478     try $ string "repeat" >> space

   479     comments

   480     o <- many phrase

   481     string "until"

   482     comments

   483     e <- expression

   484     comments

   485     return $ RepeatCycle e o

   486 

   487 forCycle = do

   488     try $ string "for" >> space

   489     comments

   490     i <- iD

   491     comments

   492     string ":="

   493     comments

   494     e1 <- expression

   495     comments

   496     up <- liftM (== Just "to") $

   497             optionMaybe $ choice [

   498                 try $ string "to"

   499                 , try $ string "downto"

   500                 ]   

   501     --choice [string "to", string "downto"]

   502     comments

   503     e2 <- expression

   504     comments

   505     string "do"

   506     comments

   507     p <- phrase

   508     comments

   509     return $ ForCycle i e1 e2 p up

   510 

   511 switchCase = do

   512     try $ string "case"

   513     comments

   514     e <- expression

   515     comments

   516     string "of"

   517     comments

   518     cs <- many1 aCase

   519     o2 <- optionMaybe $ do

   520         try $ string "else" >> notFollowedBy alphaNum

   521         comments

   522         o <- many phrase

   523         comments

   524         return o

   525     string "end"

   526     comments

   527     return $ SwitchCase e cs o2

   528     where

   529     aCase = do

   530         e <- (commaSep pas) $ (liftM InitRange rangeDecl <|> initExpression)

   531         comments

   532         char ':'

   533         comments

   534         p <- phrase

   535         comments

   536         return (e, p)

   537 

   538 procCall = do

   539     r <- reference

   540     p <- option [] $ (parens pas) parameters

   541     return $ ProcCall r p

   542 

   543 parameters = (commaSep pas) expression <?> "parameters"

   544 

   545 functionBody = do

   546     tv <- typeVarDeclaration True

   547     comments

   548     p <- phrasesBlock

   549     char ';'

   550     comments

   551     return (TypesAndVars tv, p)

   552 

   553 uses = liftM Uses (option [] u)

   554     where

   555         u = do

   556             string "uses"

   557             comments

   558             u <- (iD >>= \i -> comments >> return i) `sepBy1` (char ',' >> comments)

   559             char ';'

   560             comments

   561             return u

   562 

   563 initExpression = buildExpressionParser table term <?> "initialization expression"

   564     where

   565     term = comments >> choice [

   566         liftM (uncurry BuiltInFunction) $ builtInFunction initExpression 

   567         , try $ brackets pas (commaSep pas $ initExpression) >>= return . InitSet

   568         , try $ parens pas (commaSep pas $ initExpression) >>= \ia -> when (null $ tail ia) mzero >> return (InitArray ia)

   569         , try $ parens pas (sepEndBy recField (char ';' >> comments)) >>= return . InitRecord

   570         , parens pas initExpression

   571         , try $ integer pas >>= \i -> notFollowedBy (char '.') >> (return . InitNumber . show) i

   572         , try $ float pas >>= return . InitFloat . show

   573         , try $ integer pas >>= return . InitNumber . show

   574         , stringLiteral pas >>= return . InitString

   575         , char '#' >> many digit >>= \c -> comments >> return (InitChar c)

   576         , char '$' >> many hexDigit >>= \h -> comments >> return (InitHexNumber h)

   577         , char '@' >> initExpression >>= \c -> comments >> return (InitAddress c)

   578         , try $ string "nil" >> return InitNull

   579         , itypeCast

   580         , iD >>= return . InitReference

   581         ]

   582 

   583     recField = do

   584         i <- iD

   585         spaces

   586         char ':'

   587         spaces

   588         e <- initExpression

   589         spaces

   590         return (i ,e)

   591 

   592     table = [

   593           [

   594              Prefix (char '-' >> return (InitPrefixOp "-"))

   595             ,Prefix (try (string "not") >> return (InitPrefixOp "not"))

   596           ]

   597         , [  Infix (char '*' >> return (InitBinOp "*")) AssocLeft

   598            , Infix (char '/' >> return (InitBinOp "/")) AssocLeft

   599            , Infix (try (string "div") >> return (InitBinOp "div")) AssocLeft

   600            , Infix (try (string "mod") >> return (InitBinOp "mod")) AssocLeft

   601            , Infix (try $ string "and" >> return (InitBinOp "and")) AssocLeft

   602            , Infix (try $ string "shl" >> return (InitBinOp "shl")) AssocNone

   603            , Infix (try $ string "shr" >> return (InitBinOp "shr")) AssocNone

   604           ]

   605         , [  Infix (char '+' >> return (InitBinOp "+")) AssocLeft

   606            , Infix (char '-' >> return (InitBinOp "-")) AssocLeft

   607            , Infix (try $ string "or" >> return (InitBinOp "or")) AssocLeft

   608            , Infix (try $ string "xor" >> return (InitBinOp "xor")) AssocLeft

   609           ]

   610         , [  Infix (try (string "<>") >> return (InitBinOp "<>")) AssocNone

   611            , Infix (try (string "<=") >> return (InitBinOp "<=")) AssocNone

   612            , Infix (try (string ">=") >> return (InitBinOp ">=")) AssocNone

   613            , Infix (char '<' >> return (InitBinOp "<")) AssocNone

   614            , Infix (char '>' >> return (InitBinOp ">")) AssocNone

   615            , Infix (char '=' >> return (InitBinOp "=")) AssocNone

   616           ]

   617         {--, [  Infix (try $ string "and" >> return (InitBinOp "and")) AssocLeft

   618            , Infix (try $ string "or" >> return (InitBinOp "or")) AssocLeft

   619            , Infix (try $ string "xor" >> return (InitBinOp "xor")) AssocLeft

   620           ]

   621         , [  Infix (try $ string "shl" >> return (InitBinOp "shl")) AssocNone

   622            , Infix (try $ string "shr" >> return (InitBinOp "shr")) AssocNone

   623           ]--}

   624         --, [Prefix (try (string "not") >> return (InitPrefixOp "not"))]

   625         ]

   626 

   627     itypeCast = do

   628         t <- choice $ map (\s -> try $ caseInsensitiveString s >>= \i -> notFollowedBy alphaNum >> return i) knownTypes

   629         i <- parens pas initExpression

   630         comments

   631         return $ InitTypeCast (Identifier t BTUnknown) i

   632 

   633 builtInFunction e = do

   634     name <- choice $ map (\s -> try $ caseInsensitiveString s >>= \i -> notFollowedBy alphaNum >> return i) builtin

   635     spaces

   636     exprs <- option [] $ parens pas $ option [] $ commaSep1 pas $ e

   637     spaces

   638     return (name, exprs)

   639 

   640 systemUnit = do

   641     string "system;"

   642     comments

   643     string "type"

   644     comments

   645     t <- typesDecl

   646     string "var"

   647     v <- varsDecl True

   648     return $ System (t ++ v)

   649 

   650 redoUnit = do

   651     string "redo;"

   652     comments

   653     string "type"

   654     comments

   655     t <- typesDecl

   656     string "var"

   657     v <- varsDecl True

   658     return $ Redo (t ++ v)

   659