Mercurial Mercurial > sheepy-clone / 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/pas2c/PascalParser.hs
changeset 10113 b26c2772e754
parent 10111 459bc720cea1
child 10120 b7f632c12784
equal deleted inserted replaced
10111:459bc720cea1 10113:b26c2772e754 
     1 module PascalParser where
 
     1 module PascalParser (
 
       
     2     pascalUnit
 
       
     3     )
 
       
     4     where
 
     2 
     5 
     3 import Text.Parsec
 
     6 import Text.Parsec
 
     4 import Text.Parsec.Char
 
       
     5 import Text.Parsec.Token
 
     7 import Text.Parsec.Token
 
     6 import Text.Parsec.Language
 
       
     7 import Text.Parsec.Expr
 
     8 import Text.Parsec.Expr
 
     8 import Text.Parsec.Prim
 
       
     9 import Text.Parsec.Combinator
 
       
    10 import Text.Parsec.String
 
       
    11 import Control.Monad
 
     9 import Control.Monad
 
    12 import Data.Maybe
 
    10 import Data.Maybe
 
    13 import Data.Char
 
    11 import Data.Char
 
    14 
    12 
    15 import PascalBasics
 
    13 import PascalBasics
 
    16 import PascalUnitSyntaxTree
 
    14 import PascalUnitSyntaxTree
 
    17 
    15 
       
    16 knownTypes :: [String]
 
    18 knownTypes = ["shortstring", "ansistring", "char", "byte"]
 
    17 knownTypes = ["shortstring", "ansistring", "char", "byte"]
 
    19 
    18 
       
    19 pascalUnit :: Parsec String u PascalUnit
 
    20 pascalUnit = do
 
    20 pascalUnit = do
 
    21     comments
 
    21     comments
 
    22     u <- choice [program, unit, systemUnit, redoUnit]
 
    22     u <- choice [program, unit, systemUnit, redoUnit]
 
    23     comments
 
    23     comments
 
    24     return u
 
    24     return u
 
    25 
    25 
       
    26 iD :: Parsec String u Identifier
 
    26 iD = do
 
    27 iD = do
 
    27     i <- identifier pas
 
    28     i <- identifier pas
 
    28     comments
 
    29     comments
 
    29     when (i == "not") $ unexpected "'not' used as an identifier"
 
    30     when (i == "not") $ unexpected "'not' used as an identifier"
 
    30     return $ Identifier i BTUnknown
 
    31     return $ Identifier i BTUnknown
 
    31 
    32 
       
    33 unit :: Parsec String u PascalUnit
 
    32 unit = do
 
    34 unit = do
 
    33     string "unit" >> comments
 
    35     string' "unit" >> comments
 
    34     name <- iD
 
    36     name <- iD
 
    35     semi pas
 
    37     void $ semi pas
 
    36     comments
 
    38     comments
 
    37     int <- interface
 
    39     int <- interface
 
    38     impl <- implementation
 
    40     impl <- implementation
 
    39     comments
 
    41     comments
 
    40     return $ Unit name int impl Nothing Nothing
 
    42     return $ Unit name int impl Nothing Nothing
 
    41 
    43 
    42 
    44 
       
    45 reference :: Parsec String u Reference
 
    43 reference = buildExpressionParser table term <?> "reference"
 
    46 reference = buildExpressionParser table term <?> "reference"
 
    44     where
 
    47     where
 
    45     term = comments >> choice [
 
    48     term = comments >> choice [
 
    46         parens pas (liftM RefExpression expression >>= postfixes) >>= postfixes
 
    49         parens pas (liftM RefExpression expression >>= postfixes) >>= postfixes
 
    47         , try $ typeCast >>= postfixes
 
    50         , try $ typeCast >>= postfixes
 
    48         , char '@' >> liftM Address reference >>= postfixes
 
    51         , char' '@' >> liftM Address reference >>= postfixes
 
    49         , liftM SimpleReference iD >>= postfixes
 
    52         , liftM SimpleReference iD >>= postfixes
 
    50         ] <?> "simple reference"
 
    53         ] <?> "simple reference"
 
    51 
    54 
    52     table = [
 
    55     table = [
 
    53         ]
 
    56         ]
 
    54 
    57 
    55     postfixes r = many postfix >>= return . foldl (flip ($)) r
 
    58     postfixes r = many postfix >>= return . foldl (flip ($)) r
 
    56     postfix = choice [
 
    59     postfix = choice [
 
    57             parens pas (option [] parameters) >>= return . FunCall
 
    60             parens pas (option [] parameters) >>= return . FunCall
 
    58           , char '^' >> return Dereference
 
    61           , char' '^' >> return Dereference
 
    59           , (brackets pas) (commaSep1 pas $ expression) >>= return . ArrayElement
 
    62           , (brackets pas) (commaSep1 pas $ expression) >>= return . ArrayElement
 
    60           , (char '.' >> notFollowedBy (char '.')) >> liftM (flip RecordField) reference
 
    63           , (char' '.' >> notFollowedBy (char' '.')) >> liftM (flip RecordField) reference
 
    61         ]
 
    64         ]
 
    62 
    65 
    63     typeCast = do
 
    66     typeCast = do
 
    64         t <- choice $ map (\s -> try $ caseInsensitiveString s >>= \i -> notFollowedBy alphaNum >> return i) knownTypes
 
    67         t <- choice $ map (\s -> try $ caseInsensitiveString s >>= \i -> notFollowedBy alphaNum >> return i) knownTypes
 
    65         e <- parens pas expression
 
    68         e <- parens pas expression
 
    66         comments
 
    69         comments
 
    67         return $ TypeCast (Identifier t BTUnknown) e
 
    70         return $ TypeCast (Identifier t BTUnknown) e
 
    68 
    71 
       
    72 varsDecl1, varsDecl :: Bool -> Parsec String u [TypeVarDeclaration]
 
    69 varsDecl1 = varsParser sepEndBy1
 
    73 varsDecl1 = varsParser sepEndBy1
 
    70 varsDecl = varsParser sepEndBy
 
    74 varsDecl = varsParser sepEndBy
 
       
    75 
       
    76 varsParser ::
 
       
    77     (Parsec String u TypeVarDeclaration
 
       
    78         -> Parsec String u String
 
       
    79         -> Parsec
 
       
    80             String u [TypeVarDeclaration])
 
       
    81     -> Bool
 
       
    82     -> Parsec
 
       
    83             String u [TypeVarDeclaration]
 
    71 varsParser m endsWithSemi = do
 
    84 varsParser m endsWithSemi = do
 
    72     vs <- m (aVarDecl endsWithSemi) (semi pas)
 
    85     vs <- m (aVarDecl endsWithSemi) (semi pas)
 
    73     return vs
 
    86     return vs
 
    74 
    87 
       
    88 aVarDecl :: Bool -> Parsec String u TypeVarDeclaration
 
    75 aVarDecl endsWithSemi = do
 
    89 aVarDecl endsWithSemi = do
 
    76     isVar <- liftM (== Just "var") $
 
    90     isVar <- liftM (== Just "var") $
 
    77         if not endsWithSemi then
 
    91         if not endsWithSemi then
 
    78             optionMaybe $ choice [
 
    92             optionMaybe $ choice [
 
    79                 try $ string "var"
 
    93                 try $ string "var"
 
    83             else
 
    97             else
 
    84                 return Nothing
 
    98                 return Nothing
 
    85     comments
 
    99     comments
 
    86     ids <- do
 
   100     ids <- do
 
    87         i <- (commaSep1 pas) $ (try iD <?> "variable declaration")
 
   101         i <- (commaSep1 pas) $ (try iD <?> "variable declaration")
 
    88         char ':'
 
   102         char' ':'
 
    89         return i
 
   103         return i
 
    90     comments
 
   104     comments
 
    91     t <- typeDecl <?> "variable type declaration"
 
   105     t <- typeDecl <?> "variable type declaration"
 
    92     comments
 
   106     comments
 
    93     init <- option Nothing $ do
 
   107     initialization <- option Nothing $ do
 
    94         char '='
 
   108         char' '='
 
    95         comments
 
   109         comments
 
    96         e <- initExpression
 
   110         e <- initExpression
 
    97         comments
 
   111         comments
 
    98         return (Just e)
 
   112         return (Just e)
 
    99     return $ VarDeclaration isVar False (ids, t) init
 
   113     return $ VarDeclaration isVar False (ids, t) initialization
 
   100 
   114 
   101 
   115 constsDecl :: Parsec String u [TypeVarDeclaration]
 
   102 constsDecl = do
 
   116 constsDecl = do
 
   103     vs <- many1 (try (aConstDecl >>= \i -> semi pas >> return i) >>= \i -> comments >> return i)
 
   117     vs <- many1 (try (aConstDecl >>= \i -> semi pas >> return i) >>= \i -> comments >> return i)
 
   104     comments
 
   118     comments
 
   105     return vs
 
   119     return vs
 
   106     where
 
   120     where
 
   107     aConstDecl = do
 
   121     aConstDecl = do
 
   108         comments
 
   122         comments
 
   109         i <- iD
 
   123         i <- iD
 
   110         t <- optionMaybe $ do
 
   124         t <- optionMaybe $ do
 
   111             char ':'
 
   125             char' ':'
 
   112             comments
 
   126             comments
 
   113             t <- typeDecl
 
   127             t <- typeDecl
 
   114             comments
 
   128             comments
 
   115             return t
 
   129             return t
 
   116         char '='
 
   130         char' '='
 
   117         comments
 
   131         comments
 
   118         e <- initExpression
 
   132         e <- initExpression
 
   119         comments
 
   133         comments
 
   120         return $ VarDeclaration False (isNothing t) ([i], fromMaybe (DeriveType e) t) (Just e)
 
   134         return $ VarDeclaration False (isNothing t) ([i], fromMaybe (DeriveType e) t) (Just e)
 
   121 
   135 
       
   136 typeDecl :: Parsec String u TypeDecl
 
   122 typeDecl = choice [
 
   137 typeDecl = choice [
 
   123     char '^' >> typeDecl >>= return . PointerTo
 
   138     char' '^' >> typeDecl >>= return . PointerTo
 
   124     , try (string "shortstring") >> return String
 
   139     , try (string' "shortstring") >> return String
 
   125     , try (string "string") >> optionMaybe (brackets pas $ integer pas) >> return String
 
   140     , try (string' "string") >> optionMaybe (brackets pas $ integer pas) >> return String
 
   126     , try (string "ansistring") >> optionMaybe (brackets pas $ integer pas) >> return String
 
   141     , try (string' "ansistring") >> optionMaybe (brackets pas $ integer pas) >> return String
 
   127     , arrayDecl
 
   142     , arrayDecl
 
   128     , recordDecl
 
   143     , recordDecl
 
   129     , setDecl
 
   144     , setDecl
 
   130     , functionType
 
   145     , functionType
 
   131     , sequenceDecl >>= return . Sequence
 
   146     , sequenceDecl >>= return . Sequence
 
   133     , rangeDecl >>= return . RangeType
 
   148     , rangeDecl >>= return . RangeType
 
   134     ] <?> "type declaration"
 
   149     ] <?> "type declaration"
 
   135     where
 
   150     where
 
   136     arrayDecl = do
 
   151     arrayDecl = do
 
   137         try $ do
 
   152         try $ do
 
   138             optional $ (try $ string "packed") >> comments
 
   153             optional $ (try $ string' "packed") >> comments
 
   139             string "array"
 
   154             string' "array"
 
   140         comments
 
   155         comments
 
   141         r <- option [] $ do
 
   156         r <- option [] $ do
 
   142             char '['
 
   157             char' '['
 
   143             r <- commaSep pas rangeDecl
 
   158             r <- commaSep pas rangeDecl
 
   144             char ']'
 
   159             char' ']'
 
   145             comments
 
   160             comments
 
   146             return r
 
   161             return r
 
   147         string "of"
 
   162         string' "of"
 
   148         comments
 
   163         comments
 
   149         t <- typeDecl
 
   164         t <- typeDecl
 
   150         if null r then
 
   165         if null r then
 
   151             return $ ArrayDecl Nothing t
 
   166             return $ ArrayDecl Nothing t
 
   152             else
 
   167             else
 
   153             return $ foldr (\a b -> ArrayDecl (Just a) b) (ArrayDecl (Just $ head r) t) (tail r)
 
   168             return $ foldr (\a b -> ArrayDecl (Just a) b) (ArrayDecl (Just $ head r) t) (tail r)
 
   154     recordDecl = do
 
   169     recordDecl = do
 
   155         try $ do
 
   170         try $ do
 
   156             optional $ (try $ string "packed") >> comments
 
   171             optional $ (try $ string' "packed") >> comments
 
   157             string "record"
 
   172             string' "record"
 
   158         comments
 
   173         comments
 
   159         vs <- varsDecl True
 
   174         vs <- varsDecl True
 
   160         union <- optionMaybe $ do
 
   175         union <- optionMaybe $ do
 
   161             string "case"
 
   176             string' "case"
 
   162             comments
 
   177             comments
 
   163             iD
 
   178             void $ iD
 
   164             comments
 
   179             comments
 
   165             string "of"
 
   180             string' "of"
 
   166             comments
 
   181             comments
 
   167             many unionCase
 
   182             many unionCase
 
   168         string "end"
 
   183         string' "end"
 
   169         return $ RecordType vs union
 
   184         return $ RecordType vs union
 
   170     setDecl = do
 
   185     setDecl = do
 
   171         try $ string "set" >> space
 
   186         try $ string' "set" >> void space
 
   172         comments
 
   187         comments
 
   173         string "of"
 
   188         string' "of"
 
   174         comments
 
   189         comments
 
   175         liftM Set typeDecl
 
   190         liftM Set typeDecl
 
   176     unionCase = do
 
   191     unionCase = do
 
   177         try $ commaSep pas $ (iD >> return ()) <|> (integer pas >> return ())
 
   192         void $ try $ commaSep pas $ (void $ iD) <|> (void $ integer pas)
 
   178         char ':'
 
   193         char' ':'
 
   179         comments
 
   194         comments
 
   180         u <- parens pas $ varsDecl True
 
   195         u <- parens pas $ varsDecl True
 
   181         char ';'
 
   196         char' ';'
 
   182         comments
 
   197         comments
 
   183         return u
 
   198         return u
 
   184     sequenceDecl = (parens pas) $ (commaSep pas) (iD >>= \i -> optional (spaces >> char '=' >> spaces >> integer pas) >> return i)
 
   199     sequenceDecl = (parens pas) $ (commaSep pas) (iD >>= \i -> optional (spaces >> char' '=' >> spaces >> integer pas) >> return i)
 
   185     functionType = do
 
   200     functionType = do
 
   186         fp <- try (string "function") <|> try (string "procedure")
 
   201         fp <- try (string "function") <|> try (string "procedure")
 
   187         comments
 
   202         comments
 
   188         vs <- option [] $ parens pas $ varsDecl False
 
   203         vs <- option [] $ parens pas $ varsDecl False
 
   189         comments
 
   204         comments
 
   190         ret <- if (fp == "function") then do
 
   205         ret <- if (fp == "function") then do
 
   191             char ':'
 
   206             char' ':'
 
   192             comments
 
   207             comments
 
   193             ret <- typeDecl
 
   208             ret <- typeDecl
 
   194             comments
 
   209             comments
 
   195             return ret
 
   210             return ret
 
   196             else
 
   211             else
 
   197             return VoidType
 
   212             return VoidType
 
   198         optional $ try $ char ';' >> comments >> string "cdecl"
 
   213         optional $ try $ char' ';' >> comments >> string' "cdecl"
 
   199         comments
 
   214         comments
 
   200         return $ FunctionType ret vs
 
   215         return $ FunctionType ret vs
 
   201 
   216 
       
   217 typesDecl :: Parsec String u [TypeVarDeclaration]
 
   202 typesDecl = many (aTypeDecl >>= \t -> comments >> return t)
 
   218 typesDecl = many (aTypeDecl >>= \t -> comments >> return t)
 
   203     where
 
   219     where
 
   204     aTypeDecl = do
 
   220     aTypeDecl = do
 
   205         i <- try $ do
 
   221         i <- try $ do
 
   206             i <- iD <?> "type declaration"
 
   222             i <- iD <?> "type declaration"
 
   207             comments
 
   223             comments
 
   208             char '='
 
   224             char' '='
 
   209             return i
 
   225             return i
 
   210         comments
 
   226         comments
 
   211         t <- typeDecl
 
   227         t <- typeDecl
 
   212         comments
 
   228         comments
 
   213         semi pas
 
   229         void $ semi pas
 
   214         comments
 
   230         comments
 
   215         return $ TypeDeclaration i t
 
   231         return $ TypeDeclaration i t
 
   216 
   232 
       
   233 rangeDecl :: Parsec String u Range
 
   217 rangeDecl = choice [
 
   234 rangeDecl = choice [
 
   218     try $ rangeft
 
   235     try $ rangeft
 
   219     , iD >>= return . Range
 
   236     , iD >>= return . Range
 
   220     ] <?> "range declaration"
 
   237     ] <?> "range declaration"
 
   221     where
 
   238     where
 
   222     rangeft = do
 
   239     rangeft = do
 
   223     e1 <- initExpression
 
   240     e1 <- initExpression
 
   224     string ".."
 
   241     string' ".."
 
   225     e2 <- initExpression
 
   242     e2 <- initExpression
 
   226     return $ RangeFromTo e1 e2
 
   243     return $ RangeFromTo e1 e2
 
   227 
   244 
       
   245 typeVarDeclaration :: Bool -> Parsec String u [TypeVarDeclaration]
 
   228 typeVarDeclaration isImpl = (liftM concat . many . choice) [
 
   246 typeVarDeclaration isImpl = (liftM concat . many . choice) [
 
   229     varSection,
 
   247     varSection,
 
   230     constSection,
 
   248     constSection,
 
   231     typeSection,
 
   249     typeSection,
 
   232     funcDecl,
 
   250     funcDecl,
 
   243                             ArrayDecl _ _ -> res
 
   261                             ArrayDecl _ _ -> res
 
   244                             _ -> [x]
 
   262                             _ -> [x]
 
   245                     _ -> error ("checkInit:\n" ++ (show v))) v
 
   263                     _ -> error ("checkInit:\n" ++ (show v))) v
 
   246 
   264 
   247     varSection = do
 
   265     varSection = do
 
   248         try $ string "var"
 
   266         try $ string' "var"
 
   249         comments
 
   267         comments
 
   250         v <- varsDecl1 True <?> "variable declaration"
 
   268         v <- varsDecl1 True <?> "variable declaration"
 
   251         comments
 
   269         comments
 
   252         return $ fixInit v
 
   270         return $ fixInit v
 
   253 
   271 
   254     constSection = do
 
   272     constSection = do
 
   255         try $ string "const"
 
   273         try $ string' "const"
 
   256         comments
 
   274         comments
 
   257         c <- constsDecl <?> "const declaration"
 
   275         c <- constsDecl <?> "const declaration"
 
   258         comments
 
   276         comments
 
   259         return $ fixInit c
 
   277         return $ fixInit c
 
   260 
   278 
   261     typeSection = do
 
   279     typeSection = do
 
   262         try $ string "type"
 
   280         try $ string' "type"
 
   263         comments
 
   281         comments
 
   264         t <- typesDecl <?> "type declaration"
 
   282         t <- typesDecl <?> "type declaration"
 
   265         comments
 
   283         comments
 
   266         return t
 
   284         return t
 
   267 
   285 
   268     operatorDecl = do
 
   286     operatorDecl = do
 
   269         try $ string "operator"
 
   287         try $ string' "operator"
 
   270         comments
 
   288         comments
 
   271         i <- manyTill anyChar space
 
   289         i <- manyTill anyChar space
 
   272         comments
 
   290         comments
 
   273         vs <- parens pas $ varsDecl False
 
   291         vs <- parens pas $ varsDecl False
 
   274         comments
 
   292         comments
 
   275         rid <- iD
 
   293         rid <- iD
 
   276         comments
 
   294         comments
 
   277         char ':'
 
   295         char' ':'
 
   278         comments
 
   296         comments
 
   279         ret <- typeDecl
 
   297         ret <- typeDecl
 
   280         comments
 
   298         comments
 
   281         return ret
 
   299         -- return ret
 
   282         char ';'
 
   300         -- ^^^^^^^^^^ wth was this???
 
   283         comments
 
   301         char' ';'
 
   284         forward <- liftM isJust $ optionMaybe (try (string "forward;") >> comments)
 
   302         comments
 
       
   303         forward <- liftM isJust $ optionMaybe (try (string' "forward;") >> comments)
 
   285         inline <- liftM (any (== "inline;")) $ many functionDecorator
 
   304         inline <- liftM (any (== "inline;")) $ many functionDecorator
 
   286         b <- if isImpl && (not forward) then
 
   305         b <- if isImpl && (not forward) then
 
   287                 liftM Just functionBody
 
   306                 liftM Just functionBody
 
   288                 else
 
   307                 else
 
   289                 return Nothing
 
   308                 return Nothing
 
   295         comments
 
   314         comments
 
   296         i <- iD
 
   315         i <- iD
 
   297         vs <- option [] $ parens pas $ varsDecl False
 
   316         vs <- option [] $ parens pas $ varsDecl False
 
   298         comments
 
   317         comments
 
   299         ret <- if (fp == "function") then do
 
   318         ret <- if (fp == "function") then do
 
   300             char ':'
 
   319             char' ':'
 
   301             comments
 
   320             comments
 
   302             ret <- typeDecl
 
   321             ret <- typeDecl
 
   303             comments
 
   322             comments
 
   304             return ret
 
   323             return ret
 
   305             else
 
   324             else
 
   306             return VoidType
 
   325             return VoidType
 
   307         char ';'
 
   326         char' ';'
 
   308         comments
 
   327         comments
 
   309         forward <- liftM isJust $ optionMaybe (try (string "forward;") >> comments)
 
   328         forward <- liftM isJust $ optionMaybe (try (string "forward;") >> comments)
 
   310         decorators <- many functionDecorator
 
   329         decorators <- many functionDecorator
 
   311         let inline = any (== "inline;") decorators
 
   330         let inline = any (== "inline;") decorators
 
   312             overload = any (== "overload;") decorators
 
   331             overload = any (== "overload;") decorators
 
   321             try $ string "inline;"
 
   340             try $ string "inline;"
 
   322             , try $ caseInsensitiveString "cdecl;"
 
   341             , try $ caseInsensitiveString "cdecl;"
 
   323             , try $ string "overload;"
 
   342             , try $ string "overload;"
 
   324             , try $ string "export;"
 
   343             , try $ string "export;"
 
   325             , try $ string "varargs;"
 
   344             , try $ string "varargs;"
 
   326             , try (string "external") >> comments >> iD >> optional (string "name" >> comments >> stringLiteral pas)>> string ";"
 
   345             , try (string' "external") >> comments >> iD >> optional (string' "name" >> comments >> stringLiteral pas) >> string' ";" >> return "external"
 
   327             ]
 
   346             ]
 
   328         comments
 
   347         comments
 
   329         return d
 
   348         return d
 
   330 
   349 
   331 
   350 
       
   351 program :: Parsec String u PascalUnit
 
   332 program = do
 
   352 program = do
 
   333     string "program"
 
   353     string' "program"
 
   334     comments
 
   354     comments
 
   335     name <- iD
 
   355     name <- iD
 
   336     (char ';')
 
   356     (char' ';')
 
   337     comments
 
   357     comments
 
   338     comments
 
   358     comments
 
   339     u <- uses
 
   359     u <- uses
 
   340     comments
 
   360     comments
 
   341     tv <- typeVarDeclaration True
 
   361     tv <- typeVarDeclaration True
 
   342     comments
 
   362     comments
 
   343     p <- phrase
 
   363     p <- phrase
 
   344     comments
 
   364     comments
 
   345     char '.'
 
   365     char' '.'
 
   346     comments
 
   366     comments
 
   347     return $ Program name (Implementation u (TypesAndVars tv)) p
 
   367     return $ Program name (Implementation u (TypesAndVars tv)) p
 
   348 
   368 
       
   369 interface :: Parsec String u Interface
 
   349 interface = do
 
   370 interface = do
 
   350     string "interface"
 
   371     string' "interface"
 
   351     comments
 
   372     comments
 
   352     u <- uses
 
   373     u <- uses
 
   353     comments
 
   374     comments
 
   354     tv <- typeVarDeclaration False
 
   375     tv <- typeVarDeclaration False
 
   355     comments
 
   376     comments
 
   356     return $ Interface u (TypesAndVars tv)
 
   377     return $ Interface u (TypesAndVars tv)
 
   357 
   378 
       
   379 implementation :: Parsec String u Implementation
 
   358 implementation = do
 
   380 implementation = do
 
   359     string "implementation"
 
   381     string' "implementation"
 
   360     comments
 
   382     comments
 
   361     u <- uses
 
   383     u <- uses
 
   362     comments
 
   384     comments
 
   363     tv <- typeVarDeclaration True
 
   385     tv <- typeVarDeclaration True
 
   364     string "end."
 
   386     string' "end."
 
   365     comments
 
   387     comments
 
   366     return $ Implementation u (TypesAndVars tv)
 
   388     return $ Implementation u (TypesAndVars tv)
 
   367 
   389 
       
   390 expression :: Parsec String u Expression
 
   368 expression = do
 
   391 expression = do
 
   369     buildExpressionParser table term <?> "expression"
 
   392     buildExpressionParser table term <?> "expression"
 
   370     where
 
   393     where
 
   371     term = comments >> choice [
 
   394     term = comments >> choice [
 
   372         builtInFunction expression >>= \(n, e) -> return $ BuiltInFunCall e (SimpleReference (Identifier n BTUnknown))
 
   395         builtInFunction expression >>= \(n, e) -> return $ BuiltInFunCall e (SimpleReference (Identifier n BTUnknown))
 
   373         , try (parens pas $ expression >>= \e -> notFollowedBy (comments >> char '.') >> return e)
 
   396         , try (parens pas $ expression >>= \e -> notFollowedBy (comments >> char' '.') >> return e)
 
   374         , brackets pas (commaSep pas iD) >>= return . SetExpression
 
   397         , brackets pas (commaSep pas iD) >>= return . SetExpression
 
   375         , try $ integer pas >>= \i -> notFollowedBy (char '.') >> (return . NumberLiteral . show) i
 
   398         , try $ integer pas >>= \i -> notFollowedBy (char' '.') >> (return . NumberLiteral . show) i
 
   376         , float pas >>= return . FloatLiteral . show
 
   399         , float pas >>= return . FloatLiteral . show
 
   377         , try $ integer pas >>= return . NumberLiteral . show
 
   400         , try $ integer pas >>= return . NumberLiteral . show
 
   378         , try (string "_S" >> stringLiteral pas) >>= return . StringLiteral
 
   401         , try (string' "_S" >> stringLiteral pas) >>= return . StringLiteral
 
   379         , try (string "_P" >> stringLiteral pas) >>= return . PCharLiteral
 
   402         , try (string' "_P" >> stringLiteral pas) >>= return . PCharLiteral
 
   380         , stringLiteral pas >>= return . strOrChar
 
   403         , stringLiteral pas >>= return . strOrChar
 
   381         , try (string "#$") >> many hexDigit >>= \c -> comments >> return (HexCharCode c)
 
   404         , try (string' "#$") >> many hexDigit >>= \c -> comments >> return (HexCharCode c)
 
   382         , char '#' >> many digit >>= \c -> comments >> return (CharCode c)
 
   405         , char' '#' >> many digit >>= \c -> comments >> return (CharCode c)
 
   383         , char '$' >> many hexDigit >>=  \h -> comments >> return (HexNumber h)
 
   406         , char' '$' >> many hexDigit >>=  \h -> comments >> return (HexNumber h)
 
   384         --, char '-' >> expression >>= return . PrefixOp "-"
 
   407         --, char' '-' >> expression >>= return . PrefixOp "-"
 
   385         , char '-' >> reference >>= return . PrefixOp "-" . Reference
 
   408         , char' '-' >> reference >>= return . PrefixOp "-" . Reference
 
   386         , (try $ string "not" >> notFollowedBy comments) >> unexpected "'not'"
 
   409         , (try $ string' "not" >> notFollowedBy comments) >> unexpected "'not'"
 
   387         , try $ string "nil" >> return Null
 
   410         , try $ string' "nil" >> return Null
 
   388         , reference >>= return . Reference
 
   411         , reference >>= return . Reference
 
   389         ] <?> "simple expression"
 
   412         ] <?> "simple expression"
 
   390 
   413 
   391     table = [
 
   414     table = [
 
   392           [  Prefix (reservedOp pas "not">> return (PrefixOp "not"))
 
   415           [  Prefix (reservedOp pas "not">> return (PrefixOp "not"))
 
   393            , Prefix (try (char '-') >> return (PrefixOp "-"))]
 
   416            , Prefix (try (char' '-') >> return (PrefixOp "-"))]
 
   394            ,
 
   417            ,
 
   395           [  Infix (char '*' >> return (BinOp "*")) AssocLeft
 
   418           [  Infix (char' '*' >> return (BinOp "*")) AssocLeft
 
   396            , Infix (char '/' >> return (BinOp "/")) AssocLeft
 
   419            , Infix (char' '/' >> return (BinOp "/")) AssocLeft
 
   397            , Infix (try (string "div") >> return (BinOp "div")) AssocLeft
 
   420            , Infix (try (string' "div") >> return (BinOp "div")) AssocLeft
 
   398            , Infix (try (string "mod") >> return (BinOp "mod")) AssocLeft
 
   421            , Infix (try (string' "mod") >> return (BinOp "mod")) AssocLeft
 
   399            , Infix (try (string "in") >> return (BinOp "in")) AssocNone
 
   422            , Infix (try (string' "in") >> return (BinOp "in")) AssocNone
 
   400            , Infix (try $ string "and" >> return (BinOp "and")) AssocLeft
 
   423            , Infix (try $ string' "and" >> return (BinOp "and")) AssocLeft
 
   401            , Infix (try $ string "shl" >> return (BinOp "shl")) AssocLeft
 
   424            , Infix (try $ string' "shl" >> return (BinOp "shl")) AssocLeft
 
   402            , Infix (try $ string "shr" >> return (BinOp "shr")) AssocLeft
 
   425            , Infix (try $ string' "shr" >> return (BinOp "shr")) AssocLeft
 
   403           ]
 
   426           ]
 
   404         , [  Infix (char '+' >> return (BinOp "+")) AssocLeft
 
   427         , [  Infix (char' '+' >> return (BinOp "+")) AssocLeft
 
   405            , Infix (char '-' >> return (BinOp "-")) AssocLeft
 
   428            , Infix (char' '-' >> return (BinOp "-")) AssocLeft
 
   406            , Infix (try $ string "or" >> return (BinOp "or")) AssocLeft
 
   429            , Infix (try $ string' "or" >> return (BinOp "or")) AssocLeft
 
   407            , Infix (try $ string "xor" >> return (BinOp "xor")) AssocLeft
 
   430            , Infix (try $ string' "xor" >> return (BinOp "xor")) AssocLeft
 
   408           ]
 
   431           ]
 
   409         , [  Infix (try (string "<>") >> return (BinOp "<>")) AssocNone
 
   432         , [  Infix (try (string' "<>") >> return (BinOp "<>")) AssocNone
 
   410            , Infix (try (string "<=") >> return (BinOp "<=")) AssocNone
 
   433            , Infix (try (string' "<=") >> return (BinOp "<=")) AssocNone
 
   411            , Infix (try (string ">=") >> return (BinOp ">=")) AssocNone
 
   434            , Infix (try (string' ">=") >> return (BinOp ">=")) AssocNone
 
   412            , Infix (char '<' >> return (BinOp "<")) AssocNone
 
   435            , Infix (char' '<' >> return (BinOp "<")) AssocNone
 
   413            , Infix (char '>' >> return (BinOp ">")) AssocNone
 
   436            , Infix (char' '>' >> return (BinOp ">")) AssocNone
 
   414           ]
 
   437           ]
 
   415         {-, [  Infix (try $ string "shl" >> return (BinOp "shl")) AssocNone
 
   438         {-, [  Infix (try $ string' "shl" >> return (BinOp "shl")) AssocNone
 
   416              , Infix (try $ string "shr" >> return (BinOp "shr")) AssocNone
 
   439              , Infix (try $ string' "shr" >> return (BinOp "shr")) AssocNone
 
   417           ]
 
   440           ]
 
   418         , [
 
   441         , [
 
   419              Infix (try $ string "or" >> return (BinOp "or")) AssocLeft
 
   442              Infix (try $ string' "or" >> return (BinOp "or")) AssocLeft
 
   420            , Infix (try $ string "xor" >> return (BinOp "xor")) AssocLeft
 
   443            , Infix (try $ string' "xor" >> return (BinOp "xor")) AssocLeft
 
   421           ]-}
 
   444           ]-}
 
   422         , [
 
   445         , [
 
   423              Infix (char '=' >> return (BinOp "=")) AssocNone
 
   446              Infix (char' '=' >> return (BinOp "=")) AssocNone
 
   424           ]
 
   447           ]
 
   425         ]
 
   448         ]
 
   426     strOrChar [a] = CharCode . show . ord $ a
 
   449     strOrChar [a] = CharCode . show . ord $ a
 
   427     strOrChar a = StringLiteral a
 
   450     strOrChar a = StringLiteral a
 
   428 
   451 
       
   452 phrasesBlock :: Parsec String u Phrase
 
   429 phrasesBlock = do
 
   453 phrasesBlock = do
 
   430     try $ string "begin"
 
   454     try $ string' "begin"
 
   431     comments
 
   455     comments
 
   432     p <- manyTill phrase (try $ string "end" >> notFollowedBy alphaNum)
 
   456     p <- manyTill phrase (try $ string' "end" >> notFollowedBy alphaNum)
 
   433     comments
 
   457     comments
 
   434     return $ Phrases p
 
   458     return $ Phrases p
 
   435 
   459 
       
   460 phrase :: Parsec String u Phrase
 
   436 phrase = do
 
   461 phrase = do
 
   437     o <- choice [
 
   462     o <- choice [
 
   438         phrasesBlock
 
   463         phrasesBlock
 
   439         , ifBlock
 
   464         , ifBlock
 
   440         , whileCycle
 
   465         , whileCycle
 
   441         , repeatCycle
 
   466         , repeatCycle
 
   442         , switchCase
 
   467         , switchCase
 
   443         , withBlock
 
   468         , withBlock
 
   444         , forCycle
 
   469         , forCycle
 
   445         , (try $ reference >>= \r -> string ":=" >> return r) >>= \r -> comments >> expression >>= return . Assignment r
 
   470         , (try $ reference >>= \r -> string' ":=" >> return r) >>= \r -> comments >> expression >>= return . Assignment r
 
   446         , builtInFunction expression >>= \(n, e) -> return $ BuiltInFunctionCall e (SimpleReference (Identifier n BTUnknown))
 
   471         , builtInFunction expression >>= \(n, e) -> return $ BuiltInFunctionCall e (SimpleReference (Identifier n BTUnknown))
 
   447         , procCall
 
   472         , procCall
 
   448         , char ';' >> comments >> return NOP
 
   473         , char' ';' >> comments >> return NOP
 
   449         ]
 
   474         ]
 
   450     optional $ char ';'
 
   475     optional $ char' ';'
 
   451     comments
 
   476     comments
 
   452     return o
 
   477     return o
 
   453 
   478 
       
   479 ifBlock :: Parsec String u Phrase
 
   454 ifBlock = do
 
   480 ifBlock = do
 
   455     try $ string "if" >> notFollowedBy (alphaNum <|> char '_')
 
   481     try $ string "if" >> notFollowedBy (alphaNum <|> char '_')
 
   456     comments
 
   482     comments
 
   457     e <- expression
 
   483     e <- expression
 
   458     comments
 
   484     comments
 
   459     string "then"
 
   485     string' "then"
 
   460     comments
 
   486     comments
 
   461     o1 <- phrase
 
   487     o1 <- phrase
 
   462     comments
 
   488     comments
 
   463     o2 <- optionMaybe $ do
 
   489     o2 <- optionMaybe $ do
 
   464         try $ string "else" >> space
 
   490         try $ string' "else" >> void space
 
   465         comments
 
   491         comments
 
   466         o <- option NOP phrase
 
   492         o <- option NOP phrase
 
   467         comments
 
   493         comments
 
   468         return o
 
   494         return o
 
   469     return $ IfThenElse e o1 o2
 
   495     return $ IfThenElse e o1 o2
 
   470 
   496 
       
   497 whileCycle :: Parsec String u Phrase
 
   471 whileCycle = do
 
   498 whileCycle = do
 
   472     try $ string "while"
 
   499     try $ string' "while"
 
   473     comments
 
   500     comments
 
   474     e <- expression
 
   501     e <- expression
 
   475     comments
 
   502     comments
 
   476     string "do"
 
   503     string' "do"
 
   477     comments
 
   504     comments
 
   478     o <- phrase
 
   505     o <- phrase
 
   479     return $ WhileCycle e o
 
   506     return $ WhileCycle e o
 
   480 
   507 
       
   508 withBlock :: Parsec String u Phrase
 
   481 withBlock = do
 
   509 withBlock = do
 
   482     try $ string "with" >> space
 
   510     try $ string' "with" >> void space
 
   483     comments
 
   511     comments
 
   484     rs <- (commaSep1 pas) reference
 
   512     rs <- (commaSep1 pas) reference
 
   485     comments
 
   513     comments
 
   486     string "do"
 
   514     string' "do"
 
   487     comments
 
   515     comments
 
   488     o <- phrase
 
   516     o <- phrase
 
   489     return $ foldr WithBlock o rs
 
   517     return $ foldr WithBlock o rs
 
   490 
   518 
       
   519 repeatCycle :: Parsec String u Phrase
 
   491 repeatCycle = do
 
   520 repeatCycle = do
 
   492     try $ string "repeat" >> space
 
   521     try $ string' "repeat" >> void space
 
   493     comments
 
   522     comments
 
   494     o <- many phrase
 
   523     o <- many phrase
 
   495     string "until"
 
   524     string' "until"
 
   496     comments
 
   525     comments
 
   497     e <- expression
 
   526     e <- expression
 
   498     comments
 
   527     comments
 
   499     return $ RepeatCycle e o
 
   528     return $ RepeatCycle e o
 
   500 
   529 
       
   530 forCycle :: Parsec String u Phrase
 
   501 forCycle = do
 
   531 forCycle = do
 
   502     try $ string "for" >> space
 
   532     try $ string' "for" >> void space
 
   503     comments
 
   533     comments
 
   504     i <- iD
 
   534     i <- iD
 
   505     comments
 
   535     comments
 
   506     string ":="
 
   536     string' ":="
 
   507     comments
 
   537     comments
 
   508     e1 <- expression
 
   538     e1 <- expression
 
   509     comments
 
   539     comments
 
   510     up <- liftM (== Just "to") $
 
   540     up <- liftM (== Just "to") $
 
   511             optionMaybe $ choice [
 
   541             optionMaybe $ choice [
 
   512                 try $ string "to"
 
   542                 try $ string "to"
 
   513                 , try $ string "downto"
 
   543                 , try $ string "downto"
 
   514                 ]
 
   544                 ]
 
   515     --choice [string "to", string "downto"]
 
   545     --choice [string' "to", string' "downto"]
 
   516     comments
 
   546     comments
 
   517     e2 <- expression
 
   547     e2 <- expression
 
   518     comments
 
   548     comments
 
   519     string "do"
 
   549     string' "do"
 
   520     comments
 
   550     comments
 
   521     p <- phrase
 
   551     p <- phrase
 
   522     comments
 
   552     comments
 
   523     return $ ForCycle i e1 e2 p up
 
   553     return $ ForCycle i e1 e2 p up
 
   524 
   554 
       
   555 switchCase :: Parsec String u Phrase
 
   525 switchCase = do
 
   556 switchCase = do
 
   526     try $ string "case"
 
   557     try $ string' "case"
 
   527     comments
 
   558     comments
 
   528     e <- expression
 
   559     e <- expression
 
   529     comments
 
   560     comments
 
   530     string "of"
 
   561     string' "of"
 
   531     comments
 
   562     comments
 
   532     cs <- many1 aCase
 
   563     cs <- many1 aCase
 
   533     o2 <- optionMaybe $ do
 
   564     o2 <- optionMaybe $ do
 
   534         try $ string "else" >> notFollowedBy alphaNum
 
   565         try $ string' "else" >> notFollowedBy alphaNum
 
   535         comments
 
   566         comments
 
   536         o <- many phrase
 
   567         o <- many phrase
 
   537         comments
 
   568         comments
 
   538         return o
 
   569         return o
 
   539     string "end"
 
   570     string' "end"
 
   540     comments
 
   571     comments
 
   541     return $ SwitchCase e cs o2
 
   572     return $ SwitchCase e cs o2
 
   542     where
 
   573     where
 
   543     aCase = do
 
   574     aCase = do
 
   544         e <- (commaSep pas) $ (liftM InitRange rangeDecl <|> initExpression)
 
   575         e <- (commaSep pas) $ (liftM InitRange rangeDecl <|> initExpression)
 
   545         comments
 
   576         comments
 
   546         char ':'
 
   577         char' ':'
 
   547         comments
 
   578         comments
 
   548         p <- phrase
 
   579         p <- phrase
 
   549         comments
 
   580         comments
 
   550         return (e, p)
 
   581         return (e, p)
 
   551 
   582 
       
   583 procCall :: Parsec String u Phrase
 
   552 procCall = do
 
   584 procCall = do
 
   553     r <- reference
 
   585     r <- reference
 
   554     p <- option [] $ (parens pas) parameters
 
   586     p <- option [] $ (parens pas) parameters
 
   555     return $ ProcCall r p
 
   587     return $ ProcCall r p
 
   556 
   588 
       
   589 parameters :: Parsec String u [Expression]
 
   557 parameters = (commaSep pas) expression <?> "parameters"
 
   590 parameters = (commaSep pas) expression <?> "parameters"
 
   558 
   591 
       
   592 functionBody :: Parsec String u (TypesAndVars, Phrase)
 
   559 functionBody = do
 
   593 functionBody = do
 
   560     tv <- typeVarDeclaration True
 
   594     tv <- typeVarDeclaration True
 
   561     comments
 
   595     comments
 
   562     p <- phrasesBlock
 
   596     p <- phrasesBlock
 
   563     char ';'
 
   597     char' ';'
 
   564     comments
 
   598     comments
 
   565     return (TypesAndVars tv, p)
 
   599     return (TypesAndVars tv, p)
 
   566 
   600 
       
   601 uses :: Parsec String u Uses
 
   567 uses = liftM Uses (option [] u)
 
   602 uses = liftM Uses (option [] u)
 
   568     where
 
   603     where
 
   569         u = do
 
   604         u = do
 
   570             string "uses"
 
   605             string' "uses"
 
   571             comments
 
   606             comments
 
   572             u <- (iD >>= \i -> comments >> return i) `sepBy1` (char ',' >> comments)
 
   607             ulist <- (iD >>= \i -> comments >> return i) `sepBy1` (char' ',' >> comments)
 
   573             char ';'
 
   608             char' ';'
 
   574             comments
 
   609             comments
 
   575             return u
 
   610             return ulist
 
   576 
   611 
       
   612 initExpression :: Parsec String u InitExpression
 
   577 initExpression = buildExpressionParser table term <?> "initialization expression"
 
   613 initExpression = buildExpressionParser table term <?> "initialization expression"
 
   578     where
 
   614     where
 
   579     term = comments >> choice [
 
   615     term = comments >> choice [
 
   580         liftM (uncurry BuiltInFunction) $ builtInFunction initExpression
 
   616         liftM (uncurry BuiltInFunction) $ builtInFunction initExpression
 
   581         , try $ brackets pas (commaSep pas $ initExpression) >>= return . InitSet
 
   617         , try $ brackets pas (commaSep pas $ initExpression) >>= return . InitSet
 
   582         , try $ parens pas (commaSep pas $ initExpression) >>= \ia -> when ((notRecord $ head ia) && (null $ tail ia)) mzero >> return (InitArray ia)
 
   618         , try $ parens pas (commaSep pas $ initExpression) >>= \ia -> when ((notRecord $ head ia) && (null $ tail ia)) mzero >> return (InitArray ia)
 
   583         , try $ parens pas (sepEndBy recField (char ';' >> comments)) >>= return . InitRecord
 
   619         , try $ parens pas (sepEndBy recField (char' ';' >> comments)) >>= return . InitRecord
 
   584         , parens pas initExpression
 
   620         , parens pas initExpression
 
   585         , try $ integer pas >>= \i -> notFollowedBy (char '.') >> (return . InitNumber . show) i
 
   621         , try $ integer pas >>= \i -> notFollowedBy (char' '.') >> (return . InitNumber . show) i
 
   586         , try $ float pas >>= return . InitFloat . show
 
   622         , try $ float pas >>= return . InitFloat . show
 
   587         , try $ integer pas >>= return . InitNumber . show
 
   623         , try $ integer pas >>= return . InitNumber . show
 
   588         , stringLiteral pas >>= return . InitString
 
   624         , stringLiteral pas >>= return . InitString
 
   589         , char '#' >> many digit >>= \c -> comments >> return (InitChar c)
 
   625         , char' '#' >> many digit >>= \c -> comments >> return (InitChar c)
 
   590         , char '$' >> many hexDigit >>= \h -> comments >> return (InitHexNumber h)
 
   626         , char' '$' >> many hexDigit >>= \h -> comments >> return (InitHexNumber h)
 
   591         , char '@' >> initExpression >>= \c -> comments >> return (InitAddress c)
 
   627         , char' '@' >> initExpression >>= \c -> comments >> return (InitAddress c)
 
   592         , try $ string "nil" >> return InitNull
 
   628         , try $ string' "nil" >> return InitNull
 
   593         , itypeCast
 
   629         , itypeCast
 
   594         , iD >>= return . InitReference
 
   630         , iD >>= return . InitReference
 
   595         ]
 
   631         ]
 
   596 
   632 
   597     notRecord (InitRecord _) = False
 
   633     notRecord (InitRecord _) = False
 
   598     notRecord _ = True
 
   634     notRecord _ = True
 
   599 
   635 
   600     recField = do
 
   636     recField = do
 
   601         i <- iD
 
   637         i <- iD
 
   602         spaces
 
   638         spaces
 
   603         char ':'
 
   639         char' ':'
 
   604         spaces
 
   640         spaces
 
   605         e <- initExpression
 
   641         e <- initExpression
 
   606         spaces
 
   642         spaces
 
   607         return (i ,e)
 
   643         return (i ,e)
 
   608 
   644 
   609     table = [
 
   645     table = [
 
   610           [
 
   646           [
 
   611              Prefix (char '-' >> return (InitPrefixOp "-"))
 
   647              Prefix (char' '-' >> return (InitPrefixOp "-"))
 
   612             ,Prefix (try (string "not") >> return (InitPrefixOp "not"))
 
   648             ,Prefix (try (string' "not") >> return (InitPrefixOp "not"))
 
   613           ]
 
   649           ]
 
   614         , [  Infix (char '*' >> return (InitBinOp "*")) AssocLeft
 
   650         , [  Infix (char' '*' >> return (InitBinOp "*")) AssocLeft
 
   615            , Infix (char '/' >> return (InitBinOp "/")) AssocLeft
 
   651            , Infix (char' '/' >> return (InitBinOp "/")) AssocLeft
 
   616            , Infix (try (string "div") >> return (InitBinOp "div")) AssocLeft
 
   652            , Infix (try (string' "div") >> return (InitBinOp "div")) AssocLeft
 
   617            , Infix (try (string "mod") >> return (InitBinOp "mod")) AssocLeft
 
   653            , Infix (try (string' "mod") >> return (InitBinOp "mod")) AssocLeft
 
   618            , Infix (try $ string "and" >> return (InitBinOp "and")) AssocLeft
 
   654            , Infix (try $ string' "and" >> return (InitBinOp "and")) AssocLeft
 
   619            , Infix (try $ string "shl" >> return (InitBinOp "shl")) AssocNone
 
   655            , Infix (try $ string' "shl" >> return (InitBinOp "shl")) AssocNone
 
   620            , Infix (try $ string "shr" >> return (InitBinOp "shr")) AssocNone
 
   656            , Infix (try $ string' "shr" >> return (InitBinOp "shr")) AssocNone
 
   621           ]
 
   657           ]
 
   622         , [  Infix (char '+' >> return (InitBinOp "+")) AssocLeft
 
   658         , [  Infix (char' '+' >> return (InitBinOp "+")) AssocLeft
 
   623            , Infix (char '-' >> return (InitBinOp "-")) AssocLeft
 
   659            , Infix (char' '-' >> return (InitBinOp "-")) AssocLeft
 
   624            , Infix (try $ string "or" >> return (InitBinOp "or")) AssocLeft
 
   660            , Infix (try $ string' "or" >> return (InitBinOp "or")) AssocLeft
 
   625            , Infix (try $ string "xor" >> return (InitBinOp "xor")) AssocLeft
 
   661            , Infix (try $ string' "xor" >> return (InitBinOp "xor")) AssocLeft
 
   626           ]
 
   662           ]
 
   627         , [  Infix (try (string "<>") >> return (InitBinOp "<>")) AssocNone
 
   663         , [  Infix (try (string' "<>") >> return (InitBinOp "<>")) AssocNone
 
   628            , Infix (try (string "<=") >> return (InitBinOp "<=")) AssocNone
 
   664            , Infix (try (string' "<=") >> return (InitBinOp "<=")) AssocNone
 
   629            , Infix (try (string ">=") >> return (InitBinOp ">=")) AssocNone
 
   665            , Infix (try (string' ">=") >> return (InitBinOp ">=")) AssocNone
 
   630            , Infix (char '<' >> return (InitBinOp "<")) AssocNone
 
   666            , Infix (char' '<' >> return (InitBinOp "<")) AssocNone
 
   631            , Infix (char '>' >> return (InitBinOp ">")) AssocNone
 
   667            , Infix (char' '>' >> return (InitBinOp ">")) AssocNone
 
   632            , Infix (char '=' >> return (InitBinOp "=")) AssocNone
 
   668            , Infix (char' '=' >> return (InitBinOp "=")) AssocNone
 
   633           ]
 
   669           ]
 
   634         {--, [  Infix (try $ string "and" >> return (InitBinOp "and")) AssocLeft
 
   670         {--, [  Infix (try $ string' "and" >> return (InitBinOp "and")) AssocLeft
 
   635            , Infix (try $ string "or" >> return (InitBinOp "or")) AssocLeft
 
   671            , Infix (try $ string' "or" >> return (InitBinOp "or")) AssocLeft
 
   636            , Infix (try $ string "xor" >> return (InitBinOp "xor")) AssocLeft
 
   672            , Infix (try $ string' "xor" >> return (InitBinOp "xor")) AssocLeft
 
   637           ]
 
   673           ]
 
   638         , [  Infix (try $ string "shl" >> return (InitBinOp "shl")) AssocNone
 
   674         , [  Infix (try $ string' "shl" >> return (InitBinOp "shl")) AssocNone
 
   639            , Infix (try $ string "shr" >> return (InitBinOp "shr")) AssocNone
 
   675            , Infix (try $ string' "shr" >> return (InitBinOp "shr")) AssocNone
 
   640           ]--}
 
   676           ]--}
 
   641         --, [Prefix (try (string "not") >> return (InitPrefixOp "not"))]
 
   677         --, [Prefix (try (string' "not") >> return (InitPrefixOp "not"))]
 
   642         ]
 
   678         ]
 
   643 
   679 
   644     itypeCast = do
 
   680     itypeCast = do
 
   645         t <- choice $ map (\s -> try $ caseInsensitiveString s >>= \i -> notFollowedBy alphaNum >> return i) knownTypes
 
   681         t <- choice $ map (\s -> try $ caseInsensitiveString s >>= \i -> notFollowedBy alphaNum >> return i) knownTypes
 
   646         i <- parens pas initExpression
 
   682         i <- parens pas initExpression
 
   647         comments
 
   683         comments
 
   648         return $ InitTypeCast (Identifier t BTUnknown) i
 
   684         return $ InitTypeCast (Identifier t BTUnknown) i
 
   649 
   685 
       
   686 builtInFunction :: Parsec String u a -> Parsec String u (String, [a])
 
   650 builtInFunction e = do
 
   687 builtInFunction e = do
 
   651     name <- choice $ map (\s -> try $ caseInsensitiveString s >>= \i -> notFollowedBy alphaNum >> return i) builtin
 
   688     name <- choice $ map (\s -> try $ caseInsensitiveString s >>= \i -> notFollowedBy alphaNum >> return i) builtin
 
   652     spaces
 
   689     spaces
 
   653     exprs <- option [] $ parens pas $ option [] $ commaSep1 pas $ e
 
   690     exprs <- option [] $ parens pas $ option [] $ commaSep1 pas $ e
 
   654     spaces
 
   691     spaces
 
   655     return (name, exprs)
 
   692     return (name, exprs)
 
   656 
   693 
       
   694 systemUnit :: Parsec String u PascalUnit
 
   657 systemUnit = do
 
   695 systemUnit = do
 
   658     string "system;"
 
   696     string' "system;"
 
   659     comments
 
   697     comments
 
   660     string "type"
 
   698     string' "type"
 
   661     comments
 
   699     comments
 
   662     t <- typesDecl
 
   700     t <- typesDecl
 
   663     string "var"
 
   701     string' "var"
 
   664     v <- varsDecl True
 
   702     v <- varsDecl True
 
   665     return $ System (t ++ v)
 
   703     return $ System (t ++ v)
 
   666 
   704 
       
   705 redoUnit :: Parsec String u PascalUnit
 
   667 redoUnit = do
 
   706 redoUnit = do
 
   668     string "redo;"
 
   707     string' "redo;"
 
   669     comments
 
   708     comments
 
   670     string "type"
 
   709     string' "type"
 
   671     comments
 
   710     comments
 
   672     t <- typesDecl
 
   711     t <- typesDecl
 
   673     string "var"
 
   712     string' "var"
 
   674     v <- varsDecl True
 
   713     v <- varsDecl True
 
   675     return $ Redo (t ++ v)
 
   714     return $ Redo (t ++ v)
 
   676 
   715
sheepy-clone