+
−{-# LANGUAGE ScopedTypeVariables #-}
+
−module Pas2C where
+
−
+
−import Prelude hiding ((<>))
+
−import Text.PrettyPrint.HughesPJ
+
−import Data.Maybe
+
−import Data.Char
+
−import Text.Parsec.Prim hiding (State)
+
−import Control.Monad.State
+
−import System.IO
+
−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
+
−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,
+
−        isFunctionType :: Bool, -- set to true if the current function parameter is functiontype
+
−        lastIdTypeDecl :: Doc,
+
−        stringConsts :: [(String, String)],
+
−        uniqCounter :: Int,
+
−        toMangle :: Set.Set String,
+
−        enums :: [(String, [String])], -- store all declared enums
+
−        currentUnit :: String,
+
−        currentFunctionResult :: String,
+
−        namespaces :: Map.Map String Records
+
−    }
+
−
+
−rec2Records :: [(String, BaseType)] -> [Record]
+
−rec2Records = map (\(a, b) -> Record a b empty)
+
−
+
−emptyState :: Map.Map String Records -> RenderState
+
−emptyState = RenderState Map.empty "" BTUnknown False 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 -> [String] -> IO ()
+
−pas2C fn inputPath outputPath alternateInputPath symbols = 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") symbols
+
−            case fc' of
+
−                (Left _) -> 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 ++ fileName ++ "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 :: State RenderState Doc -> State RenderState Doc
+
−withLastIdNamespace f = do
+
−    li <- gets lastIdentifier
+
−    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
+
−        un _ _ = error "withRecordNamespace un: pattern not matched"
+
−
+
−toCFiles :: String -> Map.Map String Records -> (String, PascalUnit) -> IO ()
+
−toCFiles _ _ (_, System _) = return ()
+
−toCFiles _ _ (_, Redo _) = return ()
+
−toCFiles outputPath ns pu@(fileName, _) = do
+
−    hPutStrLn stdout $ "Rendering '" ++ fileName ++ "'..."
+
−    --let (fn, p) = pu in writeFile (outputPath ++ fn ++ ".dump") $ show p
+
−    toCFiles' pu
+
−    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', _) = runState (id2C IOInsert (setBaseType BTUnit unitId) >> interface2C interface False) initialState{currentUnit = map toLower i ++ "_"}
+
−            enumDecl = (renderEnum2Strs (enums s) False)
+
−            enumImpl = (renderEnum2Strs (enums s) True)
+
−        writeFile (outputPath ++ fn ++ ".h") $ "#pragma once\n\n#include \"pas2c.h\"\n\n" ++ (render (a $+$ text "")) ++ "\n" ++ enumDecl
+
−        writeFile (outputPath ++ fn ++ ".c") $ "#include \"fpcrtl.h\"\n\n#include \"" ++ fn ++ ".h\"\n" ++ render (a' $+$ text "") ++ (render2C s . implementation2C) implementation ++ "\n" ++ enumImpl
+
−    toCFiles' _ = undefined -- just pleasing compiler to not warn us
+
−    initialState = emptyState ns
+
−
+
−    render2C :: RenderState -> State RenderState Doc -> String
+
−    render2C st p =
+
−        let (a, _) = runState p st in
+
−        render a
+
−
+
−renderEnum2Strs :: [(String, [String])] -> Bool -> String
+
−renderEnum2Strs enums' implement =
+
−    render $ foldl ($+$) empty $ map (\en -> let d = decl (fst en) in if implement then d $+$ enum2strBlock (snd en) else d <> semi) enums'
+
−    where
+
−    decl id' = text "string255 __attribute__((overloadable)) fpcrtl_GetEnumName" <> parens (text "int dummy, const" <+> text id' <+> text "enumvar")
+
−    enum2strBlock en =
+
−            text "{"
+
−            $+$
+
−            (nest 4 $
+
−                text "switch(enumvar){"
+
−                $+$
+
−                (foldl ($+$) empty $ map (\e -> text "case" <+> text e <> colon $+$ (nest 4 $ text "return fpcrtl_make_string" <> (parens $ doubleQuotes $ text e) <> semi $+$ text "break;")) en)
+
−                $+$
+
−                text "default: assert(0);"
+
−                $+$
+
−                (nest 4 $ text "return fpcrtl_make_string(\"nonsense\");")
+
−                $+$
+
−                text "}"
+
−            )
+
−            $+$
+
−            text "}"
+
−
+
−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 _ _) =
+
−    liftM2 ($+$) (interface2C interface True) (implementation2C implementation)
+
−
+
−pascal2C (Program _ implementation mainFunction) = do
+
−    impl <- implementation2C implementation
+
−    main <- liftM head $ tvar2C True False True True
+
−        (FunctionDeclaration (Identifier "main" (BTInt True)) False False False (SimpleType $ Identifier "int" (BTInt True)) 
+
−            [VarDeclaration False False ([Identifier "argc" (BTInt True)], SimpleType (Identifier "Integer" (BTInt True))) Nothing
+
−            , VarDeclaration False False ([Identifier "argv" BTUnknown], SimpleType (Identifier "PPChar" BTUnknown)) Nothing] 
+
−        (Just (TypesAndVars [], Phrases [mainResultInit, mainFunction])))
+
−
+
−    return $ impl $+$ main
+
−
+
−pascal2C _ = error "pascal2C: pattern not matched"
+
−
+
−-- 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
+
−    void $ uses2C uses
+
−    tv <- typesAndVars2C True False False tvars
+
−    void $ 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.Map String Int
+
−        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 -> State RenderState ()
+
−    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 :: Record -> RenderState -> RenderState
+
−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
+
−    tom <- gets (Set.member n . toMangle)
+
−    cu <- gets currentUnit
+
−    let (i', t') = case (t, tom) of
+
−            (BTFunction _ e p _, True) -> ((if e then id else (++) cu) $ i ++ ('_' : show (length p)), t)
+
−            (BTFunction _ e _ _, _) -> ((if e then id else (++) 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 _) = 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 _) _) = (length p) == params
+
−        checkParam _ = False
+
−id2C IODeferred (Identifier i _) = 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 _) = 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)
+
−
+
−typeVarDecl2BaseType :: [TypeVarDeclaration] -> State RenderState [(Bool, BaseType)]
+
−typeVarDecl2BaseType d = do
+
−    st <- get
+
−    result <- sequence $ concat $ map resolveType' d
+
−    put st -- restore state (not sure if necessary)
+
−    return result
+
−    where
+
−        resolveType' :: TypeVarDeclaration -> [State RenderState (Bool, BaseType)]
+
−        resolveType' (VarDeclaration isVar _ (ids, t) _) = replicate (length ids) (resolveTypeHelper' (resolveType t) isVar)
+
−        resolveType' _ = error "typeVarDecl2BaseType: not a VarDeclaration"
+
−        resolveTypeHelper' :: State RenderState BaseType -> Bool -> State RenderState (Bool, BaseType)
+
−        resolveTypeHelper' st b = do
+
−            bt <- st
+
−            return (b, bt)
+
−
+
−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 "uinteger" = BTInt False
+
−    f "integer" = BTInt True
+
−    f "pointer" = BTPointerTo BTVoid
+
−    f "boolean" = BTBool
+
−    f "float" = BTFloat
+
−    f "char" = BTChar
+
−    f "string" = BTString
+
−    f "ansistring" = BTAString
+
−    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
+
−        f _ = error "resolveType f: pattern not matched"
+
−resolveType (ArrayDecl (Just i) t) = do
+
−    t' <- resolveType t
+
−    return $ BTArray i (BTInt True) t'
+
−resolveType (ArrayDecl Nothing t) = liftM (BTArray RangeInfinite (BTInt True)) $ resolveType t
+
−resolveType (FunctionType t a) = do
+
−    bts <- typeVarDecl2BaseType a
+
−    liftM (BTFunction False False bts) $ resolveType t
+
−resolveType (DeriveType (InitHexNumber _)) = return (BTInt True)
+
−resolveType (DeriveType (InitNumber _)) = return (BTInt True)
+
−resolveType (DeriveType (InitFloat _)) = return BTFloat
+
−resolveType (DeriveType (InitString _)) = return BTString
+
−resolveType (DeriveType (InitBinOp {})) = return (BTInt True)
+
−resolveType (DeriveType (InitPrefixOp _ e)) = initExpr2C e >> gets lastType
+
−resolveType (DeriveType (BuiltInFunction{})) = return (BTInt True)
+
−resolveType (DeriveType (InitReference (Identifier{}))) = return BTBool -- TODO: derive from actual type
+
−resolveType (DeriveType _) = return BTUnknown
+
−resolveType String = return BTString
+
−resolveType AString = return BTAString
+
−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 :: [TypeVarDeclaration] -> State RenderState Doc
+
−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 _ overload external returnType params Nothing) = do
+
−    t <- type2C returnType
+
−    t'<- gets lastType
+
−    bts <- typeVarDecl2BaseType params
+
−    p <- withState' id $ functionParams2C params
+
−    n <- liftM render . id2C IOInsert $ setBaseType (BTFunction False external bts t') name
+
−    let decor = if overload then text "__attribute__((overloadable))" else empty
+
−    return [t empty <+> decor <+> text n <> parens p]
+
−
+
−fun2C True rv (FunctionDeclaration name@(Identifier i _) inline overload external returnType params (Just (tvars, phrase))) = do
+
−    let isVoid = case returnType of
+
−            VoidType -> True
+
−            _ -> False
+
−
+
−    let res = docToLower $ text rv <> if isVoid then empty else text "_result"
+
−    t <- type2C returnType
+
−    t' <- gets lastType
+
−
+
−    bts <- typeVarDecl2BaseType params
+
−    --cu <- gets currentUnit
+
−    notDeclared <- liftM isNothing . gets $ Map.lookup (map toLower i) . currentScope
+
−
+
−    n <- liftM render . id2C IOInsert $ setBaseType (BTFunction hasVars external bts t') name
+
−    let resultId = if isVoid
+
−                    then n -- void type doesn't have result, solving recursive procedure calls
+
−                    else (render res)
+
−
+
−    (p, ph) <- withState' (\st -> st{currentScope = Map.insertWith un (map toLower rv) [Record resultId (if isVoid then (BTFunction hasVars False bts t') else 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 isTrivialReturn = case phrase of
+
−         (Phrases (BuiltInFunctionCall _ (SimpleReference (Identifier "exit" BTUnknown)) : _)) -> True
+
−         _ -> False
+
−    let phrasesBlock = if isVoid || isTrivialReturn 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 inlineDecor = if inline then case notDeclared of
+
−                                    True -> text "static inline"
+
−                                    False -> text "inline"
+
−                          else empty
+
−        overloadDecor = if overload then text "__attribute__((overloadable))" else empty
+
−    return [
+
−        --define
+
−        -- $+$
+
−        --(if notDeclared && hasVars then funWithVarsToDefine n params else empty) $+$
+
−        inlineDecor <+> t empty <+> overloadDecor <+> text 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
+
−    un _ _ = error "fun2C u: pattern not matched"
+
−    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 _ (TypeDeclaration i' t) = do
+
−    i <- id2CTyped t i'
+
−    tp <- type2C t
+
−    let res = if includeType then [text "typedef" <+> tp i] else []
+
−    case t of
+
−        (Sequence ids) -> do
+
−            modify(\s -> s{enums = (render i, map (\(Identifier id' _) -> id') ids) : enums s})
+
−            return res
+
−        _ -> return res
+
−
+
−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(\id' -> varDeclDecision isConst includeType (t' id') 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 _ _ = 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 + a'
+
−        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 False False ret params body)
+
−
+
−
+
−op2CTyped :: String -> [TypeDecl] -> State RenderState Identifier
+
−op2CTyped op t = do
+
−    t' <- liftM (render . hcat . punctuate (char '_') . map (\txt -> txt 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) = do
+
−                                modify(\st -> st{lastType = (BTInt True)})
+
−                                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' (InitPChar s) = return $ doubleQuotes (text $ escapeStr s)
+
−initExpr2C' (InitChar a) = return $ text "0x" <> 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 [InitRecord fields]) = do
+
−--    e <- initExpr2C $ InitRecord fields
+
−--    return $ braces $ e
+
−initExpr2C' r@(InitRange (Range i@(Identifier i' _))) = do
+
−    void $ 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 _) = 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' hi@(BuiltInFunction "high" [e@(InitReference e')]) = do
+
−    void $ initExpr2C e
+
−    t <- gets lastType
+
−    case t of
+
−         (BTArray i _ _) -> initExpr2C' $ BuiltInFunction "pred" [InitRange i]
+
−         BTInt _ -> case e' of
+
−                  (Identifier "LongInt" _) -> return $ int (2147483647)
+
−                  (Identifier "LongWord" _) -> return $ text "4294967295"
+
−                  _ -> error $ "BuiltInFunction 'high' in initExpr: " ++ show e'
+
−         a -> error $ "BuiltInFunction 'high' in initExpr: " ++ show a ++ ": " ++ show hi
+
−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' (InitTypeCast t' i) = do
+
−    e <- initExpr2C i
+
−    t <- id2C IOLookup t'
+
−    return . parens $ parens t <> e
+
−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 _ BTAString = text "astring"
+
−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 = return (text "string255" <+>)--return (text ("string" ++ show l) <+>)
+
−    type2C' AString = return (text "astring" <+>)
+
−    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 (\tx a -> tx (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 stvs = do
+
−                txts <- withState' f $ mapM (tvar2C False False True False) stvs
+
−                return $ text "struct" $+$ braces (nest 4 (vcat . map (<> semi) . concat $ txts)) <> 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 r1) (ArrayDecl (Just r2) t)) = do
+
−        t' <- type2C t
+
−        lt <- gets lastType
+
−        r1' <- initExpr2C (InitRange r1)
+
−        r2' <- initExpr2C (InitRange r2)
+
−        return $ \i -> t' i <> brackets r1' <> brackets r2'
+
−    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
+
−    type2C' a = error $ "type2C: unknown type " ++ 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 True
+
−phrase2C (ProcCall _ _) = 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 asgn@(Assignment ref expr) = do
+
−    r <- ref2C ref
+
−    t <- gets lastType
+
−    case (t, expr) of
+
−        (_, Reference r') | ref == r' -> do
+
−            e <- ref2C r'
+
−            return $ text "UNUSED" <+> parens e <> semi
+
−        (BTFunction {}, (Reference r')) -> do
+
−            e <- ref2C r'
+
−            return $ r <+> text "=" <+> e <> semi
+
−        (BTString, _) -> do
+
−            void $ 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
+
−                BTAString -> do
+
−                    e <- expr2C $ Reference $ FunCall [Reference $ RefExpression expr] (SimpleReference (Identifier "astr2str" BTUnknown))
+
−                    return $ r <+> text "=" <+> e <> semi
+
−                BTString -> do
+
−                    e <- expr2C expr
+
−                    return $ r <+> text "=" <+> e <> semi
+
−                _ -> error $ "Assignment to string from " ++ show lt ++ "\n" ++ show asgn
+
−        (BTAString, _) -> do
+
−            void $ 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 "pchar2astr" BTUnknown))
+
−                    return $ r <+> text "=" <+> e <> semi
+
−                BTString -> do
+
−                    e <- expr2C $ Reference $ FunCall [Reference $ RefExpression expr] (SimpleReference (Identifier "str2astr" BTUnknown))
+
−                    return $ r <+> text "=" <+> e <> semi
+
−                BTAString -> do
+
−                    e <- expr2C expr
+
−                    return $ r <+> text "=" <+> e <> semi
+
−                _ -> error $ "Assignment to ansistring from " ++ show lt ++ "\n" ++ show asgn
+
−        (BTArray _ _ _, _) -> do
+
−            case expr of
+
−                Reference er -> do
+
−                    void $ 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 iEnd = i <> text "__end__"
+
−    ph <- phrase2C $ wrapPhrase p
+
−    return . braces $
+
−        i <+> text "=" <+> e1 <> semi
+
−        $$
+
−        iType <+> iEnd <+> text "=" <+> e2 <> semi
+
−        $$
+
−        text "if" <+> (parens $ i <+> text (if up then "<=" else ">=") <+> iEnd) <+> text "do" <+> ph <+>
+
−        text "while" <> parens (i <> text (if up then "++" else "--") <+> text "!=" <+> iEnd) <> semi
+
−    where
+
−        appendPhrase p (Phrases ps) = Phrases $ ps ++ [p]
+
−        appendPhrase _ _ = error "illegal appendPhrase call"
+
−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 bop@(BinOp op expr1 expr2) = do
+
−    e1 <- expr2C expr1
+
−    t1 <- gets lastType
+
−    e2 <- expr2C expr2
+
−    t2 <- gets lastType
+
−    case (op2C op, t1, t2) of
+
−        ("+", BTAString, BTAString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strconcatA" (fff t1 t2 BTString))
+
−        ("+", BTAString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strappendA" (fff t1 t2  BTAString))
+
−        ("+", BTChar, BTAString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strprependA" (fff t1 t2  BTAString))
+
−        ("!=", BTAString, BTAString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strncompareA" (fff t1 t2  BTBool))
+
−        (_, BTAString, _) -> error $ "unhandled bin op with ansistring on the left side: " ++ show bop
+
−        (_, _, BTAString) -> error $ "unhandled bin op with ansistring on the right side: " ++ show bop
+
−        ("+", BTString, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strconcat" (fff t1 t2  BTString))
+
−        ("+", BTString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strappend" (fff t1 t2  BTString))
+
−        ("+", BTChar, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strprepend" (fff t1 t2  BTString))
+
−        ("+", BTChar, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_chrconcat" (fff t1 t2  BTString))
+
−        ("==", BTString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcomparec" (fff t1 t2  BTBool))
+
−
+
−        -- for function/procedure comparision
+
−        ("==", BTVoid, _) -> procCompare expr1 expr2 "=="
+
−        ("==", BTFunction _ _ _ _, _) -> procCompare expr1 expr2 "=="
+
−
+
−        ("!=", BTVoid, _) -> procCompare expr1 expr2 "!="
+
−        ("!=", BTFunction _ _ _ _, _) -> procCompare expr1 expr2 "!="
+
−
+
−        ("==", BTString, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcompare" (fff t1 t2  BTBool))
+
−        ("!=", BTString, _) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strncompare" (fff t1 t2  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 False, BTInt False) -> parens $ text "(int64_t)" <+> parens e1
+
−                                _ -> parens e1
+
−                        e2' <- return $ case (o, t1, t2) of
+
−                                ("-", BTInt False, BTInt False) -> parens $ text "(int64_t)" <+> parens e2
+
−                                _ -> parens e2
+
−                        return $ e1' <+> o' <+> e2'
+
−    where
+
−        fff t1 t2 = BTFunction False False [(False, t1), (False, t2)]
+
−        boolOps = ["==", "!=", "<", ">", "<=", ">="]
+
−        procCompare expr1 expr2 op =
+
−            case (expr1, expr2) of
+
−                (Reference r1, Reference r2) -> do
+
−                    id1 <- ref2C r1
+
−                    id2 <- ref2C r2
+
−                    return $ (parens id1) <+> text op <+> (parens id2)
+
−                (_, _) -> error $ "Two non reference type vars are compared but they have type of BTVoid or BTFunction\n" ++ show expr1 ++ "\n" ++ show expr2
+
−
+
−expr2C (NumberLiteral s) = do
+
−    modify(\s -> s{lastType = BTInt True})
+
−    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) = do
+
−   isfunc <- gets isFunctionType
+
−   modify(\s -> s{isFunctionType = False}) -- reset
+
−   if isfunc then ref2CF ref False else ref2CF ref True
+
−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 $ text "0x" <> 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 _-> 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" _))) = do
+
−    e'<- expr2C e
+
−    return $ text "(int)" <> parens e' <> text " - 1"
+
−expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "length" _))) = do
+
−    e' <- expr2C e
+
−    lt <- gets lastType
+
−    modify (\s -> s{lastType = BTInt True})
+
−    case lt of
+
−         BTString -> return $ text "fpcrtl_Length" <> parens e'
+
−         BTAString -> return $ text "fpcrtl_LengthA" <> 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 [e, e1, e2] (SimpleReference (Identifier "copy" _))) = do
+
−    e1' <- expr2C e1
+
−    e2' <- expr2C e2
+
−    e' <- expr2C e
+
−    lt <- gets lastType
+
−    let f name = return $ text name <> parens (hsep $ punctuate (char ',') [e', e1', e2'])
+
−    case lt of
+
−         BTString -> f "fpcrtl_copy"
+
−         BTAString -> f "fpcrtl_copyA"
+
−         _ -> error $ "copy() 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 `" ++ show ref ++ "`, lastType: " ++ show t
+
−    return $
+
−        r <> parens (hsep . punctuate (char ',') $ ps)
+
−expr2C a = error $ "Don't know how to render " ++ show a
+
−
+
−ref2CF :: Reference -> Bool -> State RenderState Doc
+
−ref2CF (SimpleReference name) addParens = do
+
−    i <- id2C IOLookup name
+
−    t <- gets lastType
+
−    case t of
+
−         BTFunction _ _ _ rt -> do
+
−             modify(\s -> s{lastType = rt})
+
−             return $ if addParens then i <> parens empty else i --xymeng: removed parens
+
−         _ -> return $ i
+
−ref2CF r@(RecordField (SimpleReference _) (SimpleReference _)) addParens = do
+
−    i <- ref2C r
+
−    t <- gets lastType
+
−    case t of
+
−         BTFunction _ _ _ rt -> do
+
−             modify(\s -> s{lastType = rt})
+
−             return $ if addParens then i <> parens empty else i
+
−         _ -> 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})
+
−         BTAString -> 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
+
−         BTAString ->  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 _ _ bts t' -> do
+
−            ps <- liftM (parens . hsep . punctuate (char ',')) $
+
−                    if (length params) == (length bts) -- hot fix for pas2cSystem and pas2cRedo functions since they don't have params
+
−                    then
+
−                        mapM expr2CHelper (zip params bts)
+
−                    else 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 ++ "\n" ++ show ref ++ "\n" ++ show params ++ "\n" ++ show t
+
−    where
+
−    fref2C (SimpleReference name) = id2C (IOLookupFunction $ length params) name
+
−    fref2C a = ref2C a
+
−    expr2CHelper :: (Expression, (Bool, BaseType)) -> State RenderState Doc
+
−    expr2CHelper (e, (_, BTFunction _ _ _ _)) = do
+
−        modify (\s -> s{isFunctionType = True})
+
−        expr2C e
+
−    expr2CHelper (e, (isVar, _)) = if isVar then liftM (((<>) $ text "&") . parens) $ (expr2C e) else expr2C e
+
−
+
−ref2C (Address ref) = do
+
−    r <- ref2C ref
+
−    lt <- gets lastType
+
−    case lt of
+
−        BTFunction True _ _ _ -> return $ text "&" <> parens r
+
−        _ -> 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))
+
−        ("pchar", BTAString) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "_pcharA" $ BTPointerTo BTChar))
+
−        ("shortstring", BTAString) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "astr2str" $ BTString))
+
−        ("shortstring", BTPointerTo _) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "pchar2str" $ BTString))
+
−        ("ansistring", BTPointerTo _) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "pchar2astr" $ BTAString))
+
−        ("ansistring", BTString) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "str2astr" $ BTAString))
+
−        (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
+
−