diff -r af4ab297b2b7 -r 539380a498e4 tools/PascalParser.hs
--- a/tools/PascalParser.hs	Tue Mar 26 18:52:42 2013 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,659 +0,0 @@
-module PascalParser where
-
-import Text.Parsec
-import Text.Parsec.Char
-import Text.Parsec.Token
-import Text.Parsec.Language
-import Text.Parsec.Expr
-import Text.Parsec.Prim
-import Text.Parsec.Combinator
-import Text.Parsec.String
-import Control.Monad
-import Data.Maybe
-import Data.Char
-
-import PascalBasics
-import PascalUnitSyntaxTree
-
-knownTypes = ["shortstring", "ansistring", "char", "byte"]
-
-pascalUnit = do
-    comments
-    u <- choice [program, unit, systemUnit, redoUnit]
-    comments
-    return u
-
-iD = do
-    i <- liftM (flip Identifier BTUnknown) (identifier pas)
-    comments
-    return i
-
-unit = do
-    string "unit" >> comments
-    name <- iD
-    semi pas
-    comments
-    int <- interface
-    impl <- implementation
-    comments
-    return $ Unit name int impl Nothing Nothing
-
-
-reference = buildExpressionParser table term <?> "reference"
-    where
-    term = comments >> choice [
-        parens pas (liftM RefExpression expression >>= postfixes) >>= postfixes
-        , try $ typeCast >>= postfixes
-        , char '@' >> liftM Address reference >>= postfixes
-        , liftM SimpleReference iD >>= postfixes
-        ] <?> "simple reference"
-
-    table = [
-        ]
-
-    postfixes r = many postfix >>= return . foldl (flip ($)) r
-    postfix = choice [
-            parens pas (option [] parameters) >>= return . FunCall
-          , char '^' >> return Dereference
-          , (brackets pas) (commaSep1 pas $ expression) >>= return . ArrayElement
-          , (char '.' >> notFollowedBy (char '.')) >> liftM (flip RecordField) reference
-        ]
-
-    typeCast = do
-        t <- choice $ map (\s -> try $ caseInsensitiveString s >>= \i -> notFollowedBy alphaNum >> return i) knownTypes
-        e <- parens pas expression
-        comments
-        return $ TypeCast (Identifier t BTUnknown) e
-
-varsDecl1 = varsParser sepEndBy1
-varsDecl = varsParser sepEndBy
-varsParser m endsWithSemi = do
-    vs <- m (aVarDecl endsWithSemi) (semi pas)
-    return vs
-
-aVarDecl endsWithSemi = do
-    isVar <- liftM (== Just "var") $
-        if not endsWithSemi then
-            optionMaybe $ choice [
-                try $ string "var"
-                , try $ string "const"
-                , try $ string "out"
-                ]
-            else
-                return Nothing
-    comments
-    ids <- do
-        i <- (commaSep1 pas) $ (try iD <?> "variable declaration")
-        char ':'
-        return i
-    comments
-    t <- typeDecl <?> "variable type declaration"
-    comments
-    init <- option Nothing $ do
-        char '='
-        comments
-        e <- initExpression
-        comments
-        return (Just e)
-    return $ VarDeclaration isVar False (ids, t) init
-
-
-constsDecl = do
-    vs <- many1 (try (aConstDecl >>= \i -> semi pas >> return i) >>= \i -> comments >> return i)
-    comments
-    return vs
-    where
-    aConstDecl = do
-        comments
-        i <- iD
-        t <- optionMaybe $ do
-            char ':'
-            comments
-            t <- typeDecl
-            comments
-            return t
-        char '='
-        comments
-        e <- initExpression
-        comments
-        return $ VarDeclaration False (isNothing t) ([i], fromMaybe (DeriveType e) t) (Just e)
-
-typeDecl = choice [
-    char '^' >> typeDecl >>= return . PointerTo
-    , try (string "shortstring") >> return (String 255)
-    , try (string "string") >> optionMaybe (brackets pas $ integer pas) >>= return . String . fromMaybe 255
-    , try (string "ansistring") >> optionMaybe (brackets pas $ integer pas) >>= return . String . fromMaybe 255
-    , arrayDecl
-    , recordDecl
-    , setDecl
-    , functionType
-    , sequenceDecl >>= return . Sequence
-    , try iD >>= return . SimpleType
-    , rangeDecl >>= return . RangeType
-    ] <?> "type declaration"
-    where
-    arrayDecl = do
-        try $ do
-            optional $ (try $ string "packed") >> comments
-            string "array"
-        comments
-        r <- option [] $ do
-            char '['
-            r <- commaSep pas rangeDecl
-            char ']'
-            comments
-            return r
-        string "of"
-        comments
-        t <- typeDecl
-        if null r then
-            return $ ArrayDecl Nothing t
-            else
-            return $ foldr (\a b -> ArrayDecl (Just a) b) (ArrayDecl (Just $ head r) t) (tail r)
-    recordDecl = do
-        try $ do
-            optional $ (try $ string "packed") >> comments
-            string "record"
-        comments
-        vs <- varsDecl True
-        union <- optionMaybe $ do
-            string "case"
-            comments
-            iD
-            comments
-            string "of"
-            comments
-            many unionCase
-        string "end"
-        return $ RecordType vs union
-    setDecl = do
-        try $ string "set" >> space
-        comments
-        string "of"
-        comments
-        liftM Set typeDecl
-    unionCase = do
-        try $ commaSep pas $ (iD >> return ()) <|> (integer pas >> return ())
-        char ':'
-        comments
-        u <- parens pas $ varsDecl True
-        char ';'
-        comments
-        return u
-    sequenceDecl = (parens pas) $ (commaSep pas) (iD >>= \i -> optional (spaces >> char '=' >> spaces >> integer pas) >> return i)
-    functionType = do
-        fp <- try (string "function") <|> try (string "procedure")
-        comments
-        vs <- option [] $ parens pas $ varsDecl False
-        comments
-        ret <- if (fp == "function") then do
-            char ':'
-            comments
-            ret <- typeDecl
-            comments
-            return ret
-            else
-            return VoidType
-        optional $ try $ char ';' >> comments >> string "cdecl"
-        comments
-        return $ FunctionType ret vs
-
-typesDecl = many (aTypeDecl >>= \t -> comments >> return t)
-    where
-    aTypeDecl = do
-        i <- try $ do
-            i <- iD <?> "type declaration"
-            comments
-            char '='
-            return i
-        comments
-        t <- typeDecl
-        comments
-        semi pas
-        comments
-        return $ TypeDeclaration i t
-
-rangeDecl = choice [
-    try $ rangeft
-    , iD >>= return . Range
-    ] <?> "range declaration"
-    where
-    rangeft = do
-    e1 <- initExpression
-    string ".."
-    e2 <- initExpression
-    return $ RangeFromTo e1 e2
-
-typeVarDeclaration isImpl = (liftM concat . many . choice) [
-    varSection,
-    constSection,
-    typeSection,
-    funcDecl,
-    operatorDecl
-    ]
-    where
-    varSection = do
-        try $ string "var"
-        comments
-        v <- varsDecl1 True <?> "variable declaration"
-        comments
-        return v
-
-    constSection = do
-        try $ string "const"
-        comments
-        c <- constsDecl <?> "const declaration"
-        comments
-        return c
-
-    typeSection = do
-        try $ string "type"
-        comments
-        t <- typesDecl <?> "type declaration"
-        comments
-        return t
-
-    operatorDecl = do
-        try $ string "operator"
-        comments
-        i <- manyTill anyChar space
-        comments
-        vs <- parens pas $ varsDecl False
-        comments
-        rid <- iD
-        comments
-        char ':'
-        comments
-        ret <- typeDecl
-        comments
-        return ret
-        char ';'
-        comments
-        forward <- liftM isJust $ optionMaybe (try (string "forward;") >> comments)
-        inline <- liftM (any (== "inline;")) $ many functionDecorator
-        b <- if isImpl && (not forward) then
-                liftM Just functionBody
-                else
-                return Nothing
-        return $ [OperatorDeclaration i rid inline ret vs b]
-
-
-    funcDecl = do
-        fp <- try (string "function") <|> try (string "procedure")
-        comments
-        i <- iD
-        vs <- option [] $ parens pas $ varsDecl False
-        comments
-        ret <- if (fp == "function") then do
-            char ':'
-            comments
-            ret <- typeDecl
-            comments
-            return ret
-            else
-            return VoidType
-        char ';'
-        comments
-        forward <- liftM isJust $ optionMaybe (try (string "forward;") >> comments)
-        inline <- liftM (any (== "inline;")) $ many functionDecorator
-        b <- if isImpl && (not forward) then
-                liftM Just functionBody
-                else
-                return Nothing
-        return $ [FunctionDeclaration i inline ret vs b]
-
-    functionDecorator = do
-        d <- choice [
-            try $ string "inline;"
-            , try $ caseInsensitiveString "cdecl;"
-            , try $ string "overload;"
-            , try $ string "export;"
-            , try $ string "varargs;"
-            , try (string "external") >> comments >> iD >> optional (string "name" >> comments >> stringLiteral pas)>> string ";"
-            ]
-        comments
-        return d
-
-
-program = do
-    string "program"
-    comments
-    name <- iD
-    (char ';')
-    comments
-    comments
-    u <- uses
-    comments
-    tv <- typeVarDeclaration True
-    comments
-    p <- phrase
-    comments
-    char '.'
-    comments
-    return $ Program name (Implementation u (TypesAndVars tv)) p
-
-interface = do
-    string "interface"
-    comments
-    u <- uses
-    comments
-    tv <- typeVarDeclaration False
-    comments
-    return $ Interface u (TypesAndVars tv)
-
-implementation = do
-    string "implementation"
-    comments
-    u <- uses
-    comments
-    tv <- typeVarDeclaration True
-    string "end."
-    comments
-    return $ Implementation u (TypesAndVars tv)
-
-expression = do
-    buildExpressionParser table term <?> "expression"
-    where
-    term = comments >> choice [
-        builtInFunction expression >>= \(n, e) -> return $ BuiltInFunCall e (SimpleReference (Identifier n BTUnknown))
-        , try (parens pas $ expression >>= \e -> notFollowedBy (comments >> char '.') >> return e)
-        , brackets pas (commaSep pas iD) >>= return . SetExpression
-        , try $ integer pas >>= \i -> notFollowedBy (char '.') >> (return . NumberLiteral . show) i
-        , float pas >>= return . FloatLiteral . show
-        , try $ integer pas >>= return . NumberLiteral . show
-        , try (string "_S" >> stringLiteral pas) >>= return . StringLiteral
-        , try (string "_P" >> stringLiteral pas) >>= return . PCharLiteral
-        , stringLiteral pas >>= return . strOrChar
-        , try (string "#$") >> many hexDigit >>= \c -> comments >> return (HexCharCode c)
-        , char '#' >> many digit >>= \c -> comments >> return (CharCode c)
-        , char '$' >> many hexDigit >>=  \h -> comments >> return (HexNumber h)
-        --, char '-' >> expression >>= return . PrefixOp "-"
-        , char '-' >> reference >>= return . PrefixOp "-" . Reference
-        , (try $ string "not" >> notFollowedBy comments) >> unexpected "'not'"
-        , try $ string "nil" >> return Null
-        , reference >>= return . Reference
-        ] <?> "simple expression"
-
-    table = [
-          [  Prefix (try (string "not") >> return (PrefixOp "not"))
-           , Prefix (try (char '-') >> return (PrefixOp "-"))]
-        ,
-          [  Infix (char '*' >> return (BinOp "*")) AssocLeft
-           , Infix (char '/' >> return (BinOp "/")) AssocLeft
-           , Infix (try (string "div") >> return (BinOp "div")) AssocLeft
-           , Infix (try (string "mod") >> return (BinOp "mod")) AssocLeft
-           , Infix (try (string "in") >> return (BinOp "in")) AssocNone
-           , Infix (try $ string "and" >> return (BinOp "and")) AssocLeft
-           , Infix (try $ string "shl" >> return (BinOp "shl")) AssocLeft
-           , Infix (try $ string "shr" >> return (BinOp "shr")) AssocLeft
-          ]
-        , [  Infix (char '+' >> return (BinOp "+")) AssocLeft
-           , Infix (char '-' >> return (BinOp "-")) AssocLeft
-           , Infix (try $ string "or" >> return (BinOp "or")) AssocLeft
-           , Infix (try $ string "xor" >> return (BinOp "xor")) AssocLeft
-          ]
-        , [  Infix (try (string "<>") >> return (BinOp "<>")) AssocNone
-           , Infix (try (string "<=") >> return (BinOp "<=")) AssocNone
-           , Infix (try (string ">=") >> return (BinOp ">=")) AssocNone
-           , Infix (char '<' >> return (BinOp "<")) AssocNone
-           , Infix (char '>' >> return (BinOp ">")) AssocNone
-          ]
-        {-, [  Infix (try $ string "shl" >> return (BinOp "shl")) AssocNone
-             , Infix (try $ string "shr" >> return (BinOp "shr")) AssocNone
-          ]
-        , [
-             Infix (try $ string "or" >> return (BinOp "or")) AssocLeft
-           , Infix (try $ string "xor" >> return (BinOp "xor")) AssocLeft
-          ]-}
-        , [
-             Infix (char '=' >> return (BinOp "=")) AssocNone
-          ]
-        ]
-    strOrChar [a] = CharCode . show . ord $ a
-    strOrChar a = StringLiteral a
-
-phrasesBlock = do
-    try $ string "begin"
-    comments
-    p <- manyTill phrase (try $ string "end" >> notFollowedBy alphaNum)
-    comments
-    return $ Phrases p
-
-phrase = do
-    o <- choice [
-        phrasesBlock
-        , ifBlock
-        , whileCycle
-        , repeatCycle
-        , switchCase
-        , withBlock
-        , forCycle
-        , (try $ reference >>= \r -> string ":=" >> return r) >>= \r -> comments >> expression >>= return . Assignment r
-        , builtInFunction expression >>= \(n, e) -> return $ BuiltInFunctionCall e (SimpleReference (Identifier n BTUnknown))
-        , procCall
-        , char ';' >> comments >> return NOP
-        ]
-    optional $ char ';'
-    comments
-    return o
-
-ifBlock = do
-    try $ string "if" >> notFollowedBy (alphaNum <|> char '_')
-    comments
-    e <- expression
-    comments
-    string "then"
-    comments
-    o1 <- phrase
-    comments
-    o2 <- optionMaybe $ do
-        try $ string "else" >> space
-        comments
-        o <- option NOP phrase
-        comments
-        return o
-    return $ IfThenElse e o1 o2
-
-whileCycle = do
-    try $ string "while"
-    comments
-    e <- expression
-    comments
-    string "do"
-    comments
-    o <- phrase
-    return $ WhileCycle e o
-
-withBlock = do
-    try $ string "with" >> space
-    comments
-    rs <- (commaSep1 pas) reference
-    comments
-    string "do"
-    comments
-    o <- phrase
-    return $ foldr WithBlock o rs
-
-repeatCycle = do
-    try $ string "repeat" >> space
-    comments
-    o <- many phrase
-    string "until"
-    comments
-    e <- expression
-    comments
-    return $ RepeatCycle e o
-
-forCycle = do
-    try $ string "for" >> space
-    comments
-    i <- iD
-    comments
-    string ":="
-    comments
-    e1 <- expression
-    comments
-    up <- liftM (== Just "to") $
-            optionMaybe $ choice [
-                try $ string "to"
-                , try $ string "downto"
-                ]
-    --choice [string "to", string "downto"]
-    comments
-    e2 <- expression
-    comments
-    string "do"
-    comments
-    p <- phrase
-    comments
-    return $ ForCycle i e1 e2 p up
-
-switchCase = do
-    try $ string "case"
-    comments
-    e <- expression
-    comments
-    string "of"
-    comments
-    cs <- many1 aCase
-    o2 <- optionMaybe $ do
-        try $ string "else" >> notFollowedBy alphaNum
-        comments
-        o <- many phrase
-        comments
-        return o
-    string "end"
-    comments
-    return $ SwitchCase e cs o2
-    where
-    aCase = do
-        e <- (commaSep pas) $ (liftM InitRange rangeDecl <|> initExpression)
-        comments
-        char ':'
-        comments
-        p <- phrase
-        comments
-        return (e, p)
-
-procCall = do
-    r <- reference
-    p <- option [] $ (parens pas) parameters
-    return $ ProcCall r p
-
-parameters = (commaSep pas) expression <?> "parameters"
-
-functionBody = do
-    tv <- typeVarDeclaration True
-    comments
-    p <- phrasesBlock
-    char ';'
-    comments
-    return (TypesAndVars tv, p)
-
-uses = liftM Uses (option [] u)
-    where
-        u = do
-            string "uses"
-            comments
-            u <- (iD >>= \i -> comments >> return i) `sepBy1` (char ',' >> comments)
-            char ';'
-            comments
-            return u
-
-initExpression = buildExpressionParser table term <?> "initialization expression"
-    where
-    term = comments >> choice [
-        liftM (uncurry BuiltInFunction) $ builtInFunction initExpression
-        , try $ brackets pas (commaSep pas $ initExpression) >>= return . InitSet
-        , try $ parens pas (commaSep pas $ initExpression) >>= \ia -> when (null $ tail ia) mzero >> return (InitArray ia)
-        , try $ parens pas (sepEndBy recField (char ';' >> comments)) >>= return . InitRecord
-        , parens pas initExpression
-        , try $ integer pas >>= \i -> notFollowedBy (char '.') >> (return . InitNumber . show) i
-        , try $ float pas >>= return . InitFloat . show
-        , try $ integer pas >>= return . InitNumber . show
-        , stringLiteral pas >>= return . InitString
-        , char '#' >> many digit >>= \c -> comments >> return (InitChar c)
-        , char '$' >> many hexDigit >>= \h -> comments >> return (InitHexNumber h)
-        , char '@' >> initExpression >>= \c -> comments >> return (InitAddress c)
-        , try $ string "nil" >> return InitNull
-        , itypeCast
-        , iD >>= return . InitReference
-        ]
-
-    recField = do
-        i <- iD
-        spaces
-        char ':'
-        spaces
-        e <- initExpression
-        spaces
-        return (i ,e)
-
-    table = [
-          [
-             Prefix (char '-' >> return (InitPrefixOp "-"))
-            ,Prefix (try (string "not") >> return (InitPrefixOp "not"))
-          ]
-        , [  Infix (char '*' >> return (InitBinOp "*")) AssocLeft
-           , Infix (char '/' >> return (InitBinOp "/")) AssocLeft
-           , Infix (try (string "div") >> return (InitBinOp "div")) AssocLeft
-           , Infix (try (string "mod") >> return (InitBinOp "mod")) AssocLeft
-           , Infix (try $ string "and" >> return (InitBinOp "and")) AssocLeft
-           , Infix (try $ string "shl" >> return (InitBinOp "shl")) AssocNone
-           , Infix (try $ string "shr" >> return (InitBinOp "shr")) AssocNone
-          ]
-        , [  Infix (char '+' >> return (InitBinOp "+")) AssocLeft
-           , Infix (char '-' >> return (InitBinOp "-")) AssocLeft
-           , Infix (try $ string "or" >> return (InitBinOp "or")) AssocLeft
-           , Infix (try $ string "xor" >> return (InitBinOp "xor")) AssocLeft
-          ]
-        , [  Infix (try (string "<>") >> return (InitBinOp "<>")) AssocNone
-           , Infix (try (string "<=") >> return (InitBinOp "<=")) AssocNone
-           , Infix (try (string ">=") >> return (InitBinOp ">=")) AssocNone
-           , Infix (char '<' >> return (InitBinOp "<")) AssocNone
-           , Infix (char '>' >> return (InitBinOp ">")) AssocNone
-           , Infix (char '=' >> return (InitBinOp "=")) AssocNone
-          ]
-        {--, [  Infix (try $ string "and" >> return (InitBinOp "and")) AssocLeft
-           , Infix (try $ string "or" >> return (InitBinOp "or")) AssocLeft
-           , Infix (try $ string "xor" >> return (InitBinOp "xor")) AssocLeft
-          ]
-        , [  Infix (try $ string "shl" >> return (InitBinOp "shl")) AssocNone
-           , Infix (try $ string "shr" >> return (InitBinOp "shr")) AssocNone
-          ]--}
-        --, [Prefix (try (string "not") >> return (InitPrefixOp "not"))]
-        ]
-
-    itypeCast = do
-        t <- choice $ map (\s -> try $ caseInsensitiveString s >>= \i -> notFollowedBy alphaNum >> return i) knownTypes
-        i <- parens pas initExpression
-        comments
-        return $ InitTypeCast (Identifier t BTUnknown) i
-
-builtInFunction e = do
-    name <- choice $ map (\s -> try $ caseInsensitiveString s >>= \i -> notFollowedBy alphaNum >> return i) builtin
-    spaces
-    exprs <- option [] $ parens pas $ option [] $ commaSep1 pas $ e
-    spaces
-    return (name, exprs)
-
-systemUnit = do
-    string "system;"
-    comments
-    string "type"
-    comments
-    t <- typesDecl
-    string "var"
-    v <- varsDecl True
-    return $ System (t ++ v)
-
-redoUnit = do
-    string "redo;"
-    comments
-    string "type"
-    comments
-    t <- typesDecl
-    string "var"
-    v <- varsDecl True
-    return $ Redo (t ++ v)
-