+
−module PascalParser (
+
−    pascalUnit,
+
−    mainResultInit
+
−    )
+
−    where
+
−
+
−import Text.Parsec
+
−import Text.Parsec.Token
+
−import Text.Parsec.Expr
+
−import Control.Monad
+
−import Data.Maybe
+
−import Data.Char
+
−
+
−import PascalBasics
+
−import PascalUnitSyntaxTree
+
−
+
−
+
−mainResultInit :: Phrase
+
−mainResultInit = (\(Right a) -> a) $ parse phrase "<built-in>" "main:= 0;"
+
−
+
−knownTypes :: [String]
+
−knownTypes = ["shortstring", "ansistring", "char", "byte"]
+
−
+
−pascalUnit :: Parsec String u PascalUnit
+
−pascalUnit = do
+
−    comments
+
−    u <- choice [program, unit, systemUnit, redoUnit]
+
−    comments
+
−    return u
+
−
+
−iD :: Parsec String u Identifier
+
−iD = do
+
−    i <- identifier pas
+
−    comments
+
−    when (i == "not") $ unexpected "'not' used as an identifier"
+
−    return $ Identifier i BTUnknown
+
−
+
−unit :: Parsec String u PascalUnit
+
−unit = do
+
−    string' "unit" >> comments
+
−    name <- iD
+
−    void $ semi pas
+
−    comments
+
−    int <- interface
+
−    impl <- implementation
+
−    comments
+
−    return $ Unit name int impl Nothing Nothing
+
−
+
−
+
−reference :: Parsec String u Reference
+
−reference = 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"
+
−
+
−    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, varsDecl :: Bool -> Parsec String u [TypeVarDeclaration]
+
−varsDecl1 = varsParser sepEndBy1
+
−varsDecl = varsParser sepEndBy
+
−
+
−varsParser ::
+
−    (Parsec String u TypeVarDeclaration
+
−        -> Parsec String u String
+
−        -> Parsec
+
−            String u [TypeVarDeclaration])
+
−    -> Bool
+
−    -> Parsec
+
−            String u [TypeVarDeclaration]
+
−varsParser m endsWithSemi = do
+
−    vs <- m (aVarDecl endsWithSemi) (semi pas)
+
−    return vs
+
−
+
−aVarDecl :: Bool -> Parsec String u TypeVarDeclaration
+
−aVarDecl endsWithSemi = do
+
−    isVar <- liftM (\i -> i == Just "var" || i == Just "out") $
+
−        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
+
−    initialization <- option Nothing $ do
+
−        char' '='
+
−        comments
+
−        e <- initExpression
+
−        comments
+
−        return (Just e)
+
−    return $ VarDeclaration isVar False (ids, t) initialization
+
−
+
−constsDecl :: Parsec String u [TypeVarDeclaration]
+
−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 :: Parsec String u TypeDecl
+
−typeDecl = choice [
+
−    char' '^' >> typeDecl >>= return . PointerTo
+
−    , try (string' "shortstring") >> return String
+
−    , try (string' "string") >> optionMaybe (brackets pas $ integer pas) >> return String
+
−    , try (string' "ansistring") >> optionMaybe (brackets pas $ integer pas) >> return AString
+
−    , 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
+
−            void $ iD
+
−            comments
+
−            string' "of"
+
−            comments
+
−            many unionCase
+
−        string' "end"
+
−        return $ RecordType vs union
+
−    setDecl = do
+
−        try $ string' "set" >> void space
+
−        comments
+
−        string' "of"
+
−        comments
+
−        liftM Set typeDecl
+
−    unionCase = do
+
−        void $ try $ commaSep pas $ (void $ iD) <|> (void $ integer pas)
+
−        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 :: Parsec String u [TypeVarDeclaration]
+
−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
+
−        void $ semi pas
+
−        comments
+
−        return $ TypeDeclaration i t
+
−
+
−rangeDecl :: Parsec String u Range
+
−rangeDecl = choice [
+
−    try $ rangeft
+
−    , iD >>= return . Range
+
−    ] <?> "range declaration"
+
−    where
+
−    rangeft = do
+
−        e1 <- initExpression
+
−        string' ".."
+
−        e2 <- initExpression
+
−        return $ RangeFromTo e1 e2
+
−
+
−typeVarDeclaration :: Bool -> Parsec String u [TypeVarDeclaration]
+
−typeVarDeclaration isImpl = (liftM concat . many . choice) [
+
−    varSection,
+
−    constSection,
+
−    typeSection,
+
−    funcDecl,
+
−    operatorDecl
+
−    ]
+
−    where
+
−
+
−    fixInit v = concat $ map (\x -> case x of
+
−                    VarDeclaration a b (ids, t) c ->
+
−                        let typeId = (Identifier ((\(Identifier i _) -> i) (head ids) ++ "_tt") BTUnknown) in
+
−                        let res =  [TypeDeclaration typeId t, VarDeclaration a b (ids, (SimpleType typeId)) c] in
+
−                        case t of
+
−                            RecordType _ _ -> res -- create a separated type declaration
+
−                            ArrayDecl _ _ -> res
+
−                            _ -> [x]
+
−                    _ -> error ("checkInit:\n" ++ (show v))) v
+
−
+
−    varSection = do
+
−        try $ string' "var"
+
−        comments
+
−        v <- varsDecl1 True <?> "variable declaration"
+
−        comments
+
−        return $ fixInit v
+
−
+
−    constSection = do
+
−        try $ string' "const"
+
−        comments
+
−        c <- constsDecl <?> "const declaration"
+
−        comments
+
−        return $ fixInit 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
+
−        -- ^^^^^^^^^^ wth was this???
+
−        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)
+
−        decorators <- many functionDecorator
+
−        let inline = any (== "inline;") decorators
+
−            overload = any (== "overload;") decorators
+
−            external = any (== "external;") decorators
+
−        -- TODO: don't mangle external functions names (and remove fpcrtl.h defines hacks)
+
−        b <- if isImpl && (not forward) && (not external) then
+
−                liftM Just functionBody
+
−                else
+
−                return Nothing
+
−        return $ [FunctionDeclaration i inline overload external 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 >> comments >>
+
−                optional (string' "name" >> comments >> stringLiteral pas) >> string' ";" >> return "external;"
+
−            ]
+
−        comments
+
−        return d
+
−
+
−
+
−program :: Parsec String u PascalUnit
+
−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 :: Parsec String u Interface
+
−interface = do
+
−    string' "interface"
+
−    comments
+
−    u <- uses
+
−    comments
+
−    tv <- typeVarDeclaration False
+
−    comments
+
−    return $ Interface u (TypesAndVars tv)
+
−
+
−implementation :: Parsec String u Implementation
+
−implementation = do
+
−    string' "implementation"
+
−    comments
+
−    u <- uses
+
−    comments
+
−    tv <- typeVarDeclaration True
+
−    string' "end."
+
−    comments
+
−    return $ Implementation u (TypesAndVars tv)
+
−
+
−expression :: Parsec String u Expression
+
−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 (reservedOp pas "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 :: Parsec String u Phrase
+
−phrasesBlock = do
+
−    try $ string' "begin"
+
−    comments
+
−    p <- manyTill phrase (try $ string' "end" >> notFollowedBy alphaNum)
+
−    comments
+
−    return $ Phrases p
+
−
+
−phrase :: Parsec String u Phrase
+
−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 :: Parsec String u Phrase
+
−ifBlock = do
+
−    try $ string "if" >> notFollowedBy (alphaNum <|> char '_')
+
−    comments
+
−    e <- expression
+
−    comments
+
−    string' "then"
+
−    comments
+
−    o1 <- phrase
+
−    comments
+
−    o2 <- optionMaybe $ do
+
−        try $ string' "else" >> void space
+
−        comments
+
−        o <- option NOP phrase
+
−        comments
+
−        return o
+
−    return $ IfThenElse e o1 o2
+
−
+
−whileCycle :: Parsec String u Phrase
+
−whileCycle = do
+
−    try $ string' "while"
+
−    comments
+
−    e <- expression
+
−    comments
+
−    string' "do"
+
−    comments
+
−    o <- phrase
+
−    return $ WhileCycle e o
+
−
+
−withBlock :: Parsec String u Phrase
+
−withBlock = do
+
−    try $ string' "with" >> void space
+
−    comments
+
−    rs <- (commaSep1 pas) reference
+
−    comments
+
−    string' "do"
+
−    comments
+
−    o <- phrase
+
−    return $ foldr WithBlock o rs
+
−
+
−repeatCycle :: Parsec String u Phrase
+
−repeatCycle = do
+
−    try $ string' "repeat" >> void space
+
−    comments
+
−    o <- many phrase
+
−    string' "until"
+
−    comments
+
−    e <- expression
+
−    comments
+
−    return $ RepeatCycle e o
+
−
+
−forCycle :: Parsec String u Phrase
+
−forCycle = do
+
−    try $ string' "for" >> void 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 :: Parsec String u Phrase
+
−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 :: Parsec String u Phrase
+
−procCall = do
+
−    r <- reference
+
−    p <- option [] $ (parens pas) parameters
+
−    return $ ProcCall r p
+
−
+
−parameters :: Parsec String u [Expression]
+
−parameters = (commaSep pas) expression <?> "parameters"
+
−
+
−functionBody :: Parsec String u (TypesAndVars, Phrase)
+
−functionBody = do
+
−    tv <- typeVarDeclaration True
+
−    comments
+
−    p <- phrasesBlock
+
−    char' ';'
+
−    comments
+
−    return (TypesAndVars tv, p)
+
−
+
−uses :: Parsec String u Uses
+
−uses = liftM Uses (option [] u)
+
−    where
+
−        u = do
+
−            string' "uses"
+
−            comments
+
−            ulist <- (iD >>= \i -> comments >> return i) `sepBy1` (char' ',' >> comments)
+
−            char' ';'
+
−            comments
+
−            return ulist
+
−
+
−initExpression :: Parsec String u InitExpression
+
−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 ((notRecord $ head ia) && (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
+
−        , try (string' "_S" >> stringLiteral pas) >>= return . InitString
+
−        , try (string' "_P" >> stringLiteral pas) >>= return . InitPChar
+
−        , 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
+
−        , try itypeCast
+
−        , iD >>= return . InitReference
+
−        ]
+
−
+
−    notRecord (InitRecord _) = False
+
−    notRecord _ = True
+
−
+
−    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
+
−        t <- iD
+
−        i <- parens pas initExpression
+
−        comments
+
−        return $ InitTypeCast t i
+
−
+
−builtInFunction :: Parsec String u a -> Parsec String u (String, [a])
+
−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 :: Parsec String u PascalUnit
+
−systemUnit = do
+
−    string' "system;"
+
−    comments
+
−    string' "type"
+
−    comments
+
−    t <- typesDecl
+
−    string' "var"
+
−    v <- varsDecl True
+
−    return $ System (t ++ v)
+
−
+
−redoUnit :: Parsec String u PascalUnit
+
−redoUnit = do
+
−    string' "redo;"
+
−    comments
+
−    string' "type"
+
−    comments
+
−    t <- typesDecl
+
−    string' "var"
+
−    v <- varsDecl True
+
−    return $ Redo (t ++ v)
+
−