# HG changeset patch
# User koda
# Date 1352075754 -3600
# Node ID 7fcbbd46704a2554642f03aad54b6c4b6f837d97
# Parent  b518458f83e6c557919bdc8b32d96e1c65a059bd
move pas2c files in their own directory and add a warning about argument order

diff -r b518458f83e6 -r 7fcbbd46704a tools/Main.hs
--- a/tools/Main.hs	Sun Nov 04 06:11:39 2012 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,44 +0,0 @@
-module Main( main ) where
-
-import System( getArgs )
-import System.Console.GetOpt
-import System.Environment
-import System.Exit
-import System.IO
-import Data.Maybe( fromMaybe )
-import Pas2C
-
-main = do
-    args <- getArgs
-    if length args == 0
-    then do
-        name <- getProgName
-        hPutStrLn stderr $ usageInfo header options
-        exitFailure
-    else do
-        case getOpt RequireOrder options args of
-          (flags, [],      [])     ->
-            if length args == 8 then do
-                pas2C (args !! 1) ((args !! 3)++"/") ((args !! 5)++"/") ((args !! 7)++"/")
-            else do
-                if length args == 6 then do
-                    pas2C (args !! 1) ((args !! 3)++"/") ((args !! 5)++"/") "./"
-                else do
-                    error $ usageInfo header options
-          (_,     nonOpts, [])     -> error $ "unrecognized arguments: " ++ unwords nonOpts
-          (_,     _,       msgs)   -> error $ usageInfo header options
-
-
-data Flag = HelpMessage | Name String | Input String | Output String | Alternate String
-
-options :: [OptDescr Flag]
-options = [
-    Option ['h'] ["help"]      (NoArg HelpMessage)      "print this help message",
-    Option ['n'] ["name"]      (ReqArg Name "MAIN")     "name of the main Pascal module",
-    Option ['i'] ["input"]     (ReqArg Input "DIR")     "input directory, where .pas files will be read",
-    Option ['o'] ["output"]    (ReqArg Output "DIR")    "output directory, where .c/.h files will be written",
-    Option ['a'] ["alternate"] (ReqArg Alternate "DIR") "alternate input directory, for out of source builds"
-  ]
-
-header = "Freepascal to C conversion!\n"
-
diff -r b518458f83e6 -r 7fcbbd46704a tools/PascalBasics.hs
--- a/tools/PascalBasics.hs	Sun Nov 04 06:11:39 2012 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,70 +0,0 @@
-{-# LANGUAGE FlexibleContexts #-}
-module PascalBasics where
-
-import Text.Parsec.Combinator
-import Text.Parsec.Char
-import Text.Parsec.Prim
-import Text.Parsec.Token
-import Text.Parsec.Language
-import Data.Char
-
-builtin = ["succ", "pred", "low", "high", "ord", "inc", "dec", "exit", "break", "continue", "length"]
-
-pascalLanguageDef
-    = emptyDef
-    { commentStart   = "(*"
-    , commentEnd     = "*)"
-    , commentLine    = "//"
-    , nestedComments = False
-    , identStart     = letter <|> oneOf "_"
-    , identLetter    = alphaNum <|> oneOf "_"
-    , reservedNames  = [
-            "begin", "end", "program", "unit", "interface"
-            , "implementation", "and", "or", "xor", "shl"
-            , "shr", "while", "do", "repeat", "until", "case", "of"
-            , "type", "var", "const", "out", "array", "packed"
-            , "procedure", "function", "with", "for", "to"
-            , "downto", "div", "mod", "record", "set", "nil"
-            , "cdecl", "external", "if", "then", "else"
-            ] -- ++ builtin
-    , reservedOpNames= []
-    , caseSensitive  = False
-    }
-
-preprocessorSwitch :: Stream s m Char => ParsecT s u m String
-preprocessorSwitch = do
-    try $ string "{$"
-    s <- manyTill (noneOf "\n") $ char '}'
-    return s
-
-caseInsensitiveString s = do
-    mapM_ (\a -> satisfy (\b -> toUpper a == toUpper b)) s <?> s
-    return s
-
-pas = patch $ makeTokenParser pascalLanguageDef
-    where
-    patch tp = tp {stringLiteral = stringL}
-
-comment = choice [
-        char '{' >> notFollowedBy (char '$') >> manyTill anyChar (try $ char '}')
-        , (try $ string "(*") >> manyTill anyChar (try $ string "*)")
-        , (try $ string "//") >> manyTill anyChar (try newline)
-        ]
-
-comments = do
-    spaces
-    skipMany $ do
-        preprocessorSwitch <|> comment
-        spaces
-
-stringL = do
-    (char '\'')
-    s <- (many $ noneOf "'")
-    (char '\'')
-    ss <- many $ do
-        (char '\'')
-        s' <- (many $ noneOf "'")
-        (char '\'')
-        return $ '\'' : s'
-    comments
-    return $ concat (s:ss)
diff -r b518458f83e6 -r 7fcbbd46704a tools/PascalParser.hs
--- a/tools/PascalParser.hs	Sun Nov 04 06:11:39 2012 +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)
-
diff -r b518458f83e6 -r 7fcbbd46704a tools/PascalPreprocessor.hs
--- a/tools/PascalPreprocessor.hs	Sun Nov 04 06:11:39 2012 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,135 +0,0 @@
-module PascalPreprocessor where
-
-import Text.Parsec
-import Control.Monad.IO.Class
-import Control.Monad
-import System.IO
-import qualified Data.Map as Map
-import Data.Char
-
-
--- comments are removed
-comment = choice [
-        char '{' >> notFollowedBy (char '$') >> manyTill anyChar (try $ char '}') >> return ""
-        , (try $ string "(*") >> manyTill anyChar (try $ string "*)") >> return ""
-        , (try $ string "//") >> manyTill anyChar (try newline) >> return "\n"
-        ]
-
-initDefines = Map.fromList [
-    ("FPC", "")
-    , ("PAS2C", "")
-    , ("ENDIAN_LITTLE", "")
-    , ("S3D_DISABLED", "")
-    ]
-
-preprocess :: String -> String -> String -> IO String
-preprocess inputPath alternateInputPath fn = do
-    r <- runParserT (preprocessFile (inputPath ++ fn)) (initDefines, [True]) "" ""
-    case r of
-         (Left a) -> do
-             hPutStrLn stderr (show a)
-             return ""
-         (Right a) -> return a
-
-    where
-    preprocessFile fn = do
-        f <- liftIO (readFile fn)
-        setInput f
-        preprocessor
-
-    preprocessor, codeBlock, switch :: ParsecT String (Map.Map String String, [Bool]) IO String
-
-    preprocessor = chainr codeBlock (return (++)) ""
-
-    codeBlock = do
-        s <- choice [
-            switch
-            , comment
-            , char '\'' >> many (noneOf "'\n") >>= \s -> char '\'' >> return ('\'' : s ++ "'")
-            , identifier >>= replace
-            , noneOf "{" >>= \a -> return [a]
-            ]
-        (_, ok) <- getState
-        return $ if and ok then s else ""
-
-    --otherChar c = c `notElem` "{/('_" && not (isAlphaNum c)
-    identifier = do
-        c <- letter <|> oneOf "_"
-        s <- many (alphaNum <|> oneOf "_")
-        return $ c:s
-
-    switch = do
-        try $ string "{$"
-        s <- choice [
-            include
-            , ifdef
-            , if'
-            , elseSwitch
-            , endIf
-            , define
-            , unknown
-            ]
-        return s
-
-    include = do
-        try $ string "INCLUDE"
-        spaces
-        (char '"')
-        fn <- many1 $ noneOf "\"\n"
-        char '"'
-        spaces
-        char '}'
-        f <- liftIO (readFile (inputPath ++ fn) `catch` (\exc -> readFile (alternateInputPath ++ fn) `catch` error ("File not found: " ++ fn)))
-        c <- getInput
-        setInput $ f ++ c
-        return ""
-
-    ifdef = do
-        s <- try (string "IFDEF") <|> try (string "IFNDEF")
-        let f = if s == "IFNDEF" then not else id
-
-        spaces
-        d <- identifier
-        spaces
-        char '}'
-
-        updateState $ \(m, b) ->
-            (m, (f $ d `Map.member` m) : b)
-
-        return ""
-
-    if' = do
-        s <- try (string "IF" >> notFollowedBy alphaNum)
-
-        manyTill anyChar (char '}')
-        --char '}'
-
-        updateState $ \(m, b) ->
-            (m, False : b)
-
-        return ""
-
-    elseSwitch = do
-        try $ string "ELSE}"
-        updateState $ \(m, b:bs) -> (m, (not b):bs)
-        return ""
-    endIf = do
-        try $ string "ENDIF}"
-        updateState $ \(m, b:bs) -> (m, bs)
-        return ""
-    define = do
-        try $ string "DEFINE"
-        spaces
-        i <- identifier
-        d <- ((string ":=" >> return ()) <|> spaces) >> many (noneOf "}")
-        char '}'
-        updateState $ \(m, b) -> (if (and b) && (head i /= '_') then Map.insert i d m else m, b)
-        return ""
-    replace s = do
-        (m, _) <- getState
-        return $ Map.findWithDefault s s m
-
-    unknown = do
-        fn <- many1 $ noneOf "}\n"
-        char '}'
-        return $ "{$" ++ fn ++ "}"
diff -r b518458f83e6 -r 7fcbbd46704a tools/PascalUnitSyntaxTree.hs
--- a/tools/PascalUnitSyntaxTree.hs	Sun Nov 04 06:11:39 2012 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,119 +0,0 @@
-module PascalUnitSyntaxTree where
-
-import Data.Maybe
-import Data.Char
-
-data PascalUnit =
-    Program Identifier Implementation Phrase
-    | Unit Identifier Interface Implementation (Maybe Initialize) (Maybe Finalize)
-    | System [TypeVarDeclaration]
-    | Redo [TypeVarDeclaration]
-    deriving Show
-data Interface = Interface Uses TypesAndVars
-    deriving Show
-data Implementation = Implementation Uses TypesAndVars
-    deriving Show
-data Identifier = Identifier String BaseType
-    deriving Show
-data TypesAndVars = TypesAndVars [TypeVarDeclaration]
-    deriving Show
-data TypeVarDeclaration = TypeDeclaration Identifier TypeDecl
-    | VarDeclaration Bool Bool ([Identifier], TypeDecl) (Maybe InitExpression)
-    | FunctionDeclaration Identifier Bool TypeDecl [TypeVarDeclaration] (Maybe (TypesAndVars, Phrase))
-    | OperatorDeclaration String Identifier Bool TypeDecl [TypeVarDeclaration] (Maybe (TypesAndVars, Phrase))
-    deriving Show
-data TypeDecl = SimpleType Identifier
-    | RangeType Range
-    | Sequence [Identifier]
-    | ArrayDecl (Maybe Range) TypeDecl
-    | RecordType [TypeVarDeclaration] (Maybe [[TypeVarDeclaration]])
-    | PointerTo TypeDecl
-    | String Integer
-    | Set TypeDecl
-    | FunctionType TypeDecl [TypeVarDeclaration]
-    | DeriveType InitExpression
-    | VoidType
-    | VarParamType TypeDecl -- this is a hack
-    deriving Show
-data Range = Range Identifier
-           | RangeFromTo InitExpression InitExpression
-           | RangeInfinite
-    deriving Show
-data Initialize = Initialize String
-    deriving Show
-data Finalize = Finalize String
-    deriving Show
-data Uses = Uses [Identifier]
-    deriving Show
-data Phrase = ProcCall Reference [Expression]
-        | IfThenElse Expression Phrase (Maybe Phrase)
-        | WhileCycle Expression Phrase
-        | RepeatCycle Expression [Phrase]
-        | ForCycle Identifier Expression Expression Phrase Bool -- The last Boolean indicates wether it's up or down counting
-        | WithBlock Reference Phrase
-        | Phrases [Phrase]
-        | SwitchCase Expression [([InitExpression], Phrase)] (Maybe [Phrase])
-        | Assignment Reference Expression
-        | BuiltInFunctionCall [Expression] Reference
-        | NOP
-    deriving Show
-data Expression = Expression String
-    | BuiltInFunCall [Expression] Reference
-    | PrefixOp String Expression
-    | PostfixOp String Expression
-    | BinOp String Expression Expression
-    | StringLiteral String
-    | PCharLiteral String
-    | CharCode String
-    | HexCharCode String
-    | NumberLiteral String
-    | FloatLiteral String
-    | HexNumber String
-    | Reference Reference
-    | SetExpression [Identifier]
-    | Null
-    deriving Show
-data Reference = ArrayElement [Expression] Reference
-    | FunCall [Expression] Reference
-    | TypeCast Identifier Expression
-    | SimpleReference Identifier
-    | Dereference Reference
-    | RecordField Reference Reference
-    | Address Reference
-    | RefExpression Expression
-    deriving Show
-data InitExpression = InitBinOp String InitExpression InitExpression
-    | InitPrefixOp String InitExpression
-    | InitReference Identifier
-    | InitArray [InitExpression]
-    | InitRecord [(Identifier, InitExpression)]
-    | InitFloat String
-    | InitNumber String
-    | InitHexNumber String
-    | InitString String
-    | InitChar String
-    | BuiltInFunction String [InitExpression]
-    | InitSet [InitExpression]
-    | InitAddress InitExpression
-    | InitNull
-    | InitRange Range
-    | InitTypeCast Identifier InitExpression
-    deriving Show
-
-data BaseType = BTUnknown
-    | BTChar
-    | BTString
-    | BTInt
-    | BTBool
-    | BTFloat
-    | BTRecord String [(String, BaseType)]
-    | BTArray Range BaseType BaseType
-    | BTFunction Bool Int BaseType
-    | BTPointerTo BaseType
-    | BTUnresolved String
-    | BTSet BaseType
-    | BTEnum [String]
-    | BTVoid
-    | BTUnit
-    | BTVarParam BaseType
-    deriving Show
diff -r b518458f83e6 -r 7fcbbd46704a tools/pas2c.hs
--- a/tools/pas2c.hs	Sun Nov 04 06:11:39 2012 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,1085 +0,0 @@
-{-# LANGUAGE ScopedTypeVariables #-}
-module Pas2C where
-
-import Text.PrettyPrint.HughesPJ
-import Data.Maybe
-import Data.Char
-import Text.Parsec.Prim hiding (State)
-import Control.Monad.State
-import System.IO
-import System.Directory
-import Control.Monad.IO.Class
-import PascalPreprocessor
-import Control.Exception
-import System.IO.Error
-import qualified Data.Map as Map
-import qualified Data.Set as Set
-import Data.List (find)
-import Numeric
-
-import PascalParser(pascalUnit)
-import PascalUnitSyntaxTree
-
-
-data InsertOption =
-    IOInsert
-    | IOInsertWithType Doc
-    | IOLookup
-    | IOLookupLast
-    | IOLookupFunction Int
-    | IODeferred
-
-data Record = Record
-    {
-        lcaseId :: String,
-        baseType :: BaseType,
-        typeDecl :: Doc
-    }
-    deriving Show
-type Records = Map.Map String [Record]
-data RenderState = RenderState
-    {
-        currentScope :: Records,
-        lastIdentifier :: String,
-        lastType :: BaseType,
-        lastIdTypeDecl :: Doc,
-        stringConsts :: [(String, String)],
-        uniqCounter :: Int,
-        toMangle :: Set.Set String,
-        currentUnit :: String,
-        currentFunctionResult :: String,
-        namespaces :: Map.Map String Records
-    }
-
-rec2Records = map (\(a, b) -> Record a b empty)
-
-emptyState = RenderState Map.empty "" BTUnknown empty [] 0 Set.empty "" ""
-
-getUniq :: State RenderState Int
-getUniq = do
-    i <- gets uniqCounter
-    modify(\s -> s{uniqCounter = uniqCounter s + 1})
-    return i
-
-addStringConst :: String -> State RenderState Doc
-addStringConst str = do
-    strs <- gets stringConsts
-    let a = find ((==) str . snd) strs
-    if isJust a then
-        do
-        modify (\s -> s{lastType = BTString})
-        return . text . fst . fromJust $ a
-    else
-        do
-        i <- getUniq
-        let sn = "__str" ++ show i
-        modify (\s -> s{lastType = BTString, stringConsts = (sn, str) : strs})
-        return $ text sn
-
-escapeStr :: String -> String
-escapeStr = foldr escapeChar []
-
-escapeChar :: Char -> ShowS
-escapeChar '"' s = "\\\"" ++ s
-escapeChar '\\' s = "\\\\" ++ s
-escapeChar a s = a : s
-
-strInit :: String -> Doc
-strInit a = text "STRINIT" <> parens (doubleQuotes (text $ escapeStr a))
-
-renderStringConsts :: State RenderState Doc
-renderStringConsts = liftM (vcat . map (\(a, b) -> text "static const string255" <+> (text a) <+> text "=" <+> strInit b <> semi))
-    $ gets stringConsts
-
-docToLower :: Doc -> Doc
-docToLower = text . map toLower . render
-
-pas2C :: String -> String -> String -> String -> IO ()
-pas2C fn inputPath alternateInputPath outputPath = do
-    s <- flip execStateT initState $ f fn
-    renderCFiles s outputPath
-    where
-    printLn = liftIO . hPutStrLn stdout
-    print = liftIO . hPutStr stdout
-    initState = Map.empty
-    f :: String -> StateT (Map.Map String PascalUnit) IO ()
-    f fileName = do
-        processed <- gets $ Map.member fileName
-        unless processed $ do
-            print ("Preprocessing '" ++ fileName ++ ".pas'... ")
-            fc' <- liftIO
-                $ tryJust (guard . isDoesNotExistError)
-                $ preprocess inputPath alternateInputPath (fileName ++ ".pas")
-            case fc' of
-                (Left a) -> do
-                    modify (Map.insert fileName (System []))
-                    printLn "doesn't exist"
-                (Right fc) -> do
-                    print "ok, parsing... "
-                    let ptree = parse pascalUnit fileName fc
-                    case ptree of
-                         (Left a) -> do
-                            liftIO $ writeFile (outputPath ++ "preprocess.out") fc
-                            printLn $ show a ++ "\nsee preprocess.out for preprocessed source"
-                            fail "stop"
-                         (Right a) -> do
-                            printLn "ok"
-                            modify (Map.insert fileName a)
-                            mapM_ f (usesFiles a)
-
-
-renderCFiles :: Map.Map String PascalUnit -> String -> IO ()
-renderCFiles units outputPath = do
-    let u = Map.toList units
-    let nss = Map.map (toNamespace nss) units
-    --hPutStrLn stderr $ "Units: " ++ (show . Map.keys . Map.filter (not . Map.null) $ nss)
-    --writeFile "pas2c.log" $ unlines . map (\t -> show (fst t) ++ "\n" ++ (unlines . map ((:) '\t' . show) . snd $ t)) . Map.toList $ nss
-    mapM_ (toCFiles outputPath nss) u
-    where
-    toNamespace :: Map.Map String Records -> PascalUnit -> Records
-    toNamespace nss (System tvs) =
-        currentScope $ execState f (emptyState nss)
-        where
-        f = do
-            checkDuplicateFunDecls tvs
-            mapM_ (tvar2C True False True False) tvs
-    toNamespace nss (Redo tvs) = -- functions that are re-implemented, add prefix to all of them
-        currentScope $ execState f (emptyState nss){currentUnit = "fpcrtl_"}
-        where
-        f = do
-            checkDuplicateFunDecls tvs
-            mapM_ (tvar2C True False True False) tvs
-    toNamespace _ (Program {}) = Map.empty
-    toNamespace nss (Unit (Identifier i _) interface _ _ _) =
-        currentScope $ execState (interface2C interface True) (emptyState nss){currentUnit = map toLower i ++ "_"}
-
-
-withState' :: (RenderState -> RenderState) -> State RenderState a -> State RenderState a
-withState' f sf = do
-    st <- liftM f get
-    let (a, s) = runState sf st
-    modify(\st -> st{
-        lastType = lastType s
-        , uniqCounter = uniqCounter s
-        , stringConsts = stringConsts s
-        })
-    return a
-
-withLastIdNamespace f = do
-    li <- gets lastIdentifier
-    nss <- gets namespaces
-    withState' (\st -> st{currentScope = fromMaybe Map.empty $ Map.lookup li (namespaces st)}) f
-
-withRecordNamespace :: String -> [Record] -> State RenderState Doc -> State RenderState Doc
-withRecordNamespace _ [] = error "withRecordNamespace: empty record"
-withRecordNamespace prefix recs = withState' f
-    where
-        f st = st{currentScope = Map.unionWith un records (currentScope st), currentUnit = ""}
-        records = Map.fromList $ map (\(Record a b d) -> (map toLower a, [Record (prefix ++ a) b d])) recs
-        un [a] b = a : b
-
-toCFiles :: String -> Map.Map String Records -> (String, PascalUnit) -> IO ()
-toCFiles _ _ (_, System _) = return ()
-toCFiles _ _ (_, Redo _) = return ()
-toCFiles outputPath ns p@(fn, pu) = do
-    hPutStrLn stdout $ "Rendering '" ++ fn ++ "'..."
-    toCFiles' p
-    where
-    toCFiles' (fn, p@(Program {})) = writeFile (outputPath ++ fn ++ ".c") $ "#include \"fpcrtl.h\"\n" ++ (render2C initialState . pascal2C) p
-    toCFiles' (fn, (Unit unitId@(Identifier i _) interface implementation _ _)) = do
-        let (a, s) = runState (id2C IOInsert (setBaseType BTUnit unitId) >> interface2C interface True) initialState{currentUnit = map toLower i ++ "_"}
-            (a', s') = runState (id2C IOInsert (setBaseType BTUnit unitId) >> interface2C interface False) initialState{currentUnit = map toLower i ++ "_"}
-        writeFile (outputPath ++ fn ++ ".h") $ "#pragma once\n\n#include \"pas2c.h\"\n\n" ++ (render (a $+$ text ""))
-        writeFile (outputPath ++ fn ++ ".c") $ "#include \"fpcrtl.h\"\n\n#include \"" ++ fn ++ ".h\"\n" ++ render (a' $+$ text "") ++ (render2C s . implementation2C) implementation
-    initialState = emptyState ns
-
-    render2C :: RenderState -> State RenderState Doc -> String
-    render2C a = render . ($+$ empty) . flip evalState a
-
-
-usesFiles :: PascalUnit -> [String]
-usesFiles (Program _ (Implementation uses _) _) = ["pas2cSystem", "pas2cRedo"] ++ uses2List uses
-usesFiles (Unit _ (Interface uses1 _) (Implementation uses2 _) _ _) = ["pas2cSystem", "pas2cRedo"] ++ uses2List uses1 ++ uses2List uses2
-usesFiles (System {}) = []
-usesFiles (Redo {}) = []
-
-pascal2C :: PascalUnit -> State RenderState Doc
-pascal2C (Unit _ interface implementation init fin) =
-    liftM2 ($+$) (interface2C interface True) (implementation2C implementation)
-
-pascal2C (Program _ implementation mainFunction) = do
-    impl <- implementation2C implementation
-    [main] <- tvar2C True False True True (FunctionDeclaration (Identifier "main" BTInt) False (SimpleType $ Identifier "int" BTInt) [VarDeclaration False False ([Identifier "argc" BTInt], SimpleType (Identifier "Integer" BTInt)) Nothing, VarDeclaration False False ([Identifier "argv" BTUnknown], SimpleType (Identifier "PPChar" BTUnknown)) Nothing] (Just (TypesAndVars [], mainFunction)))
-    return $ impl $+$ main
-
-
--- the second bool indicates whether do normal interface translation or generate variable declarations
--- that will be inserted into implementation files
-interface2C :: Interface -> Bool -> State RenderState Doc
-interface2C (Interface uses tvars) True = do
-    u <- uses2C uses
-    tv <- typesAndVars2C True True True tvars
-    r <- renderStringConsts
-    return (u $+$ r $+$ tv)
-interface2C (Interface uses tvars) False = do
-    u <- uses2C uses
-    tv <- typesAndVars2C True False False tvars
-    r <- renderStringConsts
-    return tv
-
-implementation2C :: Implementation -> State RenderState Doc
-implementation2C (Implementation uses tvars) = do
-    u <- uses2C uses
-    tv <- typesAndVars2C True False True tvars
-    r <- renderStringConsts
-    return (u $+$ r $+$ tv)
-
-checkDuplicateFunDecls :: [TypeVarDeclaration] -> State RenderState ()
-checkDuplicateFunDecls tvs =
-    modify $ \s -> s{toMangle = Map.keysSet . Map.filter (> 1) . foldr ins initMap $ tvs}
-    where
-        initMap = Map.empty
-        --initMap = Map.fromList [("reset", 2)]
-        ins (FunctionDeclaration (Identifier i _) _ _ _ _) m = Map.insertWith (+) (map toLower i) 1 m
-        ins _ m = m
-
--- the second bool indicates whether declare variable as extern or not
--- the third bool indicates whether include types or not
-
-typesAndVars2C :: Bool -> Bool -> Bool -> TypesAndVars -> State RenderState Doc
-typesAndVars2C b externVar includeType(TypesAndVars ts) = do
-    checkDuplicateFunDecls ts
-    liftM (vcat . map (<> semi) . concat) $ mapM (tvar2C b externVar includeType False) ts
-
-setBaseType :: BaseType -> Identifier -> Identifier
-setBaseType bt (Identifier i _) = Identifier i bt
-
-uses2C :: Uses -> State RenderState Doc
-uses2C uses@(Uses unitIds) = do
-
-    mapM_ injectNamespace (Identifier "pas2cSystem" undefined : unitIds)
-    mapM_ injectNamespace (Identifier "pas2cRedo" undefined : unitIds)
-    mapM_ (id2C IOInsert . setBaseType BTUnit) unitIds
-    return $ vcat . map (\i -> text $ "#include \"" ++ i ++ ".h\"") $ uses2List uses
-    where
-    injectNamespace (Identifier i _) = do
-        getNS <- gets (flip Map.lookup . namespaces)
-        modify (\s -> s{currentScope = Map.unionWith (++) (fromMaybe Map.empty (getNS i)) $ currentScope s})
-
-uses2List :: Uses -> [String]
-uses2List (Uses ids) = map (\(Identifier i _) -> i) ids
-
-
-setLastIdValues vv = (\s -> s{lastType = baseType vv, lastIdentifier = lcaseId vv, lastIdTypeDecl = typeDecl vv})
-
-id2C :: InsertOption -> Identifier -> State RenderState Doc
-id2C IOInsert i = id2C (IOInsertWithType empty) i
-id2C (IOInsertWithType d) (Identifier i t) = do
-    ns <- gets currentScope
-    tom <- gets (Set.member n . toMangle)
-    cu <- gets currentUnit
-    let (i', t') = case (t, tom) of
-            (BTFunction _ p _, True) -> (cu ++ i ++ ('_' : show p), t)
-            (BTFunction _ _ _, _) -> (cu ++ i, t)
-            (BTVarParam t', _) -> ('(' : '*' : i ++ ")" , t')
-            _ -> (i, t)
-    modify (\s -> s{currentScope = Map.insertWith (++) n [Record i' t' d] (currentScope s), lastIdentifier = n})
-    return $ text i'
-    where
-        n = map toLower i
-
-id2C IOLookup i = id2CLookup head i
-id2C IOLookupLast i = id2CLookup last i
-id2C (IOLookupFunction params) (Identifier i t) = do
-    let i' = map toLower i
-    v <- gets $ Map.lookup i' . currentScope
-    lt <- gets lastType
-    if isNothing v then
-        error $ "Not defined: '" ++ i' ++ "'\n" ++ show lt ++ "\nwith num of params = " ++ show params ++ "\n" ++ show v
-        else
-        let vv = fromMaybe (head $ fromJust v) . find checkParam $ fromJust v in
-            modify (setLastIdValues vv) >> (return . text . lcaseId $ vv)
-    where
-        checkParam (Record _ (BTFunction _ p _) _) = p == params
-        checkParam _ = False
-id2C IODeferred (Identifier i t) = do
-    let i' = map toLower i
-    v <- gets $ Map.lookup i' . currentScope
-    if (isNothing v) then
-        modify (\s -> s{lastType = BTUnknown, lastIdentifier = i}) >> return (text i)
-        else
-        let vv = head $ fromJust v in modify (setLastIdValues vv) >> (return . text . lcaseId $ vv)
-
-id2CLookup :: ([Record] -> Record) -> Identifier -> State RenderState Doc
-id2CLookup f (Identifier i t) = do
-    let i' = map toLower i
-    v <- gets $ Map.lookup i' . currentScope
-    lt <- gets lastType
-    if isNothing v then
-        error $ "Not defined: '" ++ i' ++ "'\n" ++ show lt
-        else
-        let vv = f $ fromJust v in modify (setLastIdValues vv) >> (return . text . lcaseId $ vv)
-
-
-id2CTyped :: TypeDecl -> Identifier -> State RenderState Doc
-id2CTyped = id2CTyped2 Nothing
-
-id2CTyped2 :: Maybe Doc -> TypeDecl -> Identifier -> State RenderState Doc
-id2CTyped2 md t (Identifier i _) = do
-    tb <- resolveType t
-    case (t, tb) of
-        (_, BTUnknown) -> do
-            error $ "id2CTyped: type BTUnknown for " ++ show i ++ "\ntype: " ++ show t
-        (SimpleType {}, BTRecord _ r) -> do
-            ts <- type2C t
-            id2C (IOInsertWithType $ ts empty) (Identifier i (BTRecord (render $ ts empty) r))
-        (_, BTRecord _ r) -> do
-            ts <- type2C t
-            id2C (IOInsertWithType $ ts empty) (Identifier i (BTRecord i r))
-        _ -> case md of
-                Nothing -> id2C IOInsert (Identifier i tb)
-                Just ts -> id2C (IOInsertWithType ts) (Identifier i tb)
-
-
-resolveType :: TypeDecl -> State RenderState BaseType
-resolveType st@(SimpleType (Identifier i _)) = do
-    let i' = map toLower i
-    v <- gets $ Map.lookup i' . currentScope
-    if isJust v then return . baseType . head $ fromJust v else return $ f i'
-    where
-    f "integer" = BTInt
-    f "pointer" = BTPointerTo BTVoid
-    f "boolean" = BTBool
-    f "float" = BTFloat
-    f "char" = BTChar
-    f "string" = BTString
-    f _ = error $ "Unknown system type: " ++ show st
-resolveType (PointerTo (SimpleType (Identifier i _))) = return . BTPointerTo $ BTUnresolved (map toLower i)
-resolveType (PointerTo t) = liftM BTPointerTo $ resolveType t
-resolveType (RecordType tv mtvs) = do
-    tvs <- mapM f (concat $ tv : fromMaybe [] mtvs)
-    return . BTRecord "" . concat $ tvs
-    where
-        f :: TypeVarDeclaration -> State RenderState [(String, BaseType)]
-        f (VarDeclaration _ _ (ids, td) _) = mapM (\(Identifier i _) -> liftM ((,) i) $ resolveType td) ids
-resolveType (ArrayDecl (Just i) t) = do
-    t' <- resolveType t
-    return $ BTArray i BTInt t'
-resolveType (ArrayDecl Nothing t) = liftM (BTArray RangeInfinite BTInt) $ resolveType t
-resolveType (FunctionType t a) = liftM (BTFunction False (length a)) $ resolveType t
-resolveType (DeriveType (InitHexNumber _)) = return BTInt
-resolveType (DeriveType (InitNumber _)) = return BTInt
-resolveType (DeriveType (InitFloat _)) = return BTFloat
-resolveType (DeriveType (InitString _)) = return BTString
-resolveType (DeriveType (InitBinOp {})) = return BTInt
-resolveType (DeriveType (InitPrefixOp _ e)) = initExpr2C e >> gets lastType
-resolveType (DeriveType (BuiltInFunction{})) = return BTInt
-resolveType (DeriveType (InitReference (Identifier{}))) = return BTBool -- TODO: derive from actual type
-resolveType (DeriveType _) = return BTUnknown
-resolveType (String _) = return BTString
-resolveType VoidType = return BTVoid
-resolveType (Sequence ids) = return $ BTEnum $ map (\(Identifier i _) -> map toLower i) ids
-resolveType (RangeType _) = return $ BTVoid
-resolveType (Set t) = liftM BTSet $ resolveType t
-resolveType (VarParamType t) = liftM BTVarParam $ resolveType t
-
-
-resolve :: String -> BaseType -> State RenderState BaseType
-resolve s (BTUnresolved t) = do
-    v <- gets $ Map.lookup t . currentScope
-    if isJust v then
-        resolve s . baseType . head . fromJust $ v
-        else
-        error $ "Unknown type " ++ show t ++ "\n" ++ s
-resolve _ t = return t
-
-fromPointer :: String -> BaseType -> State RenderState BaseType
-fromPointer s (BTPointerTo t) = resolve s t
-fromPointer s t = do
-    error $ "Dereferencing from non-pointer type " ++ show t ++ "\n" ++ s
-
-
-functionParams2C params = liftM (hcat . punctuate comma . concat) $ mapM (tvar2C False False True True) params
-
-numberOfDeclarations :: [TypeVarDeclaration] -> Int
-numberOfDeclarations = sum . map cnt
-    where
-        cnt (VarDeclaration _ _ (ids, _) _) = length ids
-        cnt _ = 1
-
-hasPassByReference :: [TypeVarDeclaration] -> Bool
-hasPassByReference = or . map isVar
-    where
-        isVar (VarDeclaration v _ (_, _) _) = v
-        isVar _ = error $ "hasPassByReference called not on function parameters"
-
-toIsVarList :: [TypeVarDeclaration] -> [Bool]
-toIsVarList = concatMap isVar
-    where
-        isVar (VarDeclaration v _ (p, _) _) = replicate (length p) v
-        isVar _ = error $ "toIsVarList called not on function parameters"
-
-
-funWithVarsToDefine :: String -> [TypeVarDeclaration] -> Doc
-funWithVarsToDefine n params = text "#define" <+> text n <> parens abc <+> text (n ++ "__vars") <> parens cparams
-    where
-        abc = hcat . punctuate comma . map (char . fst) $ ps
-        cparams = hcat . punctuate comma . map (\(c, v) -> if v then char '&' <> parens (char c) else char c) $ ps
-        ps = zip ['a'..] (toIsVarList params)
-
-fun2C :: Bool -> String -> TypeVarDeclaration -> State RenderState [Doc]
-fun2C _ _ (FunctionDeclaration name inline returnType params Nothing) = do
-    t <- type2C returnType
-    t'<- gets lastType
-    p <- withState' id $ functionParams2C params
-    n <- liftM render . id2C IOInsert $ setBaseType (BTFunction hasVars (numberOfDeclarations params) t') name
-    let decor = if inline then text "inline" else empty
-    if hasVars then
-        return [funWithVarsToDefine n params $+$ decor <+> t empty <+> text (n ++ "__vars") <> parens p]
-        else
-        return [decor <+> t empty <+> text n <> parens p]
-    where
-        hasVars = hasPassByReference params
-
-
-fun2C True rv (FunctionDeclaration name@(Identifier i _) inline returnType params (Just (tvars, phrase))) = do
-    let res = docToLower $ text rv <> text "_result"
-    t <- type2C returnType
-    t'<- gets lastType
-
-    notDeclared <- liftM isNothing . gets $ Map.lookup (map toLower i) . currentScope
-
-    n <- liftM render . id2C IOInsert $ setBaseType (BTFunction hasVars (numberOfDeclarations params) t') name
-
-    let isVoid = case returnType of
-            VoidType -> True
-            _ -> False
-
-    (p, ph) <- withState' (\st -> st{currentScope = Map.insertWith un (map toLower rv) [Record (render res) t' empty] $ currentScope st
-            , currentFunctionResult = if isVoid then [] else render res}) $ do
-        p <- functionParams2C params
-        ph <- liftM2 ($+$) (typesAndVars2C False False True tvars) (phrase2C' phrase)
-        return (p, ph)
-
-    let phrasesBlock = if isVoid then ph else t empty <+> res <> semi $+$ ph $+$ text "return" <+> res <> semi
-    let define = if hasVars then text "#ifndef" <+> text n $+$ funWithVarsToDefine n params $+$ text "#endif" else empty
-    let decor = if inline then text "inline" else empty
-    return [
-        define
-        $+$
-        --(if notDeclared && hasVars then funWithVarsToDefine n params else empty) $+$
-        decor <+> t empty <+> text (if hasVars then n ++ "__vars" else n) <> parens p
-        $+$
-        text "{"
-        $+$
-        nest 4 phrasesBlock
-        $+$
-        text "}"]
-    where
-    phrase2C' (Phrases p) = liftM vcat $ mapM phrase2C p
-    phrase2C' p = phrase2C p
-    un [a] b = a : b
-    hasVars = hasPassByReference params
-
-fun2C False _ (FunctionDeclaration (Identifier name _) _ _ _ _) = error $ "nested functions not allowed: " ++ name
-fun2C _ tv _ = error $ "fun2C: I don't render " ++ show tv
-
--- the second bool indicates whether declare variable as extern or not
--- the third bool indicates whether include types or not
--- the fourth bool indicates whether ignore initialization or not (basically for dynamic arrays since we cannot do initialization in function params)
-tvar2C :: Bool -> Bool -> Bool -> Bool -> TypeVarDeclaration -> State RenderState [Doc]
-tvar2C b _ includeType _ f@(FunctionDeclaration (Identifier name _) _ _ _ _) = do
-    t <- fun2C b name f
-    if includeType then return t else return []
-tvar2C _ _ includeType _ td@(TypeDeclaration i' t) = do
-    i <- id2CTyped t i'
-    tp <- type2C t
-    return $ if includeType then [text "typedef" <+> tp i] else []
-
-tvar2C _ _ _ _ (VarDeclaration True _ (ids, t) Nothing) = do
-    t' <- liftM ((empty <+>) . ) $ type2C t
-    liftM (map(\i -> t' i)) $ mapM (id2CTyped2 (Just $ t' empty) (VarParamType t)) ids
-
-tvar2C _ externVar includeType ignoreInit (VarDeclaration _ isConst (ids, t) mInitExpr) = do
-    t' <- liftM (((if isConst then text "static const" else if externVar 
-                                                                then text "extern"
-                                                                else empty)
-                   <+>) . ) $ type2C t
-    ie <- initExpr mInitExpr
-    lt <- gets lastType
-    case (isConst, lt, ids, mInitExpr) of
-         (True, BTInt, [i], Just _) -> do
-             i' <- id2CTyped t i
-             return $ if includeType then [text "enum" <> braces (i' <+> ie)] else []
-         (True, BTFloat, [i], Just e) -> do
-             i' <- id2CTyped t i
-             ie <- initExpr2C e
-             return $ if includeType then [text "#define" <+> i' <+> parens ie <> text "\n"] else []
-         (_, BTFunction{}, _, Nothing) -> liftM (map(\i -> t' i)) $ mapM (id2CTyped t) ids
-         (_, BTArray r _ _, [i], _) -> do
-            i' <- id2CTyped t i
-            ie' <- return $ case (r, mInitExpr, ignoreInit) of
-                (RangeInfinite, Nothing, False) -> text "= NULL" -- force dynamic array to be initialized as NULL if not initialized at all
-                (_, _, _) -> ie
-            result <- liftM (map(\i -> varDeclDecision isConst includeType (t' i) ie')) $ mapM (id2CTyped t) ids           
-            case (r, ignoreInit) of
-                (RangeInfinite, False) -> 
-                    -- if the array is dynamic, add dimension info to it
-                    return $ [dimDecl] ++ result
-                    where 
-                        arrayDimStr = show $ arrayDimension t
-                        arrayDimInitExp = text ("={" ++ ".dim = " ++ arrayDimStr ++ ", .a = {0, 0, 0, 0}}")
-                        dimDecl = varDeclDecision isConst includeType (text "fpcrtl_dimension_t" <+>  i' <> text "_dimension_info") arrayDimInitExp
-                    
-                (_, _) -> return result
-            
-         _ -> liftM (map(\i -> varDeclDecision isConst includeType (t' i) ie)) $ mapM (id2CTyped2 (Just $ t' empty) t) ids
-    where
-    initExpr Nothing = return $ empty
-    initExpr (Just e) = liftM (text "=" <+>) (initExpr2C e)
-    varDeclDecision True True varStr expStr = varStr <+> expStr
-    varDeclDecision False True varStr expStr = if externVar then varStr else varStr <+> expStr
-    varDeclDecision False False varStr expStr = varStr <+> expStr
-    varDeclDecision True False varStr expStr = empty
-    arrayDimension a = case a of
-        ArrayDecl Nothing t -> let a = arrayDimension t in if a > 3 then error "Dynamic array with dimension > 4 is not supported." else 1 + arrayDimension t
-        ArrayDecl _ _ -> error "Mixed dynamic array and static array are not supported."
-        _ -> 0
-
-tvar2C f _ _ _ (OperatorDeclaration op (Identifier i _) inline ret params body) = do
-    r <- op2CTyped op (extractTypes params)
-    fun2C f i (FunctionDeclaration r inline ret params body)
-
-
-op2CTyped :: String -> [TypeDecl] -> State RenderState Identifier
-op2CTyped op t = do
-    t' <- liftM (render . hcat . punctuate (char '_') . map (\t -> t empty)) $ mapM type2C t
-    bt <- gets lastType
-    return $ Identifier (t' ++ "_op_" ++ opStr) bt
-    where
-    opStr = case op of
-                    "+" -> "add"
-                    "-" -> "sub"
-                    "*" -> "mul"
-                    "/" -> "div"
-                    "/(float)" -> "div"
-                    "=" -> "eq"
-                    "<" -> "lt"
-                    ">" -> "gt"
-                    "<>" -> "neq"
-                    _ -> error $ "op2CTyped: unknown op '" ++ op ++ "'"
-
-extractTypes :: [TypeVarDeclaration] -> [TypeDecl]
-extractTypes = concatMap f
-    where
-        f (VarDeclaration _ _ (ids, t) _) = replicate (length ids) t
-        f a = error $ "extractTypes: can't extract from " ++ show a
-
-initExpr2C, initExpr2C' :: InitExpression -> State RenderState Doc
-initExpr2C (InitArray values) = liftM (braces . vcat . punctuate comma) $ mapM initExpr2C values
-initExpr2C a = initExpr2C' a
-initExpr2C' InitNull = return $ text "NULL"
-initExpr2C' (InitAddress expr) = do
-    ie <- initExpr2C' expr
-    lt <- gets lastType
-    case lt of
-        BTFunction True _ _ -> return $ text "&" <> ie <> text "__vars"
-        _ -> return $ text "&" <> ie
-initExpr2C' (InitPrefixOp op expr) = liftM (text (op2C op) <>) (initExpr2C' expr)
-initExpr2C' (InitBinOp op expr1 expr2) = do
-    e1 <- initExpr2C' expr1
-    e2 <- initExpr2C' expr2
-    return $ parens $ e1 <+> text (op2C op) <+> e2
-initExpr2C' (InitNumber s) = return $ text s
-initExpr2C' (InitFloat s) = return $ text s
-initExpr2C' (InitHexNumber s) = return $ text "0x" <> (text . map toLower $ s)
-initExpr2C' (InitString [a]) = return . quotes $ text [a]
-initExpr2C' (InitString s) = return $ strInit s
-initExpr2C' (InitChar a) = return $ quotes $ text "\\x" <> text (showHex (read a) "")
-initExpr2C' (InitReference i) = id2C IOLookup i
-initExpr2C' (InitRecord fields) = do
-    (fs :: [Doc]) <- mapM (\(Identifier a _, b) -> liftM (text "." <> text a <+> equals <+>) $ initExpr2C b) fields
-    return $ lbrace $+$ (nest 4 . vcat . punctuate comma $ fs) $+$ rbrace
-initExpr2C' (InitArray [value]) = initExpr2C value
-initExpr2C' r@(InitRange (Range i@(Identifier i' _))) = do
-    id2C IOLookup i
-    t <- gets lastType
-    case t of
-         BTEnum s -> return . int $ length s
-         BTInt -> case i' of
-                       "byte" -> return $ int 256
-                       _ -> error $ "InitRange identifier: " ++ i'
-         _ -> error $ "InitRange: " ++ show r
-initExpr2C' (InitRange (RangeFromTo (InitNumber "0") r)) = initExpr2C $ BuiltInFunction "succ" [r]
-initExpr2C' (InitRange (RangeFromTo (InitChar "0") (InitChar r))) = initExpr2C $ BuiltInFunction "succ" [InitNumber r]
-initExpr2C' (InitRange a) = error $ show a --return $ text "<<range>>"
-initExpr2C' (InitSet []) = return $ text "0"
-initExpr2C' (InitSet a) = return $ text "<<set>>"
-initExpr2C' (BuiltInFunction "low" [InitReference e]) = return $
-    case e of
-         (Identifier "LongInt" _) -> int (-2^31)
-         (Identifier "SmallInt" _) -> int (-2^15)
-         _ -> error $ "BuiltInFunction 'low': " ++ show e
-initExpr2C' (BuiltInFunction "high" [e]) = do
-    initExpr2C e
-    t <- gets lastType
-    case t of
-         (BTArray i _ _) -> initExpr2C' $ BuiltInFunction "pred" [InitRange i]
-         a -> error $ "BuiltInFunction 'high': " ++ show a
-initExpr2C' (BuiltInFunction "succ" [BuiltInFunction "pred" [e]]) = initExpr2C' e
-initExpr2C' (BuiltInFunction "pred" [BuiltInFunction "succ" [e]]) = initExpr2C' e
-initExpr2C' (BuiltInFunction "succ" [e]) = liftM (<> text " + 1") $ initExpr2C' e
-initExpr2C' (BuiltInFunction "pred" [e]) = liftM (<> text " - 1") $ initExpr2C' e
-initExpr2C' b@(BuiltInFunction _ _) = error $ show b
-initExpr2C' a = error $ "initExpr2C: don't know how to render " ++ show a
-
-
-range2C :: InitExpression -> State RenderState [Doc]
-range2C (InitString [a]) = return [quotes $ text [a]]
-range2C (InitRange (Range i)) = liftM (flip (:) []) $ id2C IOLookup i
-range2C (InitRange (RangeFromTo (InitString [a]) (InitString [b]))) = return $ map (\i -> quotes $ text [i]) [a..b]
-range2C a = liftM (flip (:) []) $ initExpr2C a
-
-baseType2C :: String -> BaseType -> Doc
-baseType2C _ BTFloat = text "float"
-baseType2C _ BTBool = text "bool"
-baseType2C _ BTString = text "string255"
-baseType2C s a = error $ "baseType2C: " ++ show a ++ "\n" ++ s
-
-type2C :: TypeDecl -> State RenderState (Doc -> Doc)
-type2C (SimpleType i) = liftM (\i a -> i <+> a) $ id2C IOLookup i
-type2C t = do
-    r <- type2C' t
-    rt <- resolveType t
-    modify (\st -> st{lastType = rt})
-    return r
-    where
-    type2C' VoidType = return (text "void" <+>)
-    type2C' (String l) = return (text "string255" <+>)--return (text ("string" ++ show l) <+>)
-    type2C' (PointerTo (SimpleType i)) = do
-        i' <- id2C IODeferred i
-        lt <- gets lastType
-        case lt of
-             BTRecord _ _ -> return $ \a -> text "struct __" <> i' <+> text "*" <+> a
-             BTUnknown -> return $ \a -> text "struct __" <> i' <+> text "*" <+> a
-             _ -> return $ \a -> i' <+> text "*" <+> a
-    type2C' (PointerTo t) = liftM (\t a -> t (parens $ text "*" <> a)) $ type2C t
-    type2C' (RecordType tvs union) = do
-        t <- withState' f $ mapM (tvar2C False False True False) tvs
-        u <- unions
-        return $ \i -> text "struct __" <> i <+> lbrace $+$ nest 4 ((vcat . map (<> semi) . concat $ t) $$ u) $+$ rbrace <+> i
-        where
-            f s = s{currentUnit = ""}
-            unions = case union of
-                     Nothing -> return empty
-                     Just a -> do
-                         structs <- mapM struct2C a
-                         return $ text "union" $+$ braces (nest 4 $ vcat structs) <> semi
-            struct2C tvs = do
-                t <- withState' f $ mapM (tvar2C False False True False) tvs
-                return $ text "struct" $+$ braces (nest 4 (vcat . map (<> semi) . concat $ t)) <> semi
-    type2C' (RangeType r) = return (text "int" <+>)
-    type2C' (Sequence ids) = do
-        is <- mapM (id2C IOInsert . setBaseType bt) ids
-        return (text "enum" <+> (braces . vcat . punctuate comma . map (\(a, b) -> a <+> equals <+> text "0x" <> text (showHex b "")) $ zip is [0..]) <+>)
-        where
-            bt = BTEnum $ map (\(Identifier i _) -> map toLower i) ids
-    type2C' (ArrayDecl Nothing t) = type2C (PointerTo t)
-    type2C' (ArrayDecl (Just r) t) = do
-        t' <- type2C t
-        lt <- gets lastType
-        ft <- case lt of
-                -- BTFunction {} -> type2C (PointerTo t)
-                _ -> return t'
-        r' <- initExpr2C (InitRange r)
-        return $ \i -> ft i <> brackets r'
-    type2C' (Set t) = return (text "<<set>>" <+>)
-    type2C' (FunctionType returnType params) = do
-        t <- type2C returnType
-        p <- withState' id $ functionParams2C params
-        return (\i -> (t empty <> (parens $ text "*" <> i) <> parens p))
-    type2C' (DeriveType (InitBinOp _ _ i)) = type2C' (DeriveType i)
-    type2C' (DeriveType (InitPrefixOp _ i)) = type2C' (DeriveType i)
-    type2C' (DeriveType (InitNumber _)) = return (text "int" <+>)
-    type2C' (DeriveType (InitHexNumber _)) = return (text "int" <+>)
-    type2C' (DeriveType (InitFloat _)) = return (text "float" <+>)
-    type2C' (DeriveType (BuiltInFunction {})) = return (text "int" <+>)
-    type2C' (DeriveType (InitString {})) = return (text "string255" <+>)
-    type2C' (DeriveType r@(InitReference {})) = do
-        initExpr2C r
-        t <- gets lastType
-        return (baseType2C (show r) t <+>)
-    type2C' (DeriveType a) = error $ "Can't derive type from " ++ show a
-
-phrase2C :: Phrase -> State RenderState Doc
-phrase2C (Phrases p) = do
-    ps <- mapM phrase2C p
-    return $ text "{" $+$ (nest 4 . vcat $ ps) $+$ text "}"
-phrase2C (ProcCall f@(FunCall {}) []) = liftM (<> semi) $ ref2C f
-phrase2C (ProcCall ref []) = liftM (<> semi) $ ref2CF ref
-phrase2C (ProcCall ref params) = error $ "ProcCall"{-do
-    r <- ref2C ref
-    ps <- mapM expr2C params
-    return $ r <> parens (hsep . punctuate (char ',') $ ps) <> semi -}
-phrase2C (IfThenElse (expr) phrase1 mphrase2) = do
-    e <- expr2C expr
-    p1 <- (phrase2C . wrapPhrase) phrase1
-    el <- elsePart
-    return $
-        text "if" <> parens e $+$ p1 $+$ el
-    where
-    elsePart | isNothing mphrase2 = return $ empty
-             | otherwise = liftM (text "else" $$) $ (phrase2C . wrapPhrase) (fromJust mphrase2)
-phrase2C (Assignment ref expr) = do
-    r <- ref2C ref
-    t <- gets lastType
-    case (t, expr) of
-        (BTFunction {}, (Reference r')) -> do
-            e <- ref2C r'
-            return $ r <+> text "=" <+> e <> semi
-        (BTString, _) -> do
-            e <- expr2C expr
-            lt <- gets lastType
-            case lt of
-                -- assume pointer to char for simplicity
-                BTPointerTo _ -> do
-                    e <- expr2C $ Reference $ FunCall [Reference $ RefExpression expr] (SimpleReference (Identifier "pchar2str" BTUnknown))
-                    return $ r <+> text "=" <+> e <> semi
-                BTString -> do
-                    e <- expr2C expr
-                    return $ r <+> text "=" <+> e <> semi
-                _ -> error $ "Assignment to string from " ++ show lt
-        (BTArray _ _ _, _) -> do
-            case expr of
-                Reference er -> do
-                    exprRef <- ref2C er
-                    exprT <- gets lastType
-                    case exprT of
-                        BTArray RangeInfinite _ _ ->
-                            return $ text "FIXME: assign a dynamic array to an array"
-                        BTArray _ _ _ -> phrase2C $
-                                ProcCall (FunCall
-                                    [
-                                    Reference $ ref
-                                    , Reference $ RefExpression expr
-                                    , Reference $ FunCall [expr] (SimpleReference (Identifier "sizeof" BTUnknown))
-                                    ]
-                                    (SimpleReference (Identifier "memcpy" BTUnknown))
-                                    ) []
-                        _ -> return $ text "FIXME: assign a non-specific value to an array"
-
-                _ -> return $ text "FIXME: dynamic array assignment 2"
-        _ -> do
-            e <- expr2C expr
-            return $ r <+> text "=" <+> e <> semi
-phrase2C (WhileCycle expr phrase) = do
-    e <- expr2C expr
-    p <- phrase2C $ wrapPhrase phrase
-    return $ text "while" <> parens e $$ p
-phrase2C (SwitchCase expr cases mphrase) = do
-    e <- expr2C expr
-    cs <- mapM case2C cases
-    d <- dflt
-    return $
-        text "switch" <> parens e $+$ braces (nest 4 . vcat $ cs ++ d)
-    where
-    case2C :: ([InitExpression], Phrase) -> State RenderState Doc
-    case2C (e, p) = do
-        ies <- mapM range2C e
-        ph <- phrase2C p
-        return $
-             vcat (map (\i -> text "case" <+> i <> colon) . concat $ ies) <> nest 4 (ph $+$ text "break;")
-    dflt | isNothing mphrase = return [text "default: break;"] -- avoid compiler warning
-         | otherwise = do
-             ph <- mapM phrase2C $ fromJust mphrase
-             return [text "default:" <+> nest 4 (vcat ph)]
-
-phrase2C wb@(WithBlock ref p) = do
-    r <- ref2C ref
-    t <- gets lastType
-    case t of
-        (BTRecord _ rs) -> withRecordNamespace (render r ++ ".") (rec2Records rs) $ phrase2C $ wrapPhrase p
-        a -> do
-            error $ "'with' block referencing non-record type " ++ show a ++ "\n" ++ show wb
-phrase2C (ForCycle i' e1' e2' p up) = do
-    i <- id2C IOLookup i'
-    iType <- gets lastIdTypeDecl
-    e1 <- expr2C e1'
-    e2 <- expr2C e2'
-    let inc = if up then "inc" else "dec"
-    let add = if up then "+ 1" else "- 1"
-    let iEnd = i <> text "__end__"
-    ph <- phrase2C . appendPhrase (BuiltInFunctionCall [Reference $ SimpleReference i'] (SimpleReference (Identifier inc BTUnknown))) $ wrapPhrase p
-    return . braces $
-        i <+> text "=" <+> e1 <> semi
-        $$
-        iType <+> iEnd <+> text "=" <+> e2 <> semi
-        $$ 
-        text "if" <+> (parens $ i <+> text "<=" <+> iEnd) <+> text "do" <+> ph <+>
-        text "while" <> parens (i <+> text "!=" <+> iEnd <+> text add) <> semi
-    where
-        appendPhrase p (Phrases ps) = Phrases $ ps ++ [p]
-phrase2C (RepeatCycle e' p') = do
-    e <- expr2C e'
-    p <- phrase2C (Phrases p')
-    return $ text "do" <+> p <+> text "while" <> parens (text "!" <> parens e) <> semi
-phrase2C NOP = return $ text ";"
-
-phrase2C (BuiltInFunctionCall [] (SimpleReference (Identifier "exit" BTUnknown))) = do
-    f <- gets currentFunctionResult
-    if null f then
-        return $ text "return" <> semi
-        else
-        return $ text "return" <+> text f <> semi
-phrase2C (BuiltInFunctionCall [] (SimpleReference (Identifier "break" BTUnknown))) = return $ text "break" <> semi
-phrase2C (BuiltInFunctionCall [] (SimpleReference (Identifier "continue" BTUnknown))) = return $ text "continue" <> semi
-phrase2C (BuiltInFunctionCall [e] (SimpleReference (Identifier "exit" BTUnknown))) = liftM (\e -> text "return" <+> e <> semi) $ expr2C e
-phrase2C (BuiltInFunctionCall [e] (SimpleReference (Identifier "dec" BTUnknown))) = liftM (\e -> text "--" <> e <> semi) $ expr2C e
-phrase2C (BuiltInFunctionCall [e1, e2] (SimpleReference (Identifier "dec" BTUnknown))) = liftM2 (\a b -> a <> text " -= " <> b <> semi) (expr2C e1) (expr2C e2)
-phrase2C (BuiltInFunctionCall [e] (SimpleReference (Identifier "inc" BTUnknown))) = liftM (\e -> text "++" <> e <> semi) $ expr2C e
-phrase2C (BuiltInFunctionCall [e1, e2] (SimpleReference (Identifier "inc" BTUnknown))) = liftM2 (\a b -> a <+> text "+=" <+> b <> semi) (expr2C e1) (expr2C e2)
-phrase2C a = error $ "phrase2C: " ++ show a
-
-wrapPhrase p@(Phrases _) = p
-wrapPhrase p = Phrases [p]
-
-expr2C :: Expression -> State RenderState Doc
-expr2C (Expression s) = return $ text s
-expr2C b@(BinOp op expr1 expr2) = do
-    e1 <- expr2C expr1
-    t1 <- gets lastType
-    e2 <- expr2C expr2
-    t2 <- gets lastType
-    case (op2C op, t1, t2) of
-        ("+", BTString, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strconcat" (BTFunction False 2 BTString))
-        ("+", BTString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strappend" (BTFunction False 2 BTString))
-        ("+", BTChar, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strprepend" (BTFunction False 2 BTString))
-        ("+", BTChar, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_chrconcat" (BTFunction False 2 BTString))
-        ("==", BTString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcomparec" (BTFunction False 2 BTBool))
-        ("==", BTString, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcompare" (BTFunction False 2 BTBool))
-        ("!=", BTString, _) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strncompare" (BTFunction False 2 BTBool))
-        ("&", BTBool, _) -> return $ parens e1 <+> text "&&" <+> parens e2
-        ("|", BTBool, _) -> return $ parens e1 <+> text "||" <+> parens e2
-        (_, BTRecord t1 _, BTRecord t2 _) -> do
-            i <- op2CTyped op [SimpleType (Identifier t1 undefined), SimpleType (Identifier t2 undefined)]
-            ref2C $ FunCall [expr1, expr2] (SimpleReference i)
-        (_, BTRecord t1 _, BTInt) -> do
-            -- aw, "LongInt" here is hwengine-specific hack
-            i <- op2CTyped op [SimpleType (Identifier t1 undefined), SimpleType (Identifier "LongInt" undefined)]
-            ref2C $ FunCall [expr1, expr2] (SimpleReference i)
-        ("in", _, _) ->
-            case expr2 of
-                 SetExpression set -> do
-                     ids <- mapM (id2C IOLookup) set
-                     modify(\s -> s{lastType = BTBool})
-                     return . parens . hcat . punctuate (text " || ") . map (\i -> parens $ e1 <+> text "==" <+> i) $ ids
-                 _ -> error "'in' against not set expression"
-        (o, _, _) | o `elem` boolOps -> do
-                        modify(\s -> s{lastType = BTBool})
-                        return $ parens e1 <+> text o <+> parens e2
-                  | otherwise -> do
-                        o' <- return $ case o of
-                            "/(float)" -> text "/(float)" -- pascal returns real value
-                            _ -> text o
-                        e1' <- return $ case (o, t1, t2) of
-                                ("-", BTInt, BTInt) -> parens $ text "(int64_t)" <+> parens e1
-                                _ -> parens e1
-                        e2' <- return $ case (o, t1, t2) of
-                                ("-", BTInt, BTInt) -> parens $ text "(int64_t)" <+> parens e2
-                                _ -> parens e2
-                        return $ e1' <+> o' <+> e2'
-    where
-        boolOps = ["==", "!=", "<", ">", "<=", ">="]
-expr2C (NumberLiteral s) = do
-    modify(\s -> s{lastType = BTInt})
-    return $ text s
-expr2C (FloatLiteral s) = return $ text s
-expr2C (HexNumber s) = return $ text "0x" <> (text . map toLower $ s)
-{-expr2C (StringLiteral [a]) = do
-    modify(\s -> s{lastType = BTChar})
-    return . quotes . text $ escape a
-    where
-        escape '\'' = "\\\'"
-        escape a = [a]-}
-expr2C (StringLiteral s) = addStringConst s
-expr2C (PCharLiteral s) = return . doubleQuotes $ text s
-expr2C (Reference ref) = ref2CF ref
-expr2C (PrefixOp op expr) = do
-    e <- expr2C expr
-    lt <- gets lastType
-    case lt of
-        BTRecord t _ -> do
-            i <- op2CTyped op [SimpleType (Identifier t undefined)]
-            ref2C $ FunCall [expr] (SimpleReference i)
-        BTBool -> do
-            o <- return $ case op of
-                     "not" -> text "!"
-                     _ -> text (op2C op)
-            return $ o <> parens e
-        _ -> return $ text (op2C op) <> parens e
-expr2C Null = return $ text "NULL"
-expr2C (CharCode a) = do
-    modify(\s -> s{lastType = BTChar})
-    return $ quotes $ text "\\x" <> text (showHex (read a) "")
-expr2C (HexCharCode a) = if length a <= 2 then return $ quotes $ text "\\x" <> text (map toLower a) else expr2C $ HexNumber a
-expr2C (SetExpression ids) = mapM (id2C IOLookup) ids >>= return . parens . hcat . punctuate (text " | ")
-
-expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "low" _))) = do
-    e' <- liftM (map toLower . render) $ expr2C e
-    lt <- gets lastType
-    case lt of
-         BTEnum a -> return $ int 0
-         BTInt -> case e' of
-                  "longint" -> return $ int (-2147483648)
-         BTArray {} -> return $ int 0
-         _ -> error $ "BuiltInFunCall 'low' from " ++ show e ++ "\ntype: " ++ show lt
-expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "high" _))) = do
-    e' <- liftM (map toLower . render) $ expr2C e
-    lt <- gets lastType
-    case lt of
-         BTEnum a -> return . int $ length a - 1
-         BTInt -> case e' of
-                  "longint" -> return $ int (2147483647)
-         BTString -> return $ int 255
-         BTArray (RangeFromTo _ n) _ _ -> initExpr2C n
-         _ -> error $ "BuiltInFunCall 'high' from " ++ show e ++ "\ntype: " ++ show lt
-expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "ord" _))) = liftM parens $ expr2C e
-expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "succ" _))) = liftM (<> text " + 1") $ expr2C e
-expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "pred" _))) = liftM (<> text " - (int64_t)1") $ expr2C e
-expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "length" _))) = do
-    e' <- expr2C e
-    lt <- gets lastType
-    modify (\s -> s{lastType = BTInt})
-    case lt of
-         BTString -> return $ text "fpcrtl_Length" <> parens e'
-         BTArray RangeInfinite _ _ -> error $ "length() called on variable size array " ++ show e'
-         BTArray (RangeFromTo _ n) _ _ -> initExpr2C (BuiltInFunction "succ" [n])
-         _ -> error $ "length() called on " ++ show lt
-expr2C (BuiltInFunCall params ref) = do
-    r <- ref2C ref
-    t <- gets lastType
-    ps <- mapM expr2C params
-    case t of
-        BTFunction _ _ t' -> do
-            modify (\s -> s{lastType = t'})
-        _ -> error $ "BuiltInFunCall lastType: " ++ show t
-    return $
-        r <> parens (hsep . punctuate (char ',') $ ps)
-expr2C a = error $ "Don't know how to render " ++ show a
-
-ref2CF :: Reference -> State RenderState Doc
-ref2CF (SimpleReference name) = do
-    i <- id2C IOLookup name
-    t <- gets lastType
-    case t of
-         BTFunction _ _ rt -> do
-             modify(\s -> s{lastType = rt})
-             return $ i <> parens empty --xymeng: removed parens
-         _ -> return $ i
-ref2CF r@(RecordField (SimpleReference _) (SimpleReference _)) = do
-    i <- ref2C r
-    t <- gets lastType
-    case t of
-         BTFunction _ _ rt -> do
-             modify(\s -> s{lastType = rt})
-             return $ i <> parens empty
-         _ -> return $ i
-ref2CF r = ref2C r
-
-ref2C :: Reference -> State RenderState Doc
--- rewrite into proper form
-ref2C (RecordField ref1 (ArrayElement exprs ref2)) = ref2C $ ArrayElement exprs (RecordField ref1 ref2)
-ref2C (RecordField ref1 (Dereference ref2)) = ref2C $ Dereference (RecordField ref1 ref2)
-ref2C (RecordField ref1 (RecordField ref2 ref3)) = ref2C $ RecordField (RecordField ref1 ref2) ref3
-ref2C (RecordField ref1 (FunCall params ref2)) = ref2C $ FunCall params (RecordField ref1 ref2)
-ref2C (ArrayElement (a:b:xs) ref) = ref2C $ ArrayElement (b:xs) (ArrayElement [a] ref)
--- conversion routines
-ref2C ae@(ArrayElement [expr] ref) = do
-    e <- expr2C expr
-    r <- ref2C ref
-    t <- gets lastType
-    case t of
-         (BTArray _ _ t') -> modify (\st -> st{lastType = t'})
---         (BTFunctionReturn _ (BTArray _ _ t')) -> modify (\st -> st{lastType = t'})
---         (BTFunctionReturn _ (BTString)) -> modify (\st -> st{lastType = BTChar})
-         (BTString) -> modify (\st -> st{lastType = BTChar})
-         (BTPointerTo t) -> do
-                t'' <- fromPointer (show t) =<< gets lastType
-                case t'' of
-                     BTChar -> modify (\st -> st{lastType = BTChar})
-                     a -> error $ "Getting element of " ++ show a ++ "\nReference: " ++ show ae
-         a -> error $ "Getting element of " ++ show a ++ "\nReference: " ++ show ae
-    case t of
-         BTString ->  return $ r <> text ".s" <> brackets e
-         _ -> return $ r <> brackets e
-ref2C (SimpleReference name) = id2C IOLookup name
-ref2C rf@(RecordField (Dereference ref1) ref2) = do
-    r1 <- ref2C ref1
-    t <- fromPointer (show ref1) =<< gets lastType
-    r2 <- case t of
-        BTRecord _ rs -> withRecordNamespace "" (rec2Records rs) $ ref2C ref2
-        BTUnit -> error "What??"
-        a -> error $ "dereferencing from " ++ show a ++ "\n" ++ show rf
-    return $
-        r1 <> text "->" <> r2
-ref2C rf@(RecordField ref1 ref2) = do
-    r1 <- ref2C ref1
-    t <- gets lastType
-    case t of
-        BTRecord _ rs -> do
-            r2 <- withRecordNamespace "" (rec2Records rs) $ ref2C ref2
-            return $ r1 <> text "." <> r2
-        BTUnit -> withLastIdNamespace $ ref2C ref2
-        a -> error $ "dereferencing from " ++ show a ++ "\n" ++ show rf
-ref2C d@(Dereference ref) = do
-    r <- ref2C ref
-    t <- fromPointer (show d) =<< gets lastType
-    modify (\st -> st{lastType = t})
-    return $ (parens $ text "*" <> r)
-ref2C f@(FunCall params ref) = do
-    r <- fref2C ref
-    t <- gets lastType
-    case t of
-        BTFunction _ _ t' -> do
-            ps <- liftM (parens . hsep . punctuate (char ',')) $ mapM expr2C params
-            modify (\s -> s{lastType = t'})
-            return $ r <> ps
-        _ -> case (ref, params) of
-                  (SimpleReference i, [p]) -> ref2C $ TypeCast i p
-                  _ -> error $ "ref2C FunCall erroneous type cast detected: " ++ show f ++ "\nType detected: " ++ show t
-    where
-    fref2C (SimpleReference name) = id2C (IOLookupFunction $ length params) name
-    fref2C a = ref2C a
-
-ref2C (Address ref) = do
-    r <- ref2C ref
-    lt <- gets lastType
-    case lt of
-        BTFunction True _ _ -> return $ text "&" <> parens (r <> text "__vars")
-        _ -> return $ text "&" <> parens r
-ref2C (TypeCast t'@(Identifier i _) expr) = do
-    lt <- expr2C expr >> gets lastType
-    case (map toLower i, lt) of
-        ("pchar", BTString) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "_pchar" $ BTPointerTo BTChar))
-        ("shortstring", BTPointerTo _) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "pchar2str" $ BTString))
-        (a, _) -> do
-            e <- expr2C expr
-            t <- id2C IOLookup t'
-            return . parens $ parens t <> e
-ref2C (RefExpression expr) = expr2C expr
-
-
-op2C :: String -> String
-op2C "or" = "|"
-op2C "and" = "&"
-op2C "not" = "~"
-op2C "xor" = "^"
-op2C "div" = "/"
-op2C "mod" = "%"
-op2C "shl" = "<<"
-op2C "shr" = ">>"
-op2C "<>" = "!="
-op2C "=" = "=="
-op2C "/" = "/(float)"
-op2C a = a
-
diff -r b518458f83e6 -r 7fcbbd46704a tools/pas2c/Main.hs
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/pas2c/Main.hs	Mon Nov 05 01:35:54 2012 +0100
@@ -0,0 +1,43 @@
+module Main( main ) where
+
+import System( getArgs )
+import System.Console.GetOpt
+import System.Environment
+import System.Exit
+import System.IO
+import Data.Maybe( fromMaybe )
+import Pas2C
+
+main = do
+    args <- getArgs
+    if length args == 0
+    then do
+        name <- getProgName
+        hPutStrLn stderr $ usageInfo header options
+        exitFailure
+    else do
+        case getOpt RequireOrder options args of
+          (flags, [],      [])     ->
+            if length args == 8 then do
+                pas2C (args !! 1) ((args !! 3)++"/") ((args !! 5)++"/") ((args !! 7)++"/")
+            else do
+                if length args == 6 then do
+                    pas2C (args !! 1) ((args !! 3)++"/") ((args !! 5)++"/") "./"
+                else do
+                    error $ usageInfo header options
+          (_,     nonOpts, [])     -> error $ "unrecognized arguments: " ++ unwords nonOpts
+          (_,     _,       msgs)   -> error $ usageInfo header options
+    where header = "Freepascal to C conversion! Please use -n -i -o -a options in this order.\n"
+
+
+data Flag = HelpMessage | Name String | Input String | Output String | Alternate String
+
+options :: [OptDescr Flag]
+options = [
+    Option ['h'] ["help"]      (NoArg HelpMessage)      "print this help message",
+    Option ['n'] ["name"]      (ReqArg Name "MAIN")     "name of the main Pascal module",
+    Option ['i'] ["input"]     (ReqArg Input "DIR")     "input directory, where .pas files will be read",
+    Option ['o'] ["output"]    (ReqArg Output "DIR")    "output directory, where .c/.h files will be written",
+    Option ['a'] ["alternate"] (ReqArg Alternate "DIR") "alternate input directory, for out of source builds"
+  ]
+
diff -r b518458f83e6 -r 7fcbbd46704a tools/pas2c/PascalBasics.hs
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/pas2c/PascalBasics.hs	Mon Nov 05 01:35:54 2012 +0100
@@ -0,0 +1,70 @@
+{-# LANGUAGE FlexibleContexts #-}
+module PascalBasics where
+
+import Text.Parsec.Combinator
+import Text.Parsec.Char
+import Text.Parsec.Prim
+import Text.Parsec.Token
+import Text.Parsec.Language
+import Data.Char
+
+builtin = ["succ", "pred", "low", "high", "ord", "inc", "dec", "exit", "break", "continue", "length"]
+
+pascalLanguageDef
+    = emptyDef
+    { commentStart   = "(*"
+    , commentEnd     = "*)"
+    , commentLine    = "//"
+    , nestedComments = False
+    , identStart     = letter <|> oneOf "_"
+    , identLetter    = alphaNum <|> oneOf "_"
+    , reservedNames  = [
+            "begin", "end", "program", "unit", "interface"
+            , "implementation", "and", "or", "xor", "shl"
+            , "shr", "while", "do", "repeat", "until", "case", "of"
+            , "type", "var", "const", "out", "array", "packed"
+            , "procedure", "function", "with", "for", "to"
+            , "downto", "div", "mod", "record", "set", "nil"
+            , "cdecl", "external", "if", "then", "else"
+            ] -- ++ builtin
+    , reservedOpNames= []
+    , caseSensitive  = False
+    }
+
+preprocessorSwitch :: Stream s m Char => ParsecT s u m String
+preprocessorSwitch = do
+    try $ string "{$"
+    s <- manyTill (noneOf "\n") $ char '}'
+    return s
+
+caseInsensitiveString s = do
+    mapM_ (\a -> satisfy (\b -> toUpper a == toUpper b)) s <?> s
+    return s
+
+pas = patch $ makeTokenParser pascalLanguageDef
+    where
+    patch tp = tp {stringLiteral = stringL}
+
+comment = choice [
+        char '{' >> notFollowedBy (char '$') >> manyTill anyChar (try $ char '}')
+        , (try $ string "(*") >> manyTill anyChar (try $ string "*)")
+        , (try $ string "//") >> manyTill anyChar (try newline)
+        ]
+
+comments = do
+    spaces
+    skipMany $ do
+        preprocessorSwitch <|> comment
+        spaces
+
+stringL = do
+    (char '\'')
+    s <- (many $ noneOf "'")
+    (char '\'')
+    ss <- many $ do
+        (char '\'')
+        s' <- (many $ noneOf "'")
+        (char '\'')
+        return $ '\'' : s'
+    comments
+    return $ concat (s:ss)
diff -r b518458f83e6 -r 7fcbbd46704a tools/pas2c/PascalParser.hs
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/pas2c/PascalParser.hs	Mon Nov 05 01:35:54 2012 +0100
@@ -0,0 +1,659 @@
+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)
+
diff -r b518458f83e6 -r 7fcbbd46704a tools/pas2c/PascalPreprocessor.hs
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/pas2c/PascalPreprocessor.hs	Mon Nov 05 01:35:54 2012 +0100
@@ -0,0 +1,135 @@
+module PascalPreprocessor where
+
+import Text.Parsec
+import Control.Monad.IO.Class
+import Control.Monad
+import System.IO
+import qualified Data.Map as Map
+import Data.Char
+
+
+-- comments are removed
+comment = choice [
+        char '{' >> notFollowedBy (char '$') >> manyTill anyChar (try $ char '}') >> return ""
+        , (try $ string "(*") >> manyTill anyChar (try $ string "*)") >> return ""
+        , (try $ string "//") >> manyTill anyChar (try newline) >> return "\n"
+        ]
+
+initDefines = Map.fromList [
+    ("FPC", "")
+    , ("PAS2C", "")
+    , ("ENDIAN_LITTLE", "")
+    , ("S3D_DISABLED", "")
+    ]
+
+preprocess :: String -> String -> String -> IO String
+preprocess inputPath alternateInputPath fn = do
+    r <- runParserT (preprocessFile (inputPath ++ fn)) (initDefines, [True]) "" ""
+    case r of
+         (Left a) -> do
+             hPutStrLn stderr (show a)
+             return ""
+         (Right a) -> return a
+
+    where
+    preprocessFile fn = do
+        f <- liftIO (readFile fn)
+        setInput f
+        preprocessor
+
+    preprocessor, codeBlock, switch :: ParsecT String (Map.Map String String, [Bool]) IO String
+
+    preprocessor = chainr codeBlock (return (++)) ""
+
+    codeBlock = do
+        s <- choice [
+            switch
+            , comment
+            , char '\'' >> many (noneOf "'\n") >>= \s -> char '\'' >> return ('\'' : s ++ "'")
+            , identifier >>= replace
+            , noneOf "{" >>= \a -> return [a]
+            ]
+        (_, ok) <- getState
+        return $ if and ok then s else ""
+
+    --otherChar c = c `notElem` "{/('_" && not (isAlphaNum c)
+    identifier = do
+        c <- letter <|> oneOf "_"
+        s <- many (alphaNum <|> oneOf "_")
+        return $ c:s
+
+    switch = do
+        try $ string "{$"
+        s <- choice [
+            include
+            , ifdef
+            , if'
+            , elseSwitch
+            , endIf
+            , define
+            , unknown
+            ]
+        return s
+
+    include = do
+        try $ string "INCLUDE"
+        spaces
+        (char '"')
+        fn <- many1 $ noneOf "\"\n"
+        char '"'
+        spaces
+        char '}'
+        f <- liftIO (readFile (inputPath ++ fn) `catch` (\exc -> readFile (alternateInputPath ++ fn) `catch` error ("File not found: " ++ fn)))
+        c <- getInput
+        setInput $ f ++ c
+        return ""
+
+    ifdef = do
+        s <- try (string "IFDEF") <|> try (string "IFNDEF")
+        let f = if s == "IFNDEF" then not else id
+
+        spaces
+        d <- identifier
+        spaces
+        char '}'
+
+        updateState $ \(m, b) ->
+            (m, (f $ d `Map.member` m) : b)
+
+        return ""
+
+    if' = do
+        s <- try (string "IF" >> notFollowedBy alphaNum)
+
+        manyTill anyChar (char '}')
+        --char '}'
+
+        updateState $ \(m, b) ->
+            (m, False : b)
+
+        return ""
+
+    elseSwitch = do
+        try $ string "ELSE}"
+        updateState $ \(m, b:bs) -> (m, (not b):bs)
+        return ""
+    endIf = do
+        try $ string "ENDIF}"
+        updateState $ \(m, b:bs) -> (m, bs)
+        return ""
+    define = do
+        try $ string "DEFINE"
+        spaces
+        i <- identifier
+        d <- ((string ":=" >> return ()) <|> spaces) >> many (noneOf "}")
+        char '}'
+        updateState $ \(m, b) -> (if (and b) && (head i /= '_') then Map.insert i d m else m, b)
+        return ""
+    replace s = do
+        (m, _) <- getState
+        return $ Map.findWithDefault s s m
+
+    unknown = do
+        fn <- many1 $ noneOf "}\n"
+        char '}'
+        return $ "{$" ++ fn ++ "}"
diff -r b518458f83e6 -r 7fcbbd46704a tools/pas2c/PascalUnitSyntaxTree.hs
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/pas2c/PascalUnitSyntaxTree.hs	Mon Nov 05 01:35:54 2012 +0100
@@ -0,0 +1,119 @@
+module PascalUnitSyntaxTree where
+
+import Data.Maybe
+import Data.Char
+
+data PascalUnit =
+    Program Identifier Implementation Phrase
+    | Unit Identifier Interface Implementation (Maybe Initialize) (Maybe Finalize)
+    | System [TypeVarDeclaration]
+    | Redo [TypeVarDeclaration]
+    deriving Show
+data Interface = Interface Uses TypesAndVars
+    deriving Show
+data Implementation = Implementation Uses TypesAndVars
+    deriving Show
+data Identifier = Identifier String BaseType
+    deriving Show
+data TypesAndVars = TypesAndVars [TypeVarDeclaration]
+    deriving Show
+data TypeVarDeclaration = TypeDeclaration Identifier TypeDecl
+    | VarDeclaration Bool Bool ([Identifier], TypeDecl) (Maybe InitExpression)
+    | FunctionDeclaration Identifier Bool TypeDecl [TypeVarDeclaration] (Maybe (TypesAndVars, Phrase))
+    | OperatorDeclaration String Identifier Bool TypeDecl [TypeVarDeclaration] (Maybe (TypesAndVars, Phrase))
+    deriving Show
+data TypeDecl = SimpleType Identifier
+    | RangeType Range
+    | Sequence [Identifier]
+    | ArrayDecl (Maybe Range) TypeDecl
+    | RecordType [TypeVarDeclaration] (Maybe [[TypeVarDeclaration]])
+    | PointerTo TypeDecl
+    | String Integer
+    | Set TypeDecl
+    | FunctionType TypeDecl [TypeVarDeclaration]
+    | DeriveType InitExpression
+    | VoidType
+    | VarParamType TypeDecl -- this is a hack
+    deriving Show
+data Range = Range Identifier
+           | RangeFromTo InitExpression InitExpression
+           | RangeInfinite
+    deriving Show
+data Initialize = Initialize String
+    deriving Show
+data Finalize = Finalize String
+    deriving Show
+data Uses = Uses [Identifier]
+    deriving Show
+data Phrase = ProcCall Reference [Expression]
+        | IfThenElse Expression Phrase (Maybe Phrase)
+        | WhileCycle Expression Phrase
+        | RepeatCycle Expression [Phrase]
+        | ForCycle Identifier Expression Expression Phrase Bool -- The last Boolean indicates wether it's up or down counting
+        | WithBlock Reference Phrase
+        | Phrases [Phrase]
+        | SwitchCase Expression [([InitExpression], Phrase)] (Maybe [Phrase])
+        | Assignment Reference Expression
+        | BuiltInFunctionCall [Expression] Reference
+        | NOP
+    deriving Show
+data Expression = Expression String
+    | BuiltInFunCall [Expression] Reference
+    | PrefixOp String Expression
+    | PostfixOp String Expression
+    | BinOp String Expression Expression
+    | StringLiteral String
+    | PCharLiteral String
+    | CharCode String
+    | HexCharCode String
+    | NumberLiteral String
+    | FloatLiteral String
+    | HexNumber String
+    | Reference Reference
+    | SetExpression [Identifier]
+    | Null
+    deriving Show
+data Reference = ArrayElement [Expression] Reference
+    | FunCall [Expression] Reference
+    | TypeCast Identifier Expression
+    | SimpleReference Identifier
+    | Dereference Reference
+    | RecordField Reference Reference
+    | Address Reference
+    | RefExpression Expression
+    deriving Show
+data InitExpression = InitBinOp String InitExpression InitExpression
+    | InitPrefixOp String InitExpression
+    | InitReference Identifier
+    | InitArray [InitExpression]
+    | InitRecord [(Identifier, InitExpression)]
+    | InitFloat String
+    | InitNumber String
+    | InitHexNumber String
+    | InitString String
+    | InitChar String
+    | BuiltInFunction String [InitExpression]
+    | InitSet [InitExpression]
+    | InitAddress InitExpression
+    | InitNull
+    | InitRange Range
+    | InitTypeCast Identifier InitExpression
+    deriving Show
+
+data BaseType = BTUnknown
+    | BTChar
+    | BTString
+    | BTInt
+    | BTBool
+    | BTFloat
+    | BTRecord String [(String, BaseType)]
+    | BTArray Range BaseType BaseType
+    | BTFunction Bool Int BaseType
+    | BTPointerTo BaseType
+    | BTUnresolved String
+    | BTSet BaseType
+    | BTEnum [String]
+    | BTVoid
+    | BTUnit
+    | BTVarParam BaseType
+    deriving Show
diff -r b518458f83e6 -r 7fcbbd46704a tools/pas2c/pas2c.hs
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/pas2c/pas2c.hs	Mon Nov 05 01:35:54 2012 +0100
@@ -0,0 +1,1085 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+module Pas2C where
+
+import Text.PrettyPrint.HughesPJ
+import Data.Maybe
+import Data.Char
+import Text.Parsec.Prim hiding (State)
+import Control.Monad.State
+import System.IO
+import System.Directory
+import Control.Monad.IO.Class
+import PascalPreprocessor
+import Control.Exception
+import System.IO.Error
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import Data.List (find)
+import Numeric
+
+import PascalParser(pascalUnit)
+import PascalUnitSyntaxTree
+
+
+data InsertOption =
+    IOInsert
+    | IOInsertWithType Doc
+    | IOLookup
+    | IOLookupLast
+    | IOLookupFunction Int
+    | IODeferred
+
+data Record = Record
+    {
+        lcaseId :: String,
+        baseType :: BaseType,
+        typeDecl :: Doc
+    }
+    deriving Show
+type Records = Map.Map String [Record]
+data RenderState = RenderState
+    {
+        currentScope :: Records,
+        lastIdentifier :: String,
+        lastType :: BaseType,
+        lastIdTypeDecl :: Doc,
+        stringConsts :: [(String, String)],
+        uniqCounter :: Int,
+        toMangle :: Set.Set String,
+        currentUnit :: String,
+        currentFunctionResult :: String,
+        namespaces :: Map.Map String Records
+    }
+
+rec2Records = map (\(a, b) -> Record a b empty)
+
+emptyState = RenderState Map.empty "" BTUnknown empty [] 0 Set.empty "" ""
+
+getUniq :: State RenderState Int
+getUniq = do
+    i <- gets uniqCounter
+    modify(\s -> s{uniqCounter = uniqCounter s + 1})
+    return i
+
+addStringConst :: String -> State RenderState Doc
+addStringConst str = do
+    strs <- gets stringConsts
+    let a = find ((==) str . snd) strs
+    if isJust a then
+        do
+        modify (\s -> s{lastType = BTString})
+        return . text . fst . fromJust $ a
+    else
+        do
+        i <- getUniq
+        let sn = "__str" ++ show i
+        modify (\s -> s{lastType = BTString, stringConsts = (sn, str) : strs})
+        return $ text sn
+
+escapeStr :: String -> String
+escapeStr = foldr escapeChar []
+
+escapeChar :: Char -> ShowS
+escapeChar '"' s = "\\\"" ++ s
+escapeChar '\\' s = "\\\\" ++ s
+escapeChar a s = a : s
+
+strInit :: String -> Doc
+strInit a = text "STRINIT" <> parens (doubleQuotes (text $ escapeStr a))
+
+renderStringConsts :: State RenderState Doc
+renderStringConsts = liftM (vcat . map (\(a, b) -> text "static const string255" <+> (text a) <+> text "=" <+> strInit b <> semi))
+    $ gets stringConsts
+
+docToLower :: Doc -> Doc
+docToLower = text . map toLower . render
+
+pas2C :: String -> String -> String -> String -> IO ()
+pas2C fn inputPath alternateInputPath outputPath = do
+    s <- flip execStateT initState $ f fn
+    renderCFiles s outputPath
+    where
+    printLn = liftIO . hPutStrLn stdout
+    print = liftIO . hPutStr stdout
+    initState = Map.empty
+    f :: String -> StateT (Map.Map String PascalUnit) IO ()
+    f fileName = do
+        processed <- gets $ Map.member fileName
+        unless processed $ do
+            print ("Preprocessing '" ++ fileName ++ ".pas'... ")
+            fc' <- liftIO
+                $ tryJust (guard . isDoesNotExistError)
+                $ preprocess inputPath alternateInputPath (fileName ++ ".pas")
+            case fc' of
+                (Left a) -> do
+                    modify (Map.insert fileName (System []))
+                    printLn "doesn't exist"
+                (Right fc) -> do
+                    print "ok, parsing... "
+                    let ptree = parse pascalUnit fileName fc
+                    case ptree of
+                         (Left a) -> do
+                            liftIO $ writeFile (outputPath ++ "preprocess.out") fc
+                            printLn $ show a ++ "\nsee preprocess.out for preprocessed source"
+                            fail "stop"
+                         (Right a) -> do
+                            printLn "ok"
+                            modify (Map.insert fileName a)
+                            mapM_ f (usesFiles a)
+
+
+renderCFiles :: Map.Map String PascalUnit -> String -> IO ()
+renderCFiles units outputPath = do
+    let u = Map.toList units
+    let nss = Map.map (toNamespace nss) units
+    --hPutStrLn stderr $ "Units: " ++ (show . Map.keys . Map.filter (not . Map.null) $ nss)
+    --writeFile "pas2c.log" $ unlines . map (\t -> show (fst t) ++ "\n" ++ (unlines . map ((:) '\t' . show) . snd $ t)) . Map.toList $ nss
+    mapM_ (toCFiles outputPath nss) u
+    where
+    toNamespace :: Map.Map String Records -> PascalUnit -> Records
+    toNamespace nss (System tvs) =
+        currentScope $ execState f (emptyState nss)
+        where
+        f = do
+            checkDuplicateFunDecls tvs
+            mapM_ (tvar2C True False True False) tvs
+    toNamespace nss (Redo tvs) = -- functions that are re-implemented, add prefix to all of them
+        currentScope $ execState f (emptyState nss){currentUnit = "fpcrtl_"}
+        where
+        f = do
+            checkDuplicateFunDecls tvs
+            mapM_ (tvar2C True False True False) tvs
+    toNamespace _ (Program {}) = Map.empty
+    toNamespace nss (Unit (Identifier i _) interface _ _ _) =
+        currentScope $ execState (interface2C interface True) (emptyState nss){currentUnit = map toLower i ++ "_"}
+
+
+withState' :: (RenderState -> RenderState) -> State RenderState a -> State RenderState a
+withState' f sf = do
+    st <- liftM f get
+    let (a, s) = runState sf st
+    modify(\st -> st{
+        lastType = lastType s
+        , uniqCounter = uniqCounter s
+        , stringConsts = stringConsts s
+        })
+    return a
+
+withLastIdNamespace f = do
+    li <- gets lastIdentifier
+    nss <- gets namespaces
+    withState' (\st -> st{currentScope = fromMaybe Map.empty $ Map.lookup li (namespaces st)}) f
+
+withRecordNamespace :: String -> [Record] -> State RenderState Doc -> State RenderState Doc
+withRecordNamespace _ [] = error "withRecordNamespace: empty record"
+withRecordNamespace prefix recs = withState' f
+    where
+        f st = st{currentScope = Map.unionWith un records (currentScope st), currentUnit = ""}
+        records = Map.fromList $ map (\(Record a b d) -> (map toLower a, [Record (prefix ++ a) b d])) recs
+        un [a] b = a : b
+
+toCFiles :: String -> Map.Map String Records -> (String, PascalUnit) -> IO ()
+toCFiles _ _ (_, System _) = return ()
+toCFiles _ _ (_, Redo _) = return ()
+toCFiles outputPath ns p@(fn, pu) = do
+    hPutStrLn stdout $ "Rendering '" ++ fn ++ "'..."
+    toCFiles' p
+    where
+    toCFiles' (fn, p@(Program {})) = writeFile (outputPath ++ fn ++ ".c") $ "#include \"fpcrtl.h\"\n" ++ (render2C initialState . pascal2C) p
+    toCFiles' (fn, (Unit unitId@(Identifier i _) interface implementation _ _)) = do
+        let (a, s) = runState (id2C IOInsert (setBaseType BTUnit unitId) >> interface2C interface True) initialState{currentUnit = map toLower i ++ "_"}
+            (a', s') = runState (id2C IOInsert (setBaseType BTUnit unitId) >> interface2C interface False) initialState{currentUnit = map toLower i ++ "_"}
+        writeFile (outputPath ++ fn ++ ".h") $ "#pragma once\n\n#include \"pas2c.h\"\n\n" ++ (render (a $+$ text ""))
+        writeFile (outputPath ++ fn ++ ".c") $ "#include \"fpcrtl.h\"\n\n#include \"" ++ fn ++ ".h\"\n" ++ render (a' $+$ text "") ++ (render2C s . implementation2C) implementation
+    initialState = emptyState ns
+
+    render2C :: RenderState -> State RenderState Doc -> String
+    render2C a = render . ($+$ empty) . flip evalState a
+
+
+usesFiles :: PascalUnit -> [String]
+usesFiles (Program _ (Implementation uses _) _) = ["pas2cSystem", "pas2cRedo"] ++ uses2List uses
+usesFiles (Unit _ (Interface uses1 _) (Implementation uses2 _) _ _) = ["pas2cSystem", "pas2cRedo"] ++ uses2List uses1 ++ uses2List uses2
+usesFiles (System {}) = []
+usesFiles (Redo {}) = []
+
+pascal2C :: PascalUnit -> State RenderState Doc
+pascal2C (Unit _ interface implementation init fin) =
+    liftM2 ($+$) (interface2C interface True) (implementation2C implementation)
+
+pascal2C (Program _ implementation mainFunction) = do
+    impl <- implementation2C implementation
+    [main] <- tvar2C True False True True (FunctionDeclaration (Identifier "main" BTInt) False (SimpleType $ Identifier "int" BTInt) [VarDeclaration False False ([Identifier "argc" BTInt], SimpleType (Identifier "Integer" BTInt)) Nothing, VarDeclaration False False ([Identifier "argv" BTUnknown], SimpleType (Identifier "PPChar" BTUnknown)) Nothing] (Just (TypesAndVars [], mainFunction)))
+    return $ impl $+$ main
+
+
+-- the second bool indicates whether do normal interface translation or generate variable declarations
+-- that will be inserted into implementation files
+interface2C :: Interface -> Bool -> State RenderState Doc
+interface2C (Interface uses tvars) True = do
+    u <- uses2C uses
+    tv <- typesAndVars2C True True True tvars
+    r <- renderStringConsts
+    return (u $+$ r $+$ tv)
+interface2C (Interface uses tvars) False = do
+    u <- uses2C uses
+    tv <- typesAndVars2C True False False tvars
+    r <- renderStringConsts
+    return tv
+
+implementation2C :: Implementation -> State RenderState Doc
+implementation2C (Implementation uses tvars) = do
+    u <- uses2C uses
+    tv <- typesAndVars2C True False True tvars
+    r <- renderStringConsts
+    return (u $+$ r $+$ tv)
+
+checkDuplicateFunDecls :: [TypeVarDeclaration] -> State RenderState ()
+checkDuplicateFunDecls tvs =
+    modify $ \s -> s{toMangle = Map.keysSet . Map.filter (> 1) . foldr ins initMap $ tvs}
+    where
+        initMap = Map.empty
+        --initMap = Map.fromList [("reset", 2)]
+        ins (FunctionDeclaration (Identifier i _) _ _ _ _) m = Map.insertWith (+) (map toLower i) 1 m
+        ins _ m = m
+
+-- the second bool indicates whether declare variable as extern or not
+-- the third bool indicates whether include types or not
+
+typesAndVars2C :: Bool -> Bool -> Bool -> TypesAndVars -> State RenderState Doc
+typesAndVars2C b externVar includeType(TypesAndVars ts) = do
+    checkDuplicateFunDecls ts
+    liftM (vcat . map (<> semi) . concat) $ mapM (tvar2C b externVar includeType False) ts
+
+setBaseType :: BaseType -> Identifier -> Identifier
+setBaseType bt (Identifier i _) = Identifier i bt
+
+uses2C :: Uses -> State RenderState Doc
+uses2C uses@(Uses unitIds) = do
+
+    mapM_ injectNamespace (Identifier "pas2cSystem" undefined : unitIds)
+    mapM_ injectNamespace (Identifier "pas2cRedo" undefined : unitIds)
+    mapM_ (id2C IOInsert . setBaseType BTUnit) unitIds
+    return $ vcat . map (\i -> text $ "#include \"" ++ i ++ ".h\"") $ uses2List uses
+    where
+    injectNamespace (Identifier i _) = do
+        getNS <- gets (flip Map.lookup . namespaces)
+        modify (\s -> s{currentScope = Map.unionWith (++) (fromMaybe Map.empty (getNS i)) $ currentScope s})
+
+uses2List :: Uses -> [String]
+uses2List (Uses ids) = map (\(Identifier i _) -> i) ids
+
+
+setLastIdValues vv = (\s -> s{lastType = baseType vv, lastIdentifier = lcaseId vv, lastIdTypeDecl = typeDecl vv})
+
+id2C :: InsertOption -> Identifier -> State RenderState Doc
+id2C IOInsert i = id2C (IOInsertWithType empty) i
+id2C (IOInsertWithType d) (Identifier i t) = do
+    ns <- gets currentScope
+    tom <- gets (Set.member n . toMangle)
+    cu <- gets currentUnit
+    let (i', t') = case (t, tom) of
+            (BTFunction _ p _, True) -> (cu ++ i ++ ('_' : show p), t)
+            (BTFunction _ _ _, _) -> (cu ++ i, t)
+            (BTVarParam t', _) -> ('(' : '*' : i ++ ")" , t')
+            _ -> (i, t)
+    modify (\s -> s{currentScope = Map.insertWith (++) n [Record i' t' d] (currentScope s), lastIdentifier = n})
+    return $ text i'
+    where
+        n = map toLower i
+
+id2C IOLookup i = id2CLookup head i
+id2C IOLookupLast i = id2CLookup last i
+id2C (IOLookupFunction params) (Identifier i t) = do
+    let i' = map toLower i
+    v <- gets $ Map.lookup i' . currentScope
+    lt <- gets lastType
+    if isNothing v then
+        error $ "Not defined: '" ++ i' ++ "'\n" ++ show lt ++ "\nwith num of params = " ++ show params ++ "\n" ++ show v
+        else
+        let vv = fromMaybe (head $ fromJust v) . find checkParam $ fromJust v in
+            modify (setLastIdValues vv) >> (return . text . lcaseId $ vv)
+    where
+        checkParam (Record _ (BTFunction _ p _) _) = p == params
+        checkParam _ = False
+id2C IODeferred (Identifier i t) = do
+    let i' = map toLower i
+    v <- gets $ Map.lookup i' . currentScope
+    if (isNothing v) then
+        modify (\s -> s{lastType = BTUnknown, lastIdentifier = i}) >> return (text i)
+        else
+        let vv = head $ fromJust v in modify (setLastIdValues vv) >> (return . text . lcaseId $ vv)
+
+id2CLookup :: ([Record] -> Record) -> Identifier -> State RenderState Doc
+id2CLookup f (Identifier i t) = do
+    let i' = map toLower i
+    v <- gets $ Map.lookup i' . currentScope
+    lt <- gets lastType
+    if isNothing v then
+        error $ "Not defined: '" ++ i' ++ "'\n" ++ show lt
+        else
+        let vv = f $ fromJust v in modify (setLastIdValues vv) >> (return . text . lcaseId $ vv)
+
+
+id2CTyped :: TypeDecl -> Identifier -> State RenderState Doc
+id2CTyped = id2CTyped2 Nothing
+
+id2CTyped2 :: Maybe Doc -> TypeDecl -> Identifier -> State RenderState Doc
+id2CTyped2 md t (Identifier i _) = do
+    tb <- resolveType t
+    case (t, tb) of
+        (_, BTUnknown) -> do
+            error $ "id2CTyped: type BTUnknown for " ++ show i ++ "\ntype: " ++ show t
+        (SimpleType {}, BTRecord _ r) -> do
+            ts <- type2C t
+            id2C (IOInsertWithType $ ts empty) (Identifier i (BTRecord (render $ ts empty) r))
+        (_, BTRecord _ r) -> do
+            ts <- type2C t
+            id2C (IOInsertWithType $ ts empty) (Identifier i (BTRecord i r))
+        _ -> case md of
+                Nothing -> id2C IOInsert (Identifier i tb)
+                Just ts -> id2C (IOInsertWithType ts) (Identifier i tb)
+
+
+resolveType :: TypeDecl -> State RenderState BaseType
+resolveType st@(SimpleType (Identifier i _)) = do
+    let i' = map toLower i
+    v <- gets $ Map.lookup i' . currentScope
+    if isJust v then return . baseType . head $ fromJust v else return $ f i'
+    where
+    f "integer" = BTInt
+    f "pointer" = BTPointerTo BTVoid
+    f "boolean" = BTBool
+    f "float" = BTFloat
+    f "char" = BTChar
+    f "string" = BTString
+    f _ = error $ "Unknown system type: " ++ show st
+resolveType (PointerTo (SimpleType (Identifier i _))) = return . BTPointerTo $ BTUnresolved (map toLower i)
+resolveType (PointerTo t) = liftM BTPointerTo $ resolveType t
+resolveType (RecordType tv mtvs) = do
+    tvs <- mapM f (concat $ tv : fromMaybe [] mtvs)
+    return . BTRecord "" . concat $ tvs
+    where
+        f :: TypeVarDeclaration -> State RenderState [(String, BaseType)]
+        f (VarDeclaration _ _ (ids, td) _) = mapM (\(Identifier i _) -> liftM ((,) i) $ resolveType td) ids
+resolveType (ArrayDecl (Just i) t) = do
+    t' <- resolveType t
+    return $ BTArray i BTInt t'
+resolveType (ArrayDecl Nothing t) = liftM (BTArray RangeInfinite BTInt) $ resolveType t
+resolveType (FunctionType t a) = liftM (BTFunction False (length a)) $ resolveType t
+resolveType (DeriveType (InitHexNumber _)) = return BTInt
+resolveType (DeriveType (InitNumber _)) = return BTInt
+resolveType (DeriveType (InitFloat _)) = return BTFloat
+resolveType (DeriveType (InitString _)) = return BTString
+resolveType (DeriveType (InitBinOp {})) = return BTInt
+resolveType (DeriveType (InitPrefixOp _ e)) = initExpr2C e >> gets lastType
+resolveType (DeriveType (BuiltInFunction{})) = return BTInt
+resolveType (DeriveType (InitReference (Identifier{}))) = return BTBool -- TODO: derive from actual type
+resolveType (DeriveType _) = return BTUnknown
+resolveType (String _) = return BTString
+resolveType VoidType = return BTVoid
+resolveType (Sequence ids) = return $ BTEnum $ map (\(Identifier i _) -> map toLower i) ids
+resolveType (RangeType _) = return $ BTVoid
+resolveType (Set t) = liftM BTSet $ resolveType t
+resolveType (VarParamType t) = liftM BTVarParam $ resolveType t
+
+
+resolve :: String -> BaseType -> State RenderState BaseType
+resolve s (BTUnresolved t) = do
+    v <- gets $ Map.lookup t . currentScope
+    if isJust v then
+        resolve s . baseType . head . fromJust $ v
+        else
+        error $ "Unknown type " ++ show t ++ "\n" ++ s
+resolve _ t = return t
+
+fromPointer :: String -> BaseType -> State RenderState BaseType
+fromPointer s (BTPointerTo t) = resolve s t
+fromPointer s t = do
+    error $ "Dereferencing from non-pointer type " ++ show t ++ "\n" ++ s
+
+
+functionParams2C params = liftM (hcat . punctuate comma . concat) $ mapM (tvar2C False False True True) params
+
+numberOfDeclarations :: [TypeVarDeclaration] -> Int
+numberOfDeclarations = sum . map cnt
+    where
+        cnt (VarDeclaration _ _ (ids, _) _) = length ids
+        cnt _ = 1
+
+hasPassByReference :: [TypeVarDeclaration] -> Bool
+hasPassByReference = or . map isVar
+    where
+        isVar (VarDeclaration v _ (_, _) _) = v
+        isVar _ = error $ "hasPassByReference called not on function parameters"
+
+toIsVarList :: [TypeVarDeclaration] -> [Bool]
+toIsVarList = concatMap isVar
+    where
+        isVar (VarDeclaration v _ (p, _) _) = replicate (length p) v
+        isVar _ = error $ "toIsVarList called not on function parameters"
+
+
+funWithVarsToDefine :: String -> [TypeVarDeclaration] -> Doc
+funWithVarsToDefine n params = text "#define" <+> text n <> parens abc <+> text (n ++ "__vars") <> parens cparams
+    where
+        abc = hcat . punctuate comma . map (char . fst) $ ps
+        cparams = hcat . punctuate comma . map (\(c, v) -> if v then char '&' <> parens (char c) else char c) $ ps
+        ps = zip ['a'..] (toIsVarList params)
+
+fun2C :: Bool -> String -> TypeVarDeclaration -> State RenderState [Doc]
+fun2C _ _ (FunctionDeclaration name inline returnType params Nothing) = do
+    t <- type2C returnType
+    t'<- gets lastType
+    p <- withState' id $ functionParams2C params
+    n <- liftM render . id2C IOInsert $ setBaseType (BTFunction hasVars (numberOfDeclarations params) t') name
+    let decor = if inline then text "inline" else empty
+    if hasVars then
+        return [funWithVarsToDefine n params $+$ decor <+> t empty <+> text (n ++ "__vars") <> parens p]
+        else
+        return [decor <+> t empty <+> text n <> parens p]
+    where
+        hasVars = hasPassByReference params
+
+
+fun2C True rv (FunctionDeclaration name@(Identifier i _) inline returnType params (Just (tvars, phrase))) = do
+    let res = docToLower $ text rv <> text "_result"
+    t <- type2C returnType
+    t'<- gets lastType
+
+    notDeclared <- liftM isNothing . gets $ Map.lookup (map toLower i) . currentScope
+
+    n <- liftM render . id2C IOInsert $ setBaseType (BTFunction hasVars (numberOfDeclarations params) t') name
+
+    let isVoid = case returnType of
+            VoidType -> True
+            _ -> False
+
+    (p, ph) <- withState' (\st -> st{currentScope = Map.insertWith un (map toLower rv) [Record (render res) t' empty] $ currentScope st
+            , currentFunctionResult = if isVoid then [] else render res}) $ do
+        p <- functionParams2C params
+        ph <- liftM2 ($+$) (typesAndVars2C False False True tvars) (phrase2C' phrase)
+        return (p, ph)
+
+    let phrasesBlock = if isVoid then ph else t empty <+> res <> semi $+$ ph $+$ text "return" <+> res <> semi
+    let define = if hasVars then text "#ifndef" <+> text n $+$ funWithVarsToDefine n params $+$ text "#endif" else empty
+    let decor = if inline then text "inline" else empty
+    return [
+        define
+        $+$
+        --(if notDeclared && hasVars then funWithVarsToDefine n params else empty) $+$
+        decor <+> t empty <+> text (if hasVars then n ++ "__vars" else n) <> parens p
+        $+$
+        text "{"
+        $+$
+        nest 4 phrasesBlock
+        $+$
+        text "}"]
+    where
+    phrase2C' (Phrases p) = liftM vcat $ mapM phrase2C p
+    phrase2C' p = phrase2C p
+    un [a] b = a : b
+    hasVars = hasPassByReference params
+
+fun2C False _ (FunctionDeclaration (Identifier name _) _ _ _ _) = error $ "nested functions not allowed: " ++ name
+fun2C _ tv _ = error $ "fun2C: I don't render " ++ show tv
+
+-- the second bool indicates whether declare variable as extern or not
+-- the third bool indicates whether include types or not
+-- the fourth bool indicates whether ignore initialization or not (basically for dynamic arrays since we cannot do initialization in function params)
+tvar2C :: Bool -> Bool -> Bool -> Bool -> TypeVarDeclaration -> State RenderState [Doc]
+tvar2C b _ includeType _ f@(FunctionDeclaration (Identifier name _) _ _ _ _) = do
+    t <- fun2C b name f
+    if includeType then return t else return []
+tvar2C _ _ includeType _ td@(TypeDeclaration i' t) = do
+    i <- id2CTyped t i'
+    tp <- type2C t
+    return $ if includeType then [text "typedef" <+> tp i] else []
+
+tvar2C _ _ _ _ (VarDeclaration True _ (ids, t) Nothing) = do
+    t' <- liftM ((empty <+>) . ) $ type2C t
+    liftM (map(\i -> t' i)) $ mapM (id2CTyped2 (Just $ t' empty) (VarParamType t)) ids
+
+tvar2C _ externVar includeType ignoreInit (VarDeclaration _ isConst (ids, t) mInitExpr) = do
+    t' <- liftM (((if isConst then text "static const" else if externVar 
+                                                                then text "extern"
+                                                                else empty)
+                   <+>) . ) $ type2C t
+    ie <- initExpr mInitExpr
+    lt <- gets lastType
+    case (isConst, lt, ids, mInitExpr) of
+         (True, BTInt, [i], Just _) -> do
+             i' <- id2CTyped t i
+             return $ if includeType then [text "enum" <> braces (i' <+> ie)] else []
+         (True, BTFloat, [i], Just e) -> do
+             i' <- id2CTyped t i
+             ie <- initExpr2C e
+             return $ if includeType then [text "#define" <+> i' <+> parens ie <> text "\n"] else []
+         (_, BTFunction{}, _, Nothing) -> liftM (map(\i -> t' i)) $ mapM (id2CTyped t) ids
+         (_, BTArray r _ _, [i], _) -> do
+            i' <- id2CTyped t i
+            ie' <- return $ case (r, mInitExpr, ignoreInit) of
+                (RangeInfinite, Nothing, False) -> text "= NULL" -- force dynamic array to be initialized as NULL if not initialized at all
+                (_, _, _) -> ie
+            result <- liftM (map(\i -> varDeclDecision isConst includeType (t' i) ie')) $ mapM (id2CTyped t) ids           
+            case (r, ignoreInit) of
+                (RangeInfinite, False) -> 
+                    -- if the array is dynamic, add dimension info to it
+                    return $ [dimDecl] ++ result
+                    where 
+                        arrayDimStr = show $ arrayDimension t
+                        arrayDimInitExp = text ("={" ++ ".dim = " ++ arrayDimStr ++ ", .a = {0, 0, 0, 0}}")
+                        dimDecl = varDeclDecision isConst includeType (text "fpcrtl_dimension_t" <+>  i' <> text "_dimension_info") arrayDimInitExp
+                    
+                (_, _) -> return result
+            
+         _ -> liftM (map(\i -> varDeclDecision isConst includeType (t' i) ie)) $ mapM (id2CTyped2 (Just $ t' empty) t) ids
+    where
+    initExpr Nothing = return $ empty
+    initExpr (Just e) = liftM (text "=" <+>) (initExpr2C e)
+    varDeclDecision True True varStr expStr = varStr <+> expStr
+    varDeclDecision False True varStr expStr = if externVar then varStr else varStr <+> expStr
+    varDeclDecision False False varStr expStr = varStr <+> expStr
+    varDeclDecision True False varStr expStr = empty
+    arrayDimension a = case a of
+        ArrayDecl Nothing t -> let a = arrayDimension t in if a > 3 then error "Dynamic array with dimension > 4 is not supported." else 1 + arrayDimension t
+        ArrayDecl _ _ -> error "Mixed dynamic array and static array are not supported."
+        _ -> 0
+
+tvar2C f _ _ _ (OperatorDeclaration op (Identifier i _) inline ret params body) = do
+    r <- op2CTyped op (extractTypes params)
+    fun2C f i (FunctionDeclaration r inline ret params body)
+
+
+op2CTyped :: String -> [TypeDecl] -> State RenderState Identifier
+op2CTyped op t = do
+    t' <- liftM (render . hcat . punctuate (char '_') . map (\t -> t empty)) $ mapM type2C t
+    bt <- gets lastType
+    return $ Identifier (t' ++ "_op_" ++ opStr) bt
+    where
+    opStr = case op of
+                    "+" -> "add"
+                    "-" -> "sub"
+                    "*" -> "mul"
+                    "/" -> "div"
+                    "/(float)" -> "div"
+                    "=" -> "eq"
+                    "<" -> "lt"
+                    ">" -> "gt"
+                    "<>" -> "neq"
+                    _ -> error $ "op2CTyped: unknown op '" ++ op ++ "'"
+
+extractTypes :: [TypeVarDeclaration] -> [TypeDecl]
+extractTypes = concatMap f
+    where
+        f (VarDeclaration _ _ (ids, t) _) = replicate (length ids) t
+        f a = error $ "extractTypes: can't extract from " ++ show a
+
+initExpr2C, initExpr2C' :: InitExpression -> State RenderState Doc
+initExpr2C (InitArray values) = liftM (braces . vcat . punctuate comma) $ mapM initExpr2C values
+initExpr2C a = initExpr2C' a
+initExpr2C' InitNull = return $ text "NULL"
+initExpr2C' (InitAddress expr) = do
+    ie <- initExpr2C' expr
+    lt <- gets lastType
+    case lt of
+        BTFunction True _ _ -> return $ text "&" <> ie <> text "__vars"
+        _ -> return $ text "&" <> ie
+initExpr2C' (InitPrefixOp op expr) = liftM (text (op2C op) <>) (initExpr2C' expr)
+initExpr2C' (InitBinOp op expr1 expr2) = do
+    e1 <- initExpr2C' expr1
+    e2 <- initExpr2C' expr2
+    return $ parens $ e1 <+> text (op2C op) <+> e2
+initExpr2C' (InitNumber s) = return $ text s
+initExpr2C' (InitFloat s) = return $ text s
+initExpr2C' (InitHexNumber s) = return $ text "0x" <> (text . map toLower $ s)
+initExpr2C' (InitString [a]) = return . quotes $ text [a]
+initExpr2C' (InitString s) = return $ strInit s
+initExpr2C' (InitChar a) = return $ quotes $ text "\\x" <> text (showHex (read a) "")
+initExpr2C' (InitReference i) = id2C IOLookup i
+initExpr2C' (InitRecord fields) = do
+    (fs :: [Doc]) <- mapM (\(Identifier a _, b) -> liftM (text "." <> text a <+> equals <+>) $ initExpr2C b) fields
+    return $ lbrace $+$ (nest 4 . vcat . punctuate comma $ fs) $+$ rbrace
+initExpr2C' (InitArray [value]) = initExpr2C value
+initExpr2C' r@(InitRange (Range i@(Identifier i' _))) = do
+    id2C IOLookup i
+    t <- gets lastType
+    case t of
+         BTEnum s -> return . int $ length s
+         BTInt -> case i' of
+                       "byte" -> return $ int 256
+                       _ -> error $ "InitRange identifier: " ++ i'
+         _ -> error $ "InitRange: " ++ show r
+initExpr2C' (InitRange (RangeFromTo (InitNumber "0") r)) = initExpr2C $ BuiltInFunction "succ" [r]
+initExpr2C' (InitRange (RangeFromTo (InitChar "0") (InitChar r))) = initExpr2C $ BuiltInFunction "succ" [InitNumber r]
+initExpr2C' (InitRange a) = error $ show a --return $ text "<<range>>"
+initExpr2C' (InitSet []) = return $ text "0"
+initExpr2C' (InitSet a) = return $ text "<<set>>"
+initExpr2C' (BuiltInFunction "low" [InitReference e]) = return $
+    case e of
+         (Identifier "LongInt" _) -> int (-2^31)
+         (Identifier "SmallInt" _) -> int (-2^15)
+         _ -> error $ "BuiltInFunction 'low': " ++ show e
+initExpr2C' (BuiltInFunction "high" [e]) = do
+    initExpr2C e
+    t <- gets lastType
+    case t of
+         (BTArray i _ _) -> initExpr2C' $ BuiltInFunction "pred" [InitRange i]
+         a -> error $ "BuiltInFunction 'high': " ++ show a
+initExpr2C' (BuiltInFunction "succ" [BuiltInFunction "pred" [e]]) = initExpr2C' e
+initExpr2C' (BuiltInFunction "pred" [BuiltInFunction "succ" [e]]) = initExpr2C' e
+initExpr2C' (BuiltInFunction "succ" [e]) = liftM (<> text " + 1") $ initExpr2C' e
+initExpr2C' (BuiltInFunction "pred" [e]) = liftM (<> text " - 1") $ initExpr2C' e
+initExpr2C' b@(BuiltInFunction _ _) = error $ show b
+initExpr2C' a = error $ "initExpr2C: don't know how to render " ++ show a
+
+
+range2C :: InitExpression -> State RenderState [Doc]
+range2C (InitString [a]) = return [quotes $ text [a]]
+range2C (InitRange (Range i)) = liftM (flip (:) []) $ id2C IOLookup i
+range2C (InitRange (RangeFromTo (InitString [a]) (InitString [b]))) = return $ map (\i -> quotes $ text [i]) [a..b]
+range2C a = liftM (flip (:) []) $ initExpr2C a
+
+baseType2C :: String -> BaseType -> Doc
+baseType2C _ BTFloat = text "float"
+baseType2C _ BTBool = text "bool"
+baseType2C _ BTString = text "string255"
+baseType2C s a = error $ "baseType2C: " ++ show a ++ "\n" ++ s
+
+type2C :: TypeDecl -> State RenderState (Doc -> Doc)
+type2C (SimpleType i) = liftM (\i a -> i <+> a) $ id2C IOLookup i
+type2C t = do
+    r <- type2C' t
+    rt <- resolveType t
+    modify (\st -> st{lastType = rt})
+    return r
+    where
+    type2C' VoidType = return (text "void" <+>)
+    type2C' (String l) = return (text "string255" <+>)--return (text ("string" ++ show l) <+>)
+    type2C' (PointerTo (SimpleType i)) = do
+        i' <- id2C IODeferred i
+        lt <- gets lastType
+        case lt of
+             BTRecord _ _ -> return $ \a -> text "struct __" <> i' <+> text "*" <+> a
+             BTUnknown -> return $ \a -> text "struct __" <> i' <+> text "*" <+> a
+             _ -> return $ \a -> i' <+> text "*" <+> a
+    type2C' (PointerTo t) = liftM (\t a -> t (parens $ text "*" <> a)) $ type2C t
+    type2C' (RecordType tvs union) = do
+        t <- withState' f $ mapM (tvar2C False False True False) tvs
+        u <- unions
+        return $ \i -> text "struct __" <> i <+> lbrace $+$ nest 4 ((vcat . map (<> semi) . concat $ t) $$ u) $+$ rbrace <+> i
+        where
+            f s = s{currentUnit = ""}
+            unions = case union of
+                     Nothing -> return empty
+                     Just a -> do
+                         structs <- mapM struct2C a
+                         return $ text "union" $+$ braces (nest 4 $ vcat structs) <> semi
+            struct2C tvs = do
+                t <- withState' f $ mapM (tvar2C False False True False) tvs
+                return $ text "struct" $+$ braces (nest 4 (vcat . map (<> semi) . concat $ t)) <> semi
+    type2C' (RangeType r) = return (text "int" <+>)
+    type2C' (Sequence ids) = do
+        is <- mapM (id2C IOInsert . setBaseType bt) ids
+        return (text "enum" <+> (braces . vcat . punctuate comma . map (\(a, b) -> a <+> equals <+> text "0x" <> text (showHex b "")) $ zip is [0..]) <+>)
+        where
+            bt = BTEnum $ map (\(Identifier i _) -> map toLower i) ids
+    type2C' (ArrayDecl Nothing t) = type2C (PointerTo t)
+    type2C' (ArrayDecl (Just r) t) = do
+        t' <- type2C t
+        lt <- gets lastType
+        ft <- case lt of
+                -- BTFunction {} -> type2C (PointerTo t)
+                _ -> return t'
+        r' <- initExpr2C (InitRange r)
+        return $ \i -> ft i <> brackets r'
+    type2C' (Set t) = return (text "<<set>>" <+>)
+    type2C' (FunctionType returnType params) = do
+        t <- type2C returnType
+        p <- withState' id $ functionParams2C params
+        return (\i -> (t empty <> (parens $ text "*" <> i) <> parens p))
+    type2C' (DeriveType (InitBinOp _ _ i)) = type2C' (DeriveType i)
+    type2C' (DeriveType (InitPrefixOp _ i)) = type2C' (DeriveType i)
+    type2C' (DeriveType (InitNumber _)) = return (text "int" <+>)
+    type2C' (DeriveType (InitHexNumber _)) = return (text "int" <+>)
+    type2C' (DeriveType (InitFloat _)) = return (text "float" <+>)
+    type2C' (DeriveType (BuiltInFunction {})) = return (text "int" <+>)
+    type2C' (DeriveType (InitString {})) = return (text "string255" <+>)
+    type2C' (DeriveType r@(InitReference {})) = do
+        initExpr2C r
+        t <- gets lastType
+        return (baseType2C (show r) t <+>)
+    type2C' (DeriveType a) = error $ "Can't derive type from " ++ show a
+
+phrase2C :: Phrase -> State RenderState Doc
+phrase2C (Phrases p) = do
+    ps <- mapM phrase2C p
+    return $ text "{" $+$ (nest 4 . vcat $ ps) $+$ text "}"
+phrase2C (ProcCall f@(FunCall {}) []) = liftM (<> semi) $ ref2C f
+phrase2C (ProcCall ref []) = liftM (<> semi) $ ref2CF ref
+phrase2C (ProcCall ref params) = error $ "ProcCall"{-do
+    r <- ref2C ref
+    ps <- mapM expr2C params
+    return $ r <> parens (hsep . punctuate (char ',') $ ps) <> semi -}
+phrase2C (IfThenElse (expr) phrase1 mphrase2) = do
+    e <- expr2C expr
+    p1 <- (phrase2C . wrapPhrase) phrase1
+    el <- elsePart
+    return $
+        text "if" <> parens e $+$ p1 $+$ el
+    where
+    elsePart | isNothing mphrase2 = return $ empty
+             | otherwise = liftM (text "else" $$) $ (phrase2C . wrapPhrase) (fromJust mphrase2)
+phrase2C (Assignment ref expr) = do
+    r <- ref2C ref
+    t <- gets lastType
+    case (t, expr) of
+        (BTFunction {}, (Reference r')) -> do
+            e <- ref2C r'
+            return $ r <+> text "=" <+> e <> semi
+        (BTString, _) -> do
+            e <- expr2C expr
+            lt <- gets lastType
+            case lt of
+                -- assume pointer to char for simplicity
+                BTPointerTo _ -> do
+                    e <- expr2C $ Reference $ FunCall [Reference $ RefExpression expr] (SimpleReference (Identifier "pchar2str" BTUnknown))
+                    return $ r <+> text "=" <+> e <> semi
+                BTString -> do
+                    e <- expr2C expr
+                    return $ r <+> text "=" <+> e <> semi
+                _ -> error $ "Assignment to string from " ++ show lt
+        (BTArray _ _ _, _) -> do
+            case expr of
+                Reference er -> do
+                    exprRef <- ref2C er
+                    exprT <- gets lastType
+                    case exprT of
+                        BTArray RangeInfinite _ _ ->
+                            return $ text "FIXME: assign a dynamic array to an array"
+                        BTArray _ _ _ -> phrase2C $
+                                ProcCall (FunCall
+                                    [
+                                    Reference $ ref
+                                    , Reference $ RefExpression expr
+                                    , Reference $ FunCall [expr] (SimpleReference (Identifier "sizeof" BTUnknown))
+                                    ]
+                                    (SimpleReference (Identifier "memcpy" BTUnknown))
+                                    ) []
+                        _ -> return $ text "FIXME: assign a non-specific value to an array"
+
+                _ -> return $ text "FIXME: dynamic array assignment 2"
+        _ -> do
+            e <- expr2C expr
+            return $ r <+> text "=" <+> e <> semi
+phrase2C (WhileCycle expr phrase) = do
+    e <- expr2C expr
+    p <- phrase2C $ wrapPhrase phrase
+    return $ text "while" <> parens e $$ p
+phrase2C (SwitchCase expr cases mphrase) = do
+    e <- expr2C expr
+    cs <- mapM case2C cases
+    d <- dflt
+    return $
+        text "switch" <> parens e $+$ braces (nest 4 . vcat $ cs ++ d)
+    where
+    case2C :: ([InitExpression], Phrase) -> State RenderState Doc
+    case2C (e, p) = do
+        ies <- mapM range2C e
+        ph <- phrase2C p
+        return $
+             vcat (map (\i -> text "case" <+> i <> colon) . concat $ ies) <> nest 4 (ph $+$ text "break;")
+    dflt | isNothing mphrase = return [text "default: break;"] -- avoid compiler warning
+         | otherwise = do
+             ph <- mapM phrase2C $ fromJust mphrase
+             return [text "default:" <+> nest 4 (vcat ph)]
+
+phrase2C wb@(WithBlock ref p) = do
+    r <- ref2C ref
+    t <- gets lastType
+    case t of
+        (BTRecord _ rs) -> withRecordNamespace (render r ++ ".") (rec2Records rs) $ phrase2C $ wrapPhrase p
+        a -> do
+            error $ "'with' block referencing non-record type " ++ show a ++ "\n" ++ show wb
+phrase2C (ForCycle i' e1' e2' p up) = do
+    i <- id2C IOLookup i'
+    iType <- gets lastIdTypeDecl
+    e1 <- expr2C e1'
+    e2 <- expr2C e2'
+    let inc = if up then "inc" else "dec"
+    let add = if up then "+ 1" else "- 1"
+    let iEnd = i <> text "__end__"
+    ph <- phrase2C . appendPhrase (BuiltInFunctionCall [Reference $ SimpleReference i'] (SimpleReference (Identifier inc BTUnknown))) $ wrapPhrase p
+    return . braces $
+        i <+> text "=" <+> e1 <> semi
+        $$
+        iType <+> iEnd <+> text "=" <+> e2 <> semi
+        $$ 
+        text "if" <+> (parens $ i <+> text "<=" <+> iEnd) <+> text "do" <+> ph <+>
+        text "while" <> parens (i <+> text "!=" <+> iEnd <+> text add) <> semi
+    where
+        appendPhrase p (Phrases ps) = Phrases $ ps ++ [p]
+phrase2C (RepeatCycle e' p') = do
+    e <- expr2C e'
+    p <- phrase2C (Phrases p')
+    return $ text "do" <+> p <+> text "while" <> parens (text "!" <> parens e) <> semi
+phrase2C NOP = return $ text ";"
+
+phrase2C (BuiltInFunctionCall [] (SimpleReference (Identifier "exit" BTUnknown))) = do
+    f <- gets currentFunctionResult
+    if null f then
+        return $ text "return" <> semi
+        else
+        return $ text "return" <+> text f <> semi
+phrase2C (BuiltInFunctionCall [] (SimpleReference (Identifier "break" BTUnknown))) = return $ text "break" <> semi
+phrase2C (BuiltInFunctionCall [] (SimpleReference (Identifier "continue" BTUnknown))) = return $ text "continue" <> semi
+phrase2C (BuiltInFunctionCall [e] (SimpleReference (Identifier "exit" BTUnknown))) = liftM (\e -> text "return" <+> e <> semi) $ expr2C e
+phrase2C (BuiltInFunctionCall [e] (SimpleReference (Identifier "dec" BTUnknown))) = liftM (\e -> text "--" <> e <> semi) $ expr2C e
+phrase2C (BuiltInFunctionCall [e1, e2] (SimpleReference (Identifier "dec" BTUnknown))) = liftM2 (\a b -> a <> text " -= " <> b <> semi) (expr2C e1) (expr2C e2)
+phrase2C (BuiltInFunctionCall [e] (SimpleReference (Identifier "inc" BTUnknown))) = liftM (\e -> text "++" <> e <> semi) $ expr2C e
+phrase2C (BuiltInFunctionCall [e1, e2] (SimpleReference (Identifier "inc" BTUnknown))) = liftM2 (\a b -> a <+> text "+=" <+> b <> semi) (expr2C e1) (expr2C e2)
+phrase2C a = error $ "phrase2C: " ++ show a
+
+wrapPhrase p@(Phrases _) = p
+wrapPhrase p = Phrases [p]
+
+expr2C :: Expression -> State RenderState Doc
+expr2C (Expression s) = return $ text s
+expr2C b@(BinOp op expr1 expr2) = do
+    e1 <- expr2C expr1
+    t1 <- gets lastType
+    e2 <- expr2C expr2
+    t2 <- gets lastType
+    case (op2C op, t1, t2) of
+        ("+", BTString, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strconcat" (BTFunction False 2 BTString))
+        ("+", BTString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strappend" (BTFunction False 2 BTString))
+        ("+", BTChar, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strprepend" (BTFunction False 2 BTString))
+        ("+", BTChar, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_chrconcat" (BTFunction False 2 BTString))
+        ("==", BTString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcomparec" (BTFunction False 2 BTBool))
+        ("==", BTString, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcompare" (BTFunction False 2 BTBool))
+        ("!=", BTString, _) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strncompare" (BTFunction False 2 BTBool))
+        ("&", BTBool, _) -> return $ parens e1 <+> text "&&" <+> parens e2
+        ("|", BTBool, _) -> return $ parens e1 <+> text "||" <+> parens e2
+        (_, BTRecord t1 _, BTRecord t2 _) -> do
+            i <- op2CTyped op [SimpleType (Identifier t1 undefined), SimpleType (Identifier t2 undefined)]
+            ref2C $ FunCall [expr1, expr2] (SimpleReference i)
+        (_, BTRecord t1 _, BTInt) -> do
+            -- aw, "LongInt" here is hwengine-specific hack
+            i <- op2CTyped op [SimpleType (Identifier t1 undefined), SimpleType (Identifier "LongInt" undefined)]
+            ref2C $ FunCall [expr1, expr2] (SimpleReference i)
+        ("in", _, _) ->
+            case expr2 of
+                 SetExpression set -> do
+                     ids <- mapM (id2C IOLookup) set
+                     modify(\s -> s{lastType = BTBool})
+                     return . parens . hcat . punctuate (text " || ") . map (\i -> parens $ e1 <+> text "==" <+> i) $ ids
+                 _ -> error "'in' against not set expression"
+        (o, _, _) | o `elem` boolOps -> do
+                        modify(\s -> s{lastType = BTBool})
+                        return $ parens e1 <+> text o <+> parens e2
+                  | otherwise -> do
+                        o' <- return $ case o of
+                            "/(float)" -> text "/(float)" -- pascal returns real value
+                            _ -> text o
+                        e1' <- return $ case (o, t1, t2) of
+                                ("-", BTInt, BTInt) -> parens $ text "(int64_t)" <+> parens e1
+                                _ -> parens e1
+                        e2' <- return $ case (o, t1, t2) of
+                                ("-", BTInt, BTInt) -> parens $ text "(int64_t)" <+> parens e2
+                                _ -> parens e2
+                        return $ e1' <+> o' <+> e2'
+    where
+        boolOps = ["==", "!=", "<", ">", "<=", ">="]
+expr2C (NumberLiteral s) = do
+    modify(\s -> s{lastType = BTInt})
+    return $ text s
+expr2C (FloatLiteral s) = return $ text s
+expr2C (HexNumber s) = return $ text "0x" <> (text . map toLower $ s)
+{-expr2C (StringLiteral [a]) = do
+    modify(\s -> s{lastType = BTChar})
+    return . quotes . text $ escape a
+    where
+        escape '\'' = "\\\'"
+        escape a = [a]-}
+expr2C (StringLiteral s) = addStringConst s
+expr2C (PCharLiteral s) = return . doubleQuotes $ text s
+expr2C (Reference ref) = ref2CF ref
+expr2C (PrefixOp op expr) = do
+    e <- expr2C expr
+    lt <- gets lastType
+    case lt of
+        BTRecord t _ -> do
+            i <- op2CTyped op [SimpleType (Identifier t undefined)]
+            ref2C $ FunCall [expr] (SimpleReference i)
+        BTBool -> do
+            o <- return $ case op of
+                     "not" -> text "!"
+                     _ -> text (op2C op)
+            return $ o <> parens e
+        _ -> return $ text (op2C op) <> parens e
+expr2C Null = return $ text "NULL"
+expr2C (CharCode a) = do
+    modify(\s -> s{lastType = BTChar})
+    return $ quotes $ text "\\x" <> text (showHex (read a) "")
+expr2C (HexCharCode a) = if length a <= 2 then return $ quotes $ text "\\x" <> text (map toLower a) else expr2C $ HexNumber a
+expr2C (SetExpression ids) = mapM (id2C IOLookup) ids >>= return . parens . hcat . punctuate (text " | ")
+
+expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "low" _))) = do
+    e' <- liftM (map toLower . render) $ expr2C e
+    lt <- gets lastType
+    case lt of
+         BTEnum a -> return $ int 0
+         BTInt -> case e' of
+                  "longint" -> return $ int (-2147483648)
+         BTArray {} -> return $ int 0
+         _ -> error $ "BuiltInFunCall 'low' from " ++ show e ++ "\ntype: " ++ show lt
+expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "high" _))) = do
+    e' <- liftM (map toLower . render) $ expr2C e
+    lt <- gets lastType
+    case lt of
+         BTEnum a -> return . int $ length a - 1
+         BTInt -> case e' of
+                  "longint" -> return $ int (2147483647)
+         BTString -> return $ int 255
+         BTArray (RangeFromTo _ n) _ _ -> initExpr2C n
+         _ -> error $ "BuiltInFunCall 'high' from " ++ show e ++ "\ntype: " ++ show lt
+expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "ord" _))) = liftM parens $ expr2C e
+expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "succ" _))) = liftM (<> text " + 1") $ expr2C e
+expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "pred" _))) = liftM (<> text " - (int64_t)1") $ expr2C e
+expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "length" _))) = do
+    e' <- expr2C e
+    lt <- gets lastType
+    modify (\s -> s{lastType = BTInt})
+    case lt of
+         BTString -> return $ text "fpcrtl_Length" <> parens e'
+         BTArray RangeInfinite _ _ -> error $ "length() called on variable size array " ++ show e'
+         BTArray (RangeFromTo _ n) _ _ -> initExpr2C (BuiltInFunction "succ" [n])
+         _ -> error $ "length() called on " ++ show lt
+expr2C (BuiltInFunCall params ref) = do
+    r <- ref2C ref
+    t <- gets lastType
+    ps <- mapM expr2C params
+    case t of
+        BTFunction _ _ t' -> do
+            modify (\s -> s{lastType = t'})
+        _ -> error $ "BuiltInFunCall lastType: " ++ show t
+    return $
+        r <> parens (hsep . punctuate (char ',') $ ps)
+expr2C a = error $ "Don't know how to render " ++ show a
+
+ref2CF :: Reference -> State RenderState Doc
+ref2CF (SimpleReference name) = do
+    i <- id2C IOLookup name
+    t <- gets lastType
+    case t of
+         BTFunction _ _ rt -> do
+             modify(\s -> s{lastType = rt})
+             return $ i <> parens empty --xymeng: removed parens
+         _ -> return $ i
+ref2CF r@(RecordField (SimpleReference _) (SimpleReference _)) = do
+    i <- ref2C r
+    t <- gets lastType
+    case t of
+         BTFunction _ _ rt -> do
+             modify(\s -> s{lastType = rt})
+             return $ i <> parens empty
+         _ -> return $ i
+ref2CF r = ref2C r
+
+ref2C :: Reference -> State RenderState Doc
+-- rewrite into proper form
+ref2C (RecordField ref1 (ArrayElement exprs ref2)) = ref2C $ ArrayElement exprs (RecordField ref1 ref2)
+ref2C (RecordField ref1 (Dereference ref2)) = ref2C $ Dereference (RecordField ref1 ref2)
+ref2C (RecordField ref1 (RecordField ref2 ref3)) = ref2C $ RecordField (RecordField ref1 ref2) ref3
+ref2C (RecordField ref1 (FunCall params ref2)) = ref2C $ FunCall params (RecordField ref1 ref2)
+ref2C (ArrayElement (a:b:xs) ref) = ref2C $ ArrayElement (b:xs) (ArrayElement [a] ref)
+-- conversion routines
+ref2C ae@(ArrayElement [expr] ref) = do
+    e <- expr2C expr
+    r <- ref2C ref
+    t <- gets lastType
+    case t of
+         (BTArray _ _ t') -> modify (\st -> st{lastType = t'})
+--         (BTFunctionReturn _ (BTArray _ _ t')) -> modify (\st -> st{lastType = t'})
+--         (BTFunctionReturn _ (BTString)) -> modify (\st -> st{lastType = BTChar})
+         (BTString) -> modify (\st -> st{lastType = BTChar})
+         (BTPointerTo t) -> do
+                t'' <- fromPointer (show t) =<< gets lastType
+                case t'' of
+                     BTChar -> modify (\st -> st{lastType = BTChar})
+                     a -> error $ "Getting element of " ++ show a ++ "\nReference: " ++ show ae
+         a -> error $ "Getting element of " ++ show a ++ "\nReference: " ++ show ae
+    case t of
+         BTString ->  return $ r <> text ".s" <> brackets e
+         _ -> return $ r <> brackets e
+ref2C (SimpleReference name) = id2C IOLookup name
+ref2C rf@(RecordField (Dereference ref1) ref2) = do
+    r1 <- ref2C ref1
+    t <- fromPointer (show ref1) =<< gets lastType
+    r2 <- case t of
+        BTRecord _ rs -> withRecordNamespace "" (rec2Records rs) $ ref2C ref2
+        BTUnit -> error "What??"
+        a -> error $ "dereferencing from " ++ show a ++ "\n" ++ show rf
+    return $
+        r1 <> text "->" <> r2
+ref2C rf@(RecordField ref1 ref2) = do
+    r1 <- ref2C ref1
+    t <- gets lastType
+    case t of
+        BTRecord _ rs -> do
+            r2 <- withRecordNamespace "" (rec2Records rs) $ ref2C ref2
+            return $ r1 <> text "." <> r2
+        BTUnit -> withLastIdNamespace $ ref2C ref2
+        a -> error $ "dereferencing from " ++ show a ++ "\n" ++ show rf
+ref2C d@(Dereference ref) = do
+    r <- ref2C ref
+    t <- fromPointer (show d) =<< gets lastType
+    modify (\st -> st{lastType = t})
+    return $ (parens $ text "*" <> r)
+ref2C f@(FunCall params ref) = do
+    r <- fref2C ref
+    t <- gets lastType
+    case t of
+        BTFunction _ _ t' -> do
+            ps <- liftM (parens . hsep . punctuate (char ',')) $ mapM expr2C params
+            modify (\s -> s{lastType = t'})
+            return $ r <> ps
+        _ -> case (ref, params) of
+                  (SimpleReference i, [p]) -> ref2C $ TypeCast i p
+                  _ -> error $ "ref2C FunCall erroneous type cast detected: " ++ show f ++ "\nType detected: " ++ show t
+    where
+    fref2C (SimpleReference name) = id2C (IOLookupFunction $ length params) name
+    fref2C a = ref2C a
+
+ref2C (Address ref) = do
+    r <- ref2C ref
+    lt <- gets lastType
+    case lt of
+        BTFunction True _ _ -> return $ text "&" <> parens (r <> text "__vars")
+        _ -> return $ text "&" <> parens r
+ref2C (TypeCast t'@(Identifier i _) expr) = do
+    lt <- expr2C expr >> gets lastType
+    case (map toLower i, lt) of
+        ("pchar", BTString) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "_pchar" $ BTPointerTo BTChar))
+        ("shortstring", BTPointerTo _) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "pchar2str" $ BTString))
+        (a, _) -> do
+            e <- expr2C expr
+            t <- id2C IOLookup t'
+            return . parens $ parens t <> e
+ref2C (RefExpression expr) = expr2C expr
+
+
+op2C :: String -> String
+op2C "or" = "|"
+op2C "and" = "&"
+op2C "not" = "~"
+op2C "xor" = "^"
+op2C "div" = "/"
+op2C "mod" = "%"
+op2C "shl" = "<<"
+op2C "shr" = ">>"
+op2C "<>" = "!="
+op2C "=" = "=="
+op2C "/" = "/(float)"
+op2C a = a
+
diff -r b518458f83e6 -r 7fcbbd46704a tools/pas2c/unitCycles.hs
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/pas2c/unitCycles.hs	Mon Nov 05 01:35:54 2012 +0100
@@ -0,0 +1,46 @@
+module Main where
+
+import PascalParser
+import System
+import Control.Monad
+import Data.Either
+import Data.List
+import Data.Graph
+import Data.Maybe
+
+unident :: Identificator -> String
+unident (Identificator s) = s
+
+extractUnits :: PascalUnit -> (String, [String])
+extractUnits (Program (Identificator name) (Implementation (Uses idents) _ _) _) = ("program " ++ name, map unident idents)
+extractUnits (Unit (Identificator name) (Interface (Uses idents1) _) (Implementation (Uses idents2) _ _) _ _) = (name, map unident $ idents1 ++ idents2)
+
+f :: [(String, [String])] -> String
+f = unlines . map showSCC . stronglyConnComp . map (\(a, b) -> (a, a, b))
+    where
+    showSCC (AcyclicSCC v) = v
+    showSCC (CyclicSCC vs) = intercalate ", " vs
+
+myf :: [(String, [String])] -> String
+myf d = unlines . map (findCycle . fst) $ d
+    where
+    findCycle :: String -> String
+    findCycle searched = searched ++ ": " ++ (intercalate ", " $ fc searched [])
+        where
+        fc :: String -> [String] -> [String]
+        fc curSearch visited = let uses = curSearch `lookup` d; res = dropWhile null . map t $ fromJust uses in if isNothing uses || null res then [] else head res
+            where
+            t u =
+                if u == searched then
+                    [u]
+                    else
+                    if u `elem` visited then
+                        []
+                        else
+                        let chain = fc u (u:visited) in if null chain then [] else u:chain
+
+
+main = do
+    fileNames <- getArgs
+    files <- mapM readFile fileNames
+    putStrLn . myf . map extractUnits . rights . map parsePascalUnit $ files
diff -r b518458f83e6 -r 7fcbbd46704a tools/unitCycles.hs
--- a/tools/unitCycles.hs	Sun Nov 04 06:11:39 2012 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,46 +0,0 @@
-module Main where
-
-import PascalParser
-import System
-import Control.Monad
-import Data.Either
-import Data.List
-import Data.Graph
-import Data.Maybe
-
-unident :: Identificator -> String
-unident (Identificator s) = s
-
-extractUnits :: PascalUnit -> (String, [String])
-extractUnits (Program (Identificator name) (Implementation (Uses idents) _ _) _) = ("program " ++ name, map unident idents)
-extractUnits (Unit (Identificator name) (Interface (Uses idents1) _) (Implementation (Uses idents2) _ _) _ _) = (name, map unident $ idents1 ++ idents2)
-
-f :: [(String, [String])] -> String
-f = unlines . map showSCC . stronglyConnComp . map (\(a, b) -> (a, a, b))
-    where
-    showSCC (AcyclicSCC v) = v
-    showSCC (CyclicSCC vs) = intercalate ", " vs
-
-myf :: [(String, [String])] -> String
-myf d = unlines . map (findCycle . fst) $ d
-    where
-    findCycle :: String -> String
-    findCycle searched = searched ++ ": " ++ (intercalate ", " $ fc searched [])
-        where
-        fc :: String -> [String] -> [String]
-        fc curSearch visited = let uses = curSearch `lookup` d; res = dropWhile null . map t $ fromJust uses in if isNothing uses || null res then [] else head res
-            where
-            t u =
-                if u == searched then
-                    [u]
-                    else
-                    if u `elem` visited then
-                        []
-                        else
-                        let chain = fc u (u:visited) in if null chain then [] else u:chain
-
-
-main = do
-    fileNames <- getArgs
-    files <- mapM readFile fileNames
-    putStrLn . myf . map extractUnits . rights . map parsePascalUnit $ files