12 import Data.Maybe

    12 import Data.Maybe

    13 import Data.Char

    13 import Data.Char

    14 

    14 

    15 import PascalBasics

    15 import PascalBasics

    16 import PascalUnitSyntaxTree

    16 import PascalUnitSyntaxTree

    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]

    25 

    25 

    26 iD = do

    26 iD = do

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

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

    28     comments

    28     comments

    29     return i

    29     return i

    31 unit = do

    31 unit = do

    32     string "unit" >> comments

    32     string "unit" >> comments

    33     name <- iD

    33     name <- iD

    34     semi pas

    34     semi pas

    35     comments

    35     comments

    36     int <- interface

    36     int <- interface

    37     impl <- implementation

    37     impl <- implementation

    38     comments

    38     comments

    39     return $ Unit name int impl Nothing Nothing

    39     return $ Unit name int impl Nothing Nothing

    40 

    40 

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

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

    43     where

    43     where

    44     term = comments >> choice [

    44     term = comments >> choice [

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

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

    46         , try $ typeCast >>= postfixes

    46         , try $ typeCast >>= postfixes

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

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

    48         , liftM SimpleReference iD >>= postfixes 

    48         , liftM SimpleReference iD >>= postfixes 

    49         ] <?> "simple reference"

    49         ] <?> "simple reference"

    50 

    50 

    52         ]

    52         ]

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

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

    55     postfix = choice [

    55     postfix = choice [

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

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

    57           , char '^' >> return Dereference

    57           , char '^' >> return Dereference

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

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

    62     typeCast = do

    62     typeCast = do

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

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

    64         e <- parens pas expression

    64         e <- parens pas expression

    65         comments

    65         comments

    66         return $ TypeCast (Identifier t BTUnknown) e

    66         return $ TypeCast (Identifier t BTUnknown) e

    70 varsDecl = varsParser sepEndBy

    69 varsDecl = varsParser sepEndBy

    71 varsParser m endsWithSemi = do

    70 varsParser m endsWithSemi = do

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

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

    73     return vs

    72     return vs

    74 

    73 

   113         char '='

   112         char '='

   114         comments

   113         comments

   115         e <- initExpression

   114         e <- initExpression

   116         comments

   115         comments

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

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

   119 typeDecl = choice [

   118 typeDecl = choice [

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

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

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

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

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

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

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

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

   209         comments

   208         comments

   210         semi pas

   209         semi pas

   211         comments

   210         comments

   212         return $ TypeDeclaration i t

   211         return $ TypeDeclaration i t

   213 

   212 

   215 rangeDecl = choice [

   213 rangeDecl = choice [

   216     try $ rangeft

   214     try $ rangeft

   217     , iD >>= return . Range

   215     , iD >>= return . Range

   218     ] <?> "range declaration"

   216     ] <?> "range declaration"

   219     where

   217     where

   220     rangeft = do

   218     rangeft = do

   221     e1 <- initExpression

   219     e1 <- initExpression

   222     string ".."

   220     string ".."

   223     e2 <- initExpression

   221     e2 <- initExpression

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

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

   227     varSection,

   225     varSection,

   228     constSection,

   226     constSection,

   229     typeSection,

   227     typeSection,

   230     funcDecl,

   228     funcDecl,

   249         try $ string "type"

   247         try $ string "type"

   250         comments

   248         comments

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

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

   252         comments

   250         comments

   253         return t

   251         return t

   255     operatorDecl = do

   253     operatorDecl = do

   256         try $ string "operator"

   254         try $ string "operator"

   257         comments

   255         comments

   258         i <- manyTill anyChar space

   256         i <- manyTill anyChar space

   259         comments

   257         comments

   274                 liftM Just functionBody

   272                 liftM Just functionBody

   275                 else

   273                 else

   276                 return Nothing

   274                 return Nothing

   277         return $ [OperatorDeclaration i rid ret vs b]

   275         return $ [OperatorDeclaration i rid ret vs b]

   278 

   276 

   280     funcDecl = do

   278     funcDecl = do

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

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

   282         comments

   280         comments

   283         i <- iD

   281         i <- iD

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

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

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

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

   299                 liftM Just functionBody

   297                 liftM Just functionBody

   300                 else

   298                 else

   301                 return Nothing

   299                 return Nothing

   302         return $ [FunctionDeclaration i ret vs b]

   300         return $ [FunctionDeclaration i ret vs b]

   304     functionDecorator = choice [

   302     functionDecorator = choice [

   305         try $ string "inline;"

   303         try $ string "inline;"

   306         , try $ caseInsensitiveString "cdecl;"

   304         , try $ caseInsensitiveString "cdecl;"

   307         , try $ string "overload;"

   305         , try $ string "overload;"

   308         , try $ string "export;"

   306         , try $ string "export;"

   309         , try $ string "varargs;"

   307         , try $ string "varargs;"

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

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

   311         ] >> comments

   309         ] >> comments

   314 program = do

   312 program = do

   315     string "program"

   313     string "program"

   316     comments

   314     comments

   317     name <- iD

   315     name <- iD

   318     (char ';')

   316     (char ';')

   394         , [

   392         , [

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

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

   396           ]

   394           ]

   397         ]

   395         ]

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

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

   401 phrasesBlock = do

   399 phrasesBlock = do

   402     try $ string "begin"

   400     try $ string "begin"

   403     comments

   401     comments

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

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

   405     comments

   403     comments

   406     return $ Phrases p

   404     return $ Phrases p

   408 phrase = do

   406 phrase = do

   409     o <- choice [

   407     o <- choice [

   410         phrasesBlock

   408         phrasesBlock

   411         , ifBlock

   409         , ifBlock

   412         , whileCycle

   410         , whileCycle

   457     comments

   455     comments

   458     string "do"

   456     string "do"

   459     comments

   457     comments

   460     o <- phrase

   458     o <- phrase

   461     return $ foldr WithBlock o rs

   459     return $ foldr WithBlock o rs

   463 repeatCycle = do

   461 repeatCycle = do

   464     try $ string "repeat" >> space

   462     try $ string "repeat" >> space

   465     comments

   463     comments

   466     o <- many phrase

   464     o <- many phrase

   467     string "until"

   465     string "until"

   486     string "do"

   484     string "do"

   487     comments

   485     comments

   488     p <- phrase

   486     p <- phrase

   489     comments

   487     comments

   490     return $ ForCycle i e1 e2 p

   488     return $ ForCycle i e1 e2 p

   492 switchCase = do

   490 switchCase = do

   493     try $ string "case"

   491     try $ string "case"

   494     comments

   492     comments

   495     e <- expression

   493     e <- expression

   496     comments

   494     comments

   513         char ':'

   511         char ':'

   514         comments

   512         comments

   515         p <- phrase

   513         p <- phrase

   516         comments

   514         comments

   517         return (e, p)

   515         return (e, p)

   519 procCall = do

   517 procCall = do

   520     r <- reference

   518     r <- reference

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

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

   522     return $ ProcCall r p

   520     return $ ProcCall r p

   523 

   521 

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

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

   526 functionBody = do

   524 functionBody = do

   527     tv <- typeVarDeclaration True

   525     tv <- typeVarDeclaration True

   528     comments

   526     comments

   529     p <- phrasesBlock

   527     p <- phrasesBlock

   530     char ';'

   528     char ';'

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

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

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

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

   559         , itypeCast

   557         , itypeCast

   560         , iD >>= return . InitReference

   558         , iD >>= return . InitReference

   561         ]

   559         ]

   563     recField = do

   561     recField = do

   564         i <- iD

   562         i <- iD

   565         spaces

   563         spaces

   566         char ':'

   564         char ':'

   567         spaces

   565         spaces

   568         e <- initExpression

   566         e <- initExpression

   569         spaces

   567         spaces

   570         return (i ,e)

   568         return (i ,e)

   571 

   569 

   573           [

   571           [

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

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

   575           ]

   573           ]

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

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

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

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

   601     itypeCast = do

   599     itypeCast = do

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

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

   603         i <- parens pas initExpression

   601         i <- parens pas initExpression

   604         comments

   602         comments

   605         return $ InitTypeCast (Identifier t BTUnknown) i

   603         return $ InitTypeCast (Identifier t BTUnknown) i

   607 builtInFunction e = do

   605 builtInFunction e = do

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

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

   609     spaces

   607     spaces

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

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

   611     spaces

   609     spaces