1{-# LANGUAGE ScopedTypeVariables #-}
2module Pas2C where
3
4import Prelude hiding ((<>))
5import Text.PrettyPrint.HughesPJ
6import Data.Maybe
7import Data.Char
8import Text.Parsec.Prim hiding (State)
9import Control.Monad.State
10import System.IO
11import PascalPreprocessor
12import Control.Exception
13import System.IO.Error
14import qualified Data.Map as Map
15import qualified Data.Set as Set
16import Data.List (find)
17import Numeric
18
19import PascalParser
20import PascalUnitSyntaxTree
21
22
23data InsertOption =
24    IOInsert
25    | IOInsertWithType Doc
26    | IOLookup
27    | IOLookupLast
28    | IOLookupFunction Int
29    | IODeferred
30
31data Record = Record
32    {
33        lcaseId :: String,
34        baseType :: BaseType,
35        typeDecl :: Doc
36    }
37    deriving Show
38type Records = Map.Map String [Record]
39data RenderState = RenderState
40    {
41        currentScope :: Records,
42        lastIdentifier :: String,
43        lastType :: BaseType,
44        isFunctionType :: Bool, -- set to true if the current function parameter is functiontype
45        lastIdTypeDecl :: Doc,
46        stringConsts :: [(String, String)],
47        uniqCounter :: Int,
48        toMangle :: Set.Set String,
49        enums :: [(String, [String])], -- store all declared enums
50        currentUnit :: String,
51        currentFunctionResult :: String,
52        namespaces :: Map.Map String Records
53    }
54
55rec2Records :: [(String, BaseType)] -> [Record]
56rec2Records = map (\(a, b) -> Record a b empty)
57
58emptyState :: Map.Map String Records -> RenderState
59emptyState = RenderState Map.empty "" BTUnknown False empty [] 0 Set.empty [] "" ""
60
61getUniq :: State RenderState Int
62getUniq = do
63    i <- gets uniqCounter
64    modify(\s -> s{uniqCounter = uniqCounter s + 1})
65    return i
66
67addStringConst :: String -> State RenderState Doc
68addStringConst str = do
69    strs <- gets stringConsts
70    let a = find ((==) str . snd) strs
71    if isJust a then
72        do
73        modify (\s -> s{lastType = BTString})
74        return . text . fst . fromJust $ a
75    else
76        do
77        i <- getUniq
78        let sn = "__str" ++ show i
79        modify (\s -> s{lastType = BTString, stringConsts = (sn, str) : strs})
80        return $ text sn
81
82escapeStr :: String -> String
83escapeStr = foldr escapeChar []
84
85escapeChar :: Char -> ShowS
86escapeChar '"' s = "\\\"" ++ s
87escapeChar '\\' s = "\\\\" ++ s
88escapeChar a s = a : s
89
90strInit :: String -> Doc
91strInit a = text "STRINIT" <> parens (doubleQuotes (text $ escapeStr a))
92
93renderStringConsts :: State RenderState Doc
94renderStringConsts = liftM (vcat . map (\(a, b) -> text "static const string255" <+> (text a) <+> text "=" <+> strInit b <> semi))
95    $ gets stringConsts
96
97docToLower :: Doc -> Doc
98docToLower = text . map toLower . render
99
100pas2C :: String -> String -> String -> String -> [String] -> IO ()
101pas2C fn inputPath outputPath alternateInputPath symbols = do
102    s <- flip execStateT initState $ f fn
103    renderCFiles s outputPath
104    where
105    printLn = liftIO . hPutStrLn stdout
106    print' = liftIO . hPutStr stdout
107    initState = Map.empty
108    f :: String -> StateT (Map.Map String PascalUnit) IO ()
109    f fileName = do
110        processed <- gets $ Map.member fileName
111        unless processed $ do
112            print' ("Preprocessing '" ++ fileName ++ ".pas'... ")
113            fc' <- liftIO
114                $ tryJust (guard . isDoesNotExistError)
115                $ preprocess inputPath alternateInputPath (fileName ++ ".pas") symbols
116            case fc' of
117                (Left _) -> do
118                    modify (Map.insert fileName (System []))
119                    printLn "doesn't exist"
120                (Right fc) -> do
121                    print' "ok, parsing... "
122                    let ptree = parse pascalUnit fileName fc
123                    case ptree of
124                         (Left a) -> do
125                            liftIO $ writeFile (outputPath ++ fileName ++ "preprocess.out") fc
126                            printLn $ show a ++ "\nsee preprocess.out for preprocessed source"
127                            fail "stop"
128                         (Right a) -> do
129                            printLn "ok"
130                            modify (Map.insert fileName a)
131                            mapM_ f (usesFiles a)
132
133
134renderCFiles :: Map.Map String PascalUnit -> String -> IO ()
135renderCFiles units outputPath = do
136    let u = Map.toList units
137    let nss = Map.map (toNamespace nss) units
138    --hPutStrLn stderr $ "Units: " ++ (show . Map.keys . Map.filter (not . Map.null) $ nss)
139    --writeFile "pas2c.log" $ unlines . map (\t -> show (fst t) ++ "\n" ++ (unlines . map ((:) '\t' . show) . snd $ t)) . Map.toList $ nss
140    mapM_ (toCFiles outputPath nss) u
141    where
142    toNamespace :: Map.Map String Records -> PascalUnit -> Records
143    toNamespace nss (System tvs) =
144        currentScope $ execState f (emptyState nss)
145        where
146        f = do
147            checkDuplicateFunDecls tvs
148            mapM_ (tvar2C True False True False) tvs
149    toNamespace nss (Redo tvs) = -- functions that are re-implemented, add prefix to all of them
150        currentScope $ execState f (emptyState nss){currentUnit = "fpcrtl_"}
151        where
152        f = do
153            checkDuplicateFunDecls tvs
154            mapM_ (tvar2C True False True False) tvs
155    toNamespace _ (Program {}) = Map.empty
156    toNamespace nss (Unit (Identifier i _) interface _ _ _) =
157        currentScope $ execState (interface2C interface True) (emptyState nss){currentUnit = map toLower i ++ "_"}
158
159withState' :: (RenderState -> RenderState) -> State RenderState a -> State RenderState a
160withState' f sf = do
161    st <- liftM f get
162    let (a, s) = runState sf st
163    modify(\st' -> st'{
164        lastType = lastType s
165        , uniqCounter = uniqCounter s
166        , stringConsts = stringConsts s
167        })
168    return a
169
170withLastIdNamespace :: State RenderState Doc -> State RenderState Doc
171withLastIdNamespace f = do
172    li <- gets lastIdentifier
173    withState' (\st -> st{currentScope = fromMaybe Map.empty $ Map.lookup li (namespaces st)}) f
174
175withRecordNamespace :: String -> [Record] -> State RenderState Doc -> State RenderState Doc
176withRecordNamespace _ [] = error "withRecordNamespace: empty record"
177withRecordNamespace prefix recs = withState' f
178    where
179        f st = st{currentScope = Map.unionWith un records (currentScope st), currentUnit = ""}
180        records = Map.fromList $ map (\(Record a b d) -> (map toLower a, [Record (prefix ++ a) b d])) recs
181        un [a] b = a : b
182        un _ _ = error "withRecordNamespace un: pattern not matched"
183
184toCFiles :: String -> Map.Map String Records -> (String, PascalUnit) -> IO ()
185toCFiles _ _ (_, System _) = return ()
186toCFiles _ _ (_, Redo _) = return ()
187toCFiles outputPath ns pu@(fileName, _) = do
188    hPutStrLn stdout $ "Rendering '" ++ fileName ++ "'..."
189    --let (fn, p) = pu in writeFile (outputPath ++ fn ++ ".dump") $ show p
190    toCFiles' pu
191    where
192    toCFiles' (fn, p@(Program {})) = writeFile (outputPath ++ fn ++ ".c") $ "#include \"fpcrtl.h\"\n" ++ (render2C initialState . pascal2C) p
193    toCFiles' (fn, (Unit unitId@(Identifier i _) interface implementation _ _)) = do
194        let (a, s) = runState (id2C IOInsert (setBaseType BTUnit unitId) >> interface2C interface True) initialState{currentUnit = map toLower i ++ "_"}
195            (a', _) = runState (id2C IOInsert (setBaseType BTUnit unitId) >> interface2C interface False) initialState{currentUnit = map toLower i ++ "_"}
196            enumDecl = (renderEnum2Strs (enums s) False)
197            enumImpl = (renderEnum2Strs (enums s) True)
198        writeFile (outputPath ++ fn ++ ".h") $ "#pragma once\n\n#include \"pas2c.h\"\n\n" ++ (render (a $+$ text "")) ++ "\n" ++ enumDecl
199        writeFile (outputPath ++ fn ++ ".c") $ "#include \"fpcrtl.h\"\n\n#include \"" ++ fn ++ ".h\"\n" ++ render (a' $+$ text "") ++ (render2C s . implementation2C) implementation ++ "\n" ++ enumImpl
200    toCFiles' _ = undefined -- just pleasing compiler to not warn us
201    initialState = emptyState ns
202
203    render2C :: RenderState -> State RenderState Doc -> String
204    render2C st p =
205        let (a, _) = runState p st in
206        render a
207
208renderEnum2Strs :: [(String, [String])] -> Bool -> String
209renderEnum2Strs enums' implement =
210    render $ foldl ($+$) empty $ map (\en -> let d = decl (fst en) in if implement then d $+$ enum2strBlock (snd en) else d <> semi) enums'
211    where
212    decl id' = text "string255 __attribute__((overloadable)) fpcrtl_GetEnumName" <> parens (text "int dummy, const" <+> text id' <+> text "enumvar")
213    enum2strBlock en =
214            text "{"
215            $+$
216            (nest 4 $
217                text "switch(enumvar){"
218                $+$
219                (foldl ($+$) empty $ map (\e -> text "case" <+> text e <> colon $+$ (nest 4 $ text "return fpcrtl_make_string" <> (parens $ doubleQuotes $ text e) <> semi $+$ text "break;")) en)
220                $+$
221                text "default: assert(0);"
222                $+$
223                (nest 4 $ text "return fpcrtl_make_string(\"nonsense\");")
224                $+$
225                text "}"
226            )
227            $+$
228            text "}"
229
230usesFiles :: PascalUnit -> [String]
231usesFiles (Program _ (Implementation uses _) _) = ["pas2cSystem", "pas2cRedo"] ++ uses2List uses
232usesFiles (Unit _ (Interface uses1 _) (Implementation uses2 _) _ _) = ["pas2cSystem", "pas2cRedo"] ++ uses2List uses1 ++ uses2List uses2
233usesFiles (System {}) = []
234usesFiles (Redo {}) = []
235
236pascal2C :: PascalUnit -> State RenderState Doc
237pascal2C (Unit _ interface implementation _ _) =
238    liftM2 ($+$) (interface2C interface True) (implementation2C implementation)
239
240pascal2C (Program _ implementation mainFunction) = do
241    impl <- implementation2C implementation
242    main <- liftM head $ tvar2C True False True True
243        (FunctionDeclaration (Identifier "main" (BTInt True)) False False False (SimpleType $ Identifier "int" (BTInt True))
244            [VarDeclaration False False ([Identifier "argc" (BTInt True)], SimpleType (Identifier "Integer" (BTInt True))) Nothing
245            , VarDeclaration False False ([Identifier "argv" BTUnknown], SimpleType (Identifier "PPChar" BTUnknown)) Nothing]
246        (Just (TypesAndVars [], Phrases [mainResultInit, mainFunction])))
247
248    return $ impl $+$ main
249
250pascal2C _ = error "pascal2C: pattern not matched"
251
252-- the second bool indicates whether do normal interface translation or generate variable declarations
253-- that will be inserted into implementation files
254interface2C :: Interface -> Bool -> State RenderState Doc
255interface2C (Interface uses tvars) True = do
256    u <- uses2C uses
257    tv <- typesAndVars2C True True True tvars
258    r <- renderStringConsts
259    return (u $+$ r $+$ tv)
260interface2C (Interface uses tvars) False = do
261    void $ uses2C uses
262    tv <- typesAndVars2C True False False tvars
263    void $ renderStringConsts
264    return tv
265
266implementation2C :: Implementation -> State RenderState Doc
267implementation2C (Implementation uses tvars) = do
268    u <- uses2C uses
269    tv <- typesAndVars2C True False True tvars
270    r <- renderStringConsts
271    return (u $+$ r $+$ tv)
272
273checkDuplicateFunDecls :: [TypeVarDeclaration] -> State RenderState ()
274checkDuplicateFunDecls tvs =
275    modify $ \s -> s{toMangle = Map.keysSet . Map.filter (> 1) . foldr ins initMap $ tvs}
276    where
277        initMap :: Map.Map String Int
278        initMap = Map.empty
279        --initMap = Map.fromList [("reset", 2)]
280        ins (FunctionDeclaration (Identifier i _) _ _ _ _ _ _) m = Map.insertWith (+) (map toLower i) 1 m
281        ins _ m = m
282
283-- the second bool indicates whether declare variable as extern or not
284-- the third bool indicates whether include types or not
285
286typesAndVars2C :: Bool -> Bool -> Bool -> TypesAndVars -> State RenderState Doc
287typesAndVars2C b externVar includeType(TypesAndVars ts) = do
288    checkDuplicateFunDecls ts
289    liftM (vcat . map (<> semi) . concat) $ mapM (tvar2C b externVar includeType False) ts
290
291setBaseType :: BaseType -> Identifier -> Identifier
292setBaseType bt (Identifier i _) = Identifier i bt
293
294uses2C :: Uses -> State RenderState Doc
295uses2C uses@(Uses unitIds) = do
296
297    mapM_ injectNamespace (Identifier "pas2cSystem" undefined : unitIds)
298    mapM_ injectNamespace (Identifier "pas2cRedo" undefined : unitIds)
299    mapM_ (id2C IOInsert . setBaseType BTUnit) unitIds
300    return $ vcat . map (\i -> text $ "#include \"" ++ i ++ ".h\"") $ uses2List uses
301    where
302    injectNamespace :: Identifier -> State RenderState ()
303    injectNamespace (Identifier i _) = do
304        getNS <- gets (flip Map.lookup . namespaces)
305        modify (\s -> s{currentScope = Map.unionWith (++) (fromMaybe Map.empty (getNS i)) $ currentScope s})
306
307uses2List :: Uses -> [String]
308uses2List (Uses ids) = map (\(Identifier i _) -> i) ids
309
310
311setLastIdValues :: Record -> RenderState -> RenderState
312setLastIdValues vv = (\s -> s{lastType = baseType vv, lastIdentifier = lcaseId vv, lastIdTypeDecl = typeDecl vv})
313
314id2C :: InsertOption -> Identifier -> State RenderState Doc
315id2C IOInsert i = id2C (IOInsertWithType empty) i
316id2C (IOInsertWithType d) (Identifier i t) = do
317    tom <- gets (Set.member n . toMangle)
318    cu <- gets currentUnit
319    let (i', t') = case (t, tom) of
320            (BTFunction _ e p _, True) -> ((if e then id else (++) cu) $ i ++ ('_' : show (length p)), t)
321            (BTFunction _ e _ _, _) -> ((if e then id else (++) cu) i, t)
322            (BTVarParam t'', _) -> ('(' : '*' : i ++ ")" , t'')
323            _ -> (i, t)
324    modify (\s -> s{currentScope = Map.insertWith (++) n [Record i' t' d] (currentScope s), lastIdentifier = n})
325    return $ text i'
326    where
327        n = map toLower i
328
329id2C IOLookup i = id2CLookup head i
330id2C IOLookupLast i = id2CLookup last i
331id2C (IOLookupFunction params) (Identifier i _) = do
332    let i' = map toLower i
333    v <- gets $ Map.lookup i' . currentScope
334    lt <- gets lastType
335    if isNothing v then
336        error $ "Not defined: '" ++ i' ++ "'\n" ++ show lt ++ "\nwith num of params = " ++ show params ++ "\n" ++ show v
337        else
338        let vv = fromMaybe (head $ fromJust v) . find checkParam $ fromJust v in
339            modify (setLastIdValues vv) >> (return . text . lcaseId $ vv)
340    where
341        checkParam (Record _ (BTFunction _ _ p _) _) = (length p) == params
342        checkParam _ = False
343id2C IODeferred (Identifier i _) = do
344    let i' = map toLower i
345    v <- gets $ Map.lookup i' . currentScope
346    if (isNothing v) then
347        modify (\s -> s{lastType = BTUnknown, lastIdentifier = i}) >> return (text i)
348        else
349        let vv = head $ fromJust v in modify (setLastIdValues vv) >> (return . text . lcaseId $ vv)
350
351id2CLookup :: ([Record] -> Record) -> Identifier -> State RenderState Doc
352id2CLookup f (Identifier i _) = do
353    let i' = map toLower i
354    v <- gets $ Map.lookup i' . currentScope
355    lt <- gets lastType
356    if isNothing v then
357        error $ "Not defined: '" ++ i' ++ "'\n" ++ show lt
358        else
359        let vv = f $ fromJust v in modify (setLastIdValues vv) >> (return . text . lcaseId $ vv)
360
361
362
363id2CTyped :: TypeDecl -> Identifier -> State RenderState Doc
364id2CTyped = id2CTyped2 Nothing
365
366id2CTyped2 :: Maybe Doc -> TypeDecl -> Identifier -> State RenderState Doc
367id2CTyped2 md t (Identifier i _) = do
368    tb <- resolveType t
369    case (t, tb) of
370        (_, BTUnknown) -> do
371            error $ "id2CTyped: type BTUnknown for " ++ show i ++ "\ntype: " ++ show t
372        (SimpleType {}, BTRecord _ r) -> do
373            ts <- type2C t
374            id2C (IOInsertWithType $ ts empty) (Identifier i (BTRecord (render $ ts empty) r))
375        (_, BTRecord _ r) -> do
376            ts <- type2C t
377            id2C (IOInsertWithType $ ts empty) (Identifier i (BTRecord i r))
378        _ -> case md of
379                Nothing -> id2C IOInsert (Identifier i tb)
380                Just ts -> id2C (IOInsertWithType ts) (Identifier i tb)
381
382typeVarDecl2BaseType :: [TypeVarDeclaration] -> State RenderState [(Bool, BaseType)]
383typeVarDecl2BaseType d = do
384    st <- get
385    result <- sequence $ concat $ map resolveType' d
386    put st -- restore state (not sure if necessary)
387    return result
388    where
389        resolveType' :: TypeVarDeclaration -> [State RenderState (Bool, BaseType)]
390        resolveType' (VarDeclaration isVar _ (ids, t) _) = replicate (length ids) (resolveTypeHelper' (resolveType t) isVar)
391        resolveType' _ = error "typeVarDecl2BaseType: not a VarDeclaration"
392        resolveTypeHelper' :: State RenderState BaseType -> Bool -> State RenderState (Bool, BaseType)
393        resolveTypeHelper' st b = do
394            bt <- st
395            return (b, bt)
396
397resolveType :: TypeDecl -> State RenderState BaseType
398resolveType st@(SimpleType (Identifier i _)) = do
399    let i' = map toLower i
400    v <- gets $ Map.lookup i' . currentScope
401    if isJust v then return . baseType . head $ fromJust v else return $ f i'
402    where
403    f "uinteger" = BTInt False
404    f "integer" = BTInt True
405    f "pointer" = BTPointerTo BTVoid
406    f "boolean" = BTBool
407    f "float" = BTFloat
408    f "char" = BTChar
409    f "string" = BTString
410    f "ansistring" = BTAString
411    f _ = error $ "Unknown system type: " ++ show st
412resolveType (PointerTo (SimpleType (Identifier i _))) = return . BTPointerTo $ BTUnresolved (map toLower i)
413resolveType (PointerTo t) = liftM BTPointerTo $ resolveType t
414resolveType (RecordType tv mtvs) = do
415    tvs <- mapM f (concat $ tv : fromMaybe [] mtvs)
416    return . BTRecord "" . concat $ tvs
417    where
418        f :: TypeVarDeclaration -> State RenderState [(String, BaseType)]
419        f (VarDeclaration _ _ (ids, td) _) = mapM (\(Identifier i _) -> liftM ((,) i) $ resolveType td) ids
420        f _ = error "resolveType f: pattern not matched"
421resolveType (ArrayDecl (Just i) t) = do
422    t' <- resolveType t
423    return $ BTArray i (BTInt True) t'
424resolveType (ArrayDecl Nothing t) = liftM (BTArray RangeInfinite (BTInt True)) $ resolveType t
425resolveType (FunctionType t a) = do
426    bts <- typeVarDecl2BaseType a
427    liftM (BTFunction False False bts) $ resolveType t
428resolveType (DeriveType (InitHexNumber _)) = return (BTInt True)
429resolveType (DeriveType (InitNumber _)) = return (BTInt True)
430resolveType (DeriveType (InitFloat _)) = return BTFloat
431resolveType (DeriveType (InitString _)) = return BTString
432resolveType (DeriveType (InitBinOp {})) = return (BTInt True)
433resolveType (DeriveType (InitPrefixOp _ e)) = initExpr2C e >> gets lastType
434resolveType (DeriveType (BuiltInFunction{})) = return (BTInt True)
435resolveType (DeriveType (InitReference (Identifier{}))) = return BTBool -- TODO: derive from actual type
436resolveType (DeriveType _) = return BTUnknown
437resolveType String = return BTString
438resolveType AString = return BTAString
439resolveType VoidType = return BTVoid
440resolveType (Sequence ids) = return $ BTEnum $ map (\(Identifier i _) -> map toLower i) ids
441resolveType (RangeType _) = return $ BTVoid
442resolveType (Set t) = liftM BTSet $ resolveType t
443resolveType (VarParamType t) = liftM BTVarParam $ resolveType t
444
445
446resolve :: String -> BaseType -> State RenderState BaseType
447resolve s (BTUnresolved t) = do
448    v <- gets $ Map.lookup t . currentScope
449    if isJust v then
450        resolve s . baseType . head . fromJust $ v
451        else
452        error $ "Unknown type " ++ show t ++ "\n" ++ s
453resolve _ t = return t
454
455fromPointer :: String -> BaseType -> State RenderState BaseType
456fromPointer s (BTPointerTo t) = resolve s t
457fromPointer s t = do
458    error $ "Dereferencing from non-pointer type " ++ show t ++ "\n" ++ s
459
460
461functionParams2C :: [TypeVarDeclaration] -> State RenderState Doc
462functionParams2C params = liftM (hcat . punctuate comma . concat) $ mapM (tvar2C False False True True) params
463
464numberOfDeclarations :: [TypeVarDeclaration] -> Int
465numberOfDeclarations = sum . map cnt
466    where
467        cnt (VarDeclaration _ _ (ids, _) _) = length ids
468        cnt _ = 1
469
470hasPassByReference :: [TypeVarDeclaration] -> Bool
471hasPassByReference = or . map isVar
472    where
473        isVar (VarDeclaration v _ (_, _) _) = v
474        isVar _ = error $ "hasPassByReference called not on function parameters"
475
476toIsVarList :: [TypeVarDeclaration] -> [Bool]
477toIsVarList = concatMap isVar
478    where
479        isVar (VarDeclaration v _ (p, _) _) = replicate (length p) v
480        isVar _ = error $ "toIsVarList called not on function parameters"
481
482
483funWithVarsToDefine :: String -> [TypeVarDeclaration] -> Doc
484funWithVarsToDefine n params = text "#define" <+> text n <> parens abc <+> text (n ++ "__vars") <> parens cparams
485    where
486        abc = hcat . punctuate comma . map (char . fst) $ ps
487        cparams = hcat . punctuate comma . map (\(c, v) -> if v then char '&' <> parens (char c) else char c) $ ps
488        ps = zip ['a'..] (toIsVarList params)
489
490fun2C :: Bool -> String -> TypeVarDeclaration -> State RenderState [Doc]
491fun2C _ _ (FunctionDeclaration name _ overload external returnType params Nothing) = do
492    t <- type2C returnType
493    t'<- gets lastType
494    bts <- typeVarDecl2BaseType params
495    p <- withState' id $ functionParams2C params
496    n <- liftM render . id2C IOInsert $ setBaseType (BTFunction False external bts t') name
497    let decor = if overload then text "__attribute__((overloadable))" else empty
498    return [t empty <+> decor <+> text n <> parens p]
499
500fun2C True rv (FunctionDeclaration name@(Identifier i _) inline overload external returnType params (Just (tvars, phrase))) = do
501    let isVoid = case returnType of
502            VoidType -> True
503            _ -> False
504
505    let res = docToLower $ text rv <> if isVoid then empty else text "_result"
506    t <- type2C returnType
507    t' <- gets lastType
508
509    bts <- typeVarDecl2BaseType params
510    --cu <- gets currentUnit
511    notDeclared <- liftM isNothing . gets $ Map.lookup (map toLower i) . currentScope
512
513    n <- liftM render . id2C IOInsert $ setBaseType (BTFunction hasVars external bts t') name
514    let resultId = if isVoid
515                    then n -- void type doesn't have result, solving recursive procedure calls
516                    else (render res)
517
518    (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
519            , currentFunctionResult = if isVoid then [] else render res}) $ do
520        p <- functionParams2C params
521        ph <- liftM2 ($+$) (typesAndVars2C False False True tvars) (phrase2C' phrase)
522        return (p, ph)
523
524    let isTrivialReturn = case phrase of
525         (Phrases (BuiltInFunctionCall _ (SimpleReference (Identifier "exit" BTUnknown)) : _)) -> True
526         _ -> False
527    let phrasesBlock = if isVoid || isTrivialReturn then ph else t empty <+> res <> semi $+$ ph $+$ text "return" <+> res <> semi
528    --let define = if hasVars then text "#ifndef" <+> text n $+$ funWithVarsToDefine n params $+$ text "#endif" else empty
529    let inlineDecor = if inline then case notDeclared of
530                                    True -> text "static inline"
531                                    False -> text "inline"
532                          else empty
533        overloadDecor = if overload then text "__attribute__((overloadable))" else empty
534    return [
535        --define
536        -- $+$
537        --(if notDeclared && hasVars then funWithVarsToDefine n params else empty) $+$
538        inlineDecor <+> t empty <+> overloadDecor <+> text n <> parens p
539        $+$
540        text "{"
541        $+$
542        nest 4 phrasesBlock
543        $+$
544        text "}"]
545    where
546    phrase2C' (Phrases p) = liftM vcat $ mapM phrase2C p
547    phrase2C' p = phrase2C p
548    un [a] b = a : b
549    un _ _ = error "fun2C u: pattern not matched"
550    hasVars = hasPassByReference params
551
552fun2C False _ (FunctionDeclaration (Identifier name _) _ _ _ _ _ _) = error $ "nested functions not allowed: " ++ name
553fun2C _ tv _ = error $ "fun2C: I don't render " ++ show tv
554
555-- the second bool indicates whether declare variable as extern or not
556-- the third bool indicates whether include types or not
557-- the fourth bool indicates whether ignore initialization or not (basically for dynamic arrays since we cannot do initialization in function params)
558tvar2C :: Bool -> Bool -> Bool -> Bool -> TypeVarDeclaration -> State RenderState [Doc]
559tvar2C b _ includeType _ f@(FunctionDeclaration (Identifier name _) _ _ _ _ _ _) = do
560    t <- fun2C b name f
561    if includeType then return t else return []
562tvar2C _ _ includeType _ (TypeDeclaration i' t) = do
563    i <- id2CTyped t i'
564    tp <- type2C t
565    let res = if includeType then [text "typedef" <+> tp i] else []
566    case t of
567        (Sequence ids) -> do
568            modify(\s -> s{enums = (render i, map (\(Identifier id' _) -> id') ids) : enums s})
569            return res
570        _ -> return res
571
572tvar2C _ _ _ _ (VarDeclaration True _ (ids, t) Nothing) = do
573    t' <- liftM ((empty <+>) . ) $ type2C t
574    liftM (map(\i -> t' i)) $ mapM (id2CTyped2 (Just $ t' empty) (VarParamType t)) ids
575
576tvar2C _ externVar includeType ignoreInit (VarDeclaration _ isConst (ids, t) mInitExpr) = do
577    t' <- liftM (((if isConst then text "static const" else if externVar
578                                                                then text "extern"
579                                                                else empty)
580                   <+>) . ) $ type2C t
581    ie <- initExpr mInitExpr
582    lt <- gets lastType
583    case (isConst, lt, ids, mInitExpr) of
584         (True, BTInt _, [i], Just _) -> do
585             i' <- id2CTyped t i
586             return $ if includeType then [text "enum" <> braces (i' <+> ie)] else []
587         (True, BTFloat, [i], Just e) -> do
588             i' <- id2CTyped t i
589             ie' <- initExpr2C e
590             return $ if includeType then [text "#define" <+> i' <+> parens ie' <> text "\n"] else []
591         (_, BTFunction{}, _, Nothing) -> liftM (map(\i -> t' i)) $ mapM (id2CTyped t) ids
592         (_, BTArray r _ _, [i], _) -> do
593            i' <- id2CTyped t i
594            ie' <- return $ case (r, mInitExpr, ignoreInit) of
595                (RangeInfinite, Nothing, False) -> text "= NULL" -- force dynamic array to be initialized as NULL if not initialized at all
596                (_, _, _) -> ie
597            result <- liftM (map(\id' -> varDeclDecision isConst includeType (t' id') ie')) $ mapM (id2CTyped t) ids
598            case (r, ignoreInit) of
599                (RangeInfinite, False) ->
600                    -- if the array is dynamic, add dimension info to it
601                    return $ [dimDecl] ++ result
602                    where
603                        arrayDimStr = show $ arrayDimension t
604                        arrayDimInitExp = text ("={" ++ ".dim = " ++ arrayDimStr ++ ", .a = {0, 0, 0, 0}}")
605                        dimDecl = varDeclDecision isConst includeType (text "fpcrtl_dimension_t" <+>  i' <> text "_dimension_info") arrayDimInitExp
606
607                (_, _) -> return result
608
609         _ -> liftM (map(\i -> varDeclDecision isConst includeType (t' i) ie)) $ mapM (id2CTyped2 (Just $ t' empty) t) ids
610    where
611    initExpr Nothing = return $ empty
612    initExpr (Just e) = liftM (text "=" <+>) (initExpr2C e)
613    varDeclDecision True True varStr expStr = varStr <+> expStr
614    varDeclDecision False True varStr expStr = if externVar then varStr else varStr <+> expStr
615    varDeclDecision False False varStr expStr = varStr <+> expStr
616    varDeclDecision True False _ _ = empty
617    arrayDimension a = case a of
618        ArrayDecl Nothing t' -> let a' = arrayDimension t' in
619                                   if a' > 3 then error "Dynamic array with dimension > 4 is not supported." else 1 + a'
620        ArrayDecl _ _ -> error "Mixed dynamic array and static array are not supported."
621        _ -> 0
622
623tvar2C f _ _ _ (OperatorDeclaration op (Identifier i _) inline ret params body) = do
624    r <- op2CTyped op (extractTypes params)
625    fun2C f i (FunctionDeclaration r inline False False ret params body)
626
627
628op2CTyped :: String -> [TypeDecl] -> State RenderState Identifier
629op2CTyped op t = do
630    t' <- liftM (render . hcat . punctuate (char '_') . map (\txt -> txt empty)) $ mapM type2C t
631    bt <- gets lastType
632    return $ Identifier (t' ++ "_op_" ++ opStr) bt
633    where
634    opStr = case op of
635                    "+" -> "add"
636                    "-" -> "sub"
637                    "*" -> "mul"
638                    "/" -> "div"
639                    "/(float)" -> "div"
640                    "=" -> "eq"
641                    "<" -> "lt"
642                    ">" -> "gt"
643                    "<>" -> "neq"
644                    _ -> error $ "op2CTyped: unknown op '" ++ op ++ "'"
645
646extractTypes :: [TypeVarDeclaration] -> [TypeDecl]
647extractTypes = concatMap f
648    where
649        f (VarDeclaration _ _ (ids, t) _) = replicate (length ids) t
650        f a = error $ "extractTypes: can't extract from " ++ show a
651
652initExpr2C, initExpr2C' :: InitExpression -> State RenderState Doc
653initExpr2C (InitArray values) = liftM (braces . vcat . punctuate comma) $ mapM initExpr2C values
654initExpr2C a = initExpr2C' a
655initExpr2C' InitNull = return $ text "NULL"
656initExpr2C' (InitAddress expr) = do
657    ie <- initExpr2C' expr
658    lt <- gets lastType
659    case lt of
660        BTFunction True _ _ _ -> return $ text "&" <> ie -- <> text "__vars"
661        _ -> return $ text "&" <> ie
662initExpr2C' (InitPrefixOp op expr) = liftM (text (op2C op) <>) (initExpr2C' expr)
663initExpr2C' (InitBinOp op expr1 expr2) = do
664    e1 <- initExpr2C' expr1
665    e2 <- initExpr2C' expr2
666    return $ parens $ e1 <+> text (op2C op) <+> e2
667initExpr2C' (InitNumber s) = do
668                                modify(\st -> st{lastType = (BTInt True)})
669                                return $ text s
670initExpr2C' (InitFloat s) = return $ text s
671initExpr2C' (InitHexNumber s) = return $ text "0x" <> (text . map toLower $ s)
672initExpr2C' (InitString [a]) = return . quotes $ text [a]
673initExpr2C' (InitString s) = return $ strInit s
674initExpr2C' (InitPChar s) = return $ doubleQuotes (text $ escapeStr s)
675initExpr2C' (InitChar a) = return $ text "0x" <> text (showHex (read a) "")
676initExpr2C' (InitReference i) = id2C IOLookup i
677initExpr2C' (InitRecord fields) = do
678    (fs :: [Doc]) <- mapM (\(Identifier a _, b) -> liftM (text "." <> text a <+> equals <+>) $ initExpr2C b) fields
679    return $ lbrace $+$ (nest 4 . vcat . punctuate comma $ fs) $+$ rbrace
680--initExpr2C' (InitArray [InitRecord fields]) = do
681--    e <- initExpr2C $ InitRecord fields
682--    return $ braces $ e
683initExpr2C' r@(InitRange (Range i@(Identifier i' _))) = do
684    void $ id2C IOLookup i
685    t <- gets lastType
686    case t of
687         BTEnum s -> return . int $ length s
688         BTInt _ -> case i' of
689                       "byte" -> return $ int 256
690                       _ -> error $ "InitRange identifier: " ++ i'
691         _ -> error $ "InitRange: " ++ show r
692initExpr2C' (InitRange (RangeFromTo (InitNumber "0") r)) = initExpr2C $ BuiltInFunction "succ" [r]
693initExpr2C' (InitRange (RangeFromTo (InitChar "0") (InitChar r))) = initExpr2C $ BuiltInFunction "succ" [InitNumber r]
694initExpr2C' (InitRange a) = error $ show a --return $ text "<<range>>"
695initExpr2C' (InitSet []) = return $ text "0"
696initExpr2C' (InitSet _) = return $ text "<<set>>"
697initExpr2C' (BuiltInFunction "low" [InitReference e]) = return $
698    case e of
699         (Identifier "LongInt" _) -> int (-2^31)
700         (Identifier "SmallInt" _) -> int (-2^15)
701         _ -> error $ "BuiltInFunction 'low': " ++ show e
702initExpr2C' hi@(BuiltInFunction "high" [e@(InitReference e')]) = do
703    void $ initExpr2C e
704    t <- gets lastType
705    case t of
706         (BTArray i _ _) -> initExpr2C' $ BuiltInFunction "pred" [InitRange i]
707         BTInt _ -> case e' of
708                  (Identifier "LongInt" _) -> return $ int (2147483647)
709                  (Identifier "LongWord" _) -> return $ text "4294967295"
710                  _ -> error $ "BuiltInFunction 'high' in initExpr: " ++ show e'
711         a -> error $ "BuiltInFunction 'high' in initExpr: " ++ show a ++ ": " ++ show hi
712initExpr2C' (BuiltInFunction "succ" [BuiltInFunction "pred" [e]]) = initExpr2C' e
713initExpr2C' (BuiltInFunction "pred" [BuiltInFunction "succ" [e]]) = initExpr2C' e
714initExpr2C' (BuiltInFunction "succ" [e]) = liftM (<> text " + 1") $ initExpr2C' e
715initExpr2C' (BuiltInFunction "pred" [e]) = liftM (<> text " - 1") $ initExpr2C' e
716initExpr2C' b@(BuiltInFunction _ _) = error $ show b
717initExpr2C' (InitTypeCast t' i) = do
718    e <- initExpr2C i
719    t <- id2C IOLookup t'
720    return . parens $ parens t <> e
721initExpr2C' a = error $ "initExpr2C: don't know how to render " ++ show a
722
723
724range2C :: InitExpression -> State RenderState [Doc]
725range2C (InitString [a]) = return [quotes $ text [a]]
726range2C (InitRange (Range i)) = liftM (flip (:) []) $ id2C IOLookup i
727range2C (InitRange (RangeFromTo (InitString [a]) (InitString [b]))) = return $ map (\i -> quotes $ text [i]) [a..b]
728range2C a = liftM (flip (:) []) $ initExpr2C a
729
730baseType2C :: String -> BaseType -> Doc
731baseType2C _ BTFloat = text "float"
732baseType2C _ BTBool = text "bool"
733baseType2C _ BTString = text "string255"
734baseType2C _ BTAString = text "astring"
735baseType2C s a = error $ "baseType2C: " ++ show a ++ "\n" ++ s
736
737type2C :: TypeDecl -> State RenderState (Doc -> Doc)
738type2C (SimpleType i) = liftM (\i' a -> i' <+> a) $ id2C IOLookup i
739type2C t = do
740    r <- type2C' t
741    rt <- resolveType t
742    modify (\st -> st{lastType = rt})
743    return r
744    where
745    type2C' VoidType = return (text "void" <+>)
746    type2C' String = return (text "string255" <+>)--return (text ("string" ++ show l) <+>)
747    type2C' AString = return (text "astring" <+>)
748    type2C' (PointerTo (SimpleType i)) = do
749        i' <- id2C IODeferred i
750        lt <- gets lastType
751        case lt of
752             BTRecord _ _ -> return $ \a -> text "struct __" <> i' <+> text "*" <+> a
753             BTUnknown -> return $ \a -> text "struct __" <> i' <+> text "*" <+> a
754             _ -> return $ \a -> i' <+> text "*" <+> a
755    type2C' (PointerTo t) = liftM (\tx a -> tx (parens $ text "*" <> a)) $ type2C t
756    type2C' (RecordType tvs union) = do
757        t' <- withState' f $ mapM (tvar2C False False True False) tvs
758        u <- unions
759        return $ \i -> text "struct __" <> i <+> lbrace $+$ nest 4 ((vcat . map (<> semi) . concat $ t') $$ u) $+$ rbrace <+> i
760        where
761            f s = s{currentUnit = ""}
762            unions = case union of
763                     Nothing -> return empty
764                     Just a -> do
765                         structs <- mapM struct2C a
766                         return $ text "union" $+$ braces (nest 4 $ vcat structs) <> semi
767            struct2C stvs = do
768                txts <- withState' f $ mapM (tvar2C False False True False) stvs
769                return $ text "struct" $+$ braces (nest 4 (vcat . map (<> semi) . concat $ txts)) <> semi
770    type2C' (RangeType r) = return (text "int" <+>)
771    type2C' (Sequence ids) = do
772        is <- mapM (id2C IOInsert . setBaseType bt) ids
773        return (text "enum" <+> (braces . vcat . punctuate comma . map (\(a, b) -> a <+> equals <+> text "0x" <> text (showHex b "")) $ zip is [0..]) <+>)
774        where
775            bt = BTEnum $ map (\(Identifier i _) -> map toLower i) ids
776    type2C' (ArrayDecl Nothing t) = type2C (PointerTo t)
777    type2C' (ArrayDecl (Just r1) (ArrayDecl (Just r2) t)) = do
778        t' <- type2C t
779        lt <- gets lastType
780        r1' <- initExpr2C (InitRange r1)
781        r2' <- initExpr2C (InitRange r2)
782        return $ \i -> t' i <> brackets r1' <> brackets r2'
783    type2C' (ArrayDecl (Just r) t) = do
784        t' <- type2C t
785        lt <- gets lastType
786        ft <- case lt of
787                -- BTFunction {} -> type2C (PointerTo t)
788                _ -> return t'
789        r' <- initExpr2C (InitRange r)
790        return $ \i -> ft i <> brackets r'
791    type2C' (Set t) = return (text "<<set>>" <+>)
792    type2C' (FunctionType returnType params) = do
793        t <- type2C returnType
794        p <- withState' id $ functionParams2C params
795        return (\i -> (t empty <> (parens $ text "*" <> i) <> parens p))
796    type2C' (DeriveType (InitBinOp _ _ i)) = type2C' (DeriveType i)
797    type2C' (DeriveType (InitPrefixOp _ i)) = type2C' (DeriveType i)
798    type2C' (DeriveType (InitNumber _)) = return (text "int" <+>)
799    type2C' (DeriveType (InitHexNumber _)) = return (text "int" <+>)
800    type2C' (DeriveType (InitFloat _)) = return (text "float" <+>)
801    type2C' (DeriveType (BuiltInFunction {})) = return (text "int" <+>)
802    type2C' (DeriveType (InitString {})) = return (text "string255" <+>)
803    type2C' (DeriveType r@(InitReference {})) = do
804        initExpr2C r
805        t <- gets lastType
806        return (baseType2C (show r) t <+>)
807    type2C' (DeriveType a) = error $ "Can't derive type from " ++ show a
808    type2C' a = error $ "type2C: unknown type " ++ show a
809
810phrase2C :: Phrase -> State RenderState Doc
811phrase2C (Phrases p) = do
812    ps <- mapM phrase2C p
813    return $ text "{" $+$ (nest 4 . vcat $ ps) $+$ text "}"
814phrase2C (ProcCall f@(FunCall {}) []) = liftM (<> semi) $ ref2C f
815phrase2C (ProcCall ref []) = liftM (<> semi) $ ref2CF ref True
816phrase2C (ProcCall _ _) = error $ "ProcCall"{-do
817    r <- ref2C ref
818    ps <- mapM expr2C params
819    return $ r <> parens (hsep . punctuate (char ',') $ ps) <> semi -}
820phrase2C (IfThenElse (expr) phrase1 mphrase2) = do
821    e <- expr2C expr
822    p1 <- (phrase2C . wrapPhrase) phrase1
823    el <- elsePart
824    return $
825        text "if" <> parens e $+$ p1 $+$ el
826    where
827    elsePart | isNothing mphrase2 = return $ empty
828             | otherwise = liftM (text "else" $$) $ (phrase2C . wrapPhrase) (fromJust mphrase2)
829phrase2C asgn@(Assignment ref expr) = do
830    r <- ref2C ref
831    t <- gets lastType
832    case (t, expr) of
833        (_, Reference r') | ref == r' -> do
834            e <- ref2C r'
835            return $ text "UNUSED" <+> parens e <> semi
836        (BTFunction {}, (Reference r')) -> do
837            e <- ref2C r'
838            return $ r <+> text "=" <+> e <> semi
839        (BTString, _) -> do
840            void $ expr2C expr
841            lt <- gets lastType
842            case lt of
843                -- assume pointer to char for simplicity
844                BTPointerTo _ -> do
845                    e <- expr2C $ Reference $ FunCall [Reference $ RefExpression expr] (SimpleReference (Identifier "pchar2str" BTUnknown))
846                    return $ r <+> text "=" <+> e <> semi
847                BTAString -> do
848                    e <- expr2C $ Reference $ FunCall [Reference $ RefExpression expr] (SimpleReference (Identifier "astr2str" BTUnknown))
849                    return $ r <+> text "=" <+> e <> semi
850                BTString -> do
851                    e <- expr2C expr
852                    return $ r <+> text "=" <+> e <> semi
853                _ -> error $ "Assignment to string from " ++ show lt ++ "\n" ++ show asgn
854        (BTAString, _) -> do
855            void $ expr2C expr
856            lt <- gets lastType
857            case lt of
858                -- assume pointer to char for simplicity
859                BTPointerTo _ -> do
860                    e <- expr2C $ Reference $ FunCall [Reference $ RefExpression expr] (SimpleReference (Identifier "pchar2astr" BTUnknown))
861                    return $ r <+> text "=" <+> e <> semi
862                BTString -> do
863                    e <- expr2C $ Reference $ FunCall [Reference $ RefExpression expr] (SimpleReference (Identifier "str2astr" BTUnknown))
864                    return $ r <+> text "=" <+> e <> semi
865                BTAString -> do
866                    e <- expr2C expr
867                    return $ r <+> text "=" <+> e <> semi
868                _ -> error $ "Assignment to ansistring from " ++ show lt ++ "\n" ++ show asgn
869        (BTArray _ _ _, _) -> do
870            case expr of
871                Reference er -> do
872                    void $ ref2C er
873                    exprT <- gets lastType
874                    case exprT of
875                        BTArray RangeInfinite _ _ ->
876                            return $ text "FIXME: assign a dynamic array to an array"
877                        BTArray _ _ _ -> phrase2C $
878                                ProcCall (FunCall
879                                    [
880                                    Reference $ ref
881                                    , Reference $ RefExpression expr
882                                    , Reference $ FunCall [expr] (SimpleReference (Identifier "sizeof" BTUnknown))
883                                    ]
884                                    (SimpleReference (Identifier "memcpy" BTUnknown))
885                                    ) []
886                        _ -> return $ text "FIXME: assign a non-specific value to an array"
887
888                _ -> return $ text "FIXME: dynamic array assignment 2"
889        _ -> do
890            e <- expr2C expr
891            return $ r <+> text "=" <+> e <> semi
892phrase2C (WhileCycle expr phrase) = do
893    e <- expr2C expr
894    p <- phrase2C $ wrapPhrase phrase
895    return $ text "while" <> parens e $$ p
896phrase2C (SwitchCase expr cases mphrase) = do
897    e <- expr2C expr
898    cs <- mapM case2C cases
899    d <- dflt
900    return $
901        text "switch" <> parens e $+$ braces (nest 4 . vcat $ cs ++ d)
902    where
903    case2C :: ([InitExpression], Phrase) -> State RenderState Doc
904    case2C (e, p) = do
905        ies <- mapM range2C e
906        ph <- phrase2C p
907        return $
908             vcat (map (\i -> text "case" <+> i <> colon) . concat $ ies) <> nest 4 (ph $+$ text "break;")
909    dflt | isNothing mphrase = return [text "default: break;"] -- avoid compiler warning
910         | otherwise = do
911             ph <- mapM phrase2C $ fromJust mphrase
912             return [text "default:" <+> nest 4 (vcat ph)]
913
914phrase2C wb@(WithBlock ref p) = do
915    r <- ref2C ref
916    t <- gets lastType
917    case t of
918        (BTRecord _ rs) -> withRecordNamespace (render r ++ ".") (rec2Records rs) $ phrase2C $ wrapPhrase p
919        a -> do
920            error $ "'with' block referencing non-record type " ++ show a ++ "\n" ++ show wb
921phrase2C (ForCycle i' e1' e2' p up) = do
922    i <- id2C IOLookup i'
923    iType <- gets lastIdTypeDecl
924    e1 <- expr2C e1'
925    e2 <- expr2C e2'
926    let iEnd = i <> text "__end__"
927    ph <- phrase2C $ wrapPhrase p
928    return . braces $
929        i <+> text "=" <+> e1 <> semi
930        $$
931        iType <+> iEnd <+> text "=" <+> e2 <> semi
932        $$
933        text "if" <+> (parens $ i <+> text (if up then "<=" else ">=") <+> iEnd) <+> text "do" <+> ph <+>
934        text "while" <> parens (i <> text (if up then "++" else "--") <+> text "!=" <+> iEnd) <> semi
935    where
936        appendPhrase p (Phrases ps) = Phrases $ ps ++ [p]
937        appendPhrase _ _ = error "illegal appendPhrase call"
938phrase2C (RepeatCycle e' p') = do
939    e <- expr2C e'
940    p <- phrase2C (Phrases p')
941    return $ text "do" <+> p <+> text "while" <> parens (text "!" <> parens e) <> semi
942
943phrase2C NOP = return $ text ";"
944
945phrase2C (BuiltInFunctionCall [] (SimpleReference (Identifier "exit" BTUnknown))) = do
946    f <- gets currentFunctionResult
947    if null f then
948        return $ text "return" <> semi
949        else
950        return $ text "return" <+> text f <> semi
951phrase2C (BuiltInFunctionCall [] (SimpleReference (Identifier "break" BTUnknown))) = return $ text "break" <> semi
952phrase2C (BuiltInFunctionCall [] (SimpleReference (Identifier "continue" BTUnknown))) = return $ text "continue" <> semi
953phrase2C (BuiltInFunctionCall [e] (SimpleReference (Identifier "exit" BTUnknown))) = liftM (\e -> text "return" <+> e <> semi) $ expr2C e
954phrase2C (BuiltInFunctionCall [e] (SimpleReference (Identifier "dec" BTUnknown))) = liftM (\e -> text "--" <> e <> semi) $ expr2C e
955phrase2C (BuiltInFunctionCall [e1, e2] (SimpleReference (Identifier "dec" BTUnknown))) = liftM2 (\a b -> a <> text " -= " <> b <> semi) (expr2C e1) (expr2C e2)
956phrase2C (BuiltInFunctionCall [e] (SimpleReference (Identifier "inc" BTUnknown))) = liftM (\e -> text "++" <> e <> semi) $ expr2C e
957phrase2C (BuiltInFunctionCall [e1, e2] (SimpleReference (Identifier "inc" BTUnknown))) = liftM2 (\a b -> a <+> text "+=" <+> b <> semi) (expr2C e1) (expr2C e2)
958phrase2C a = error $ "phrase2C: " ++ show a
959
960wrapPhrase p@(Phrases _) = p
961wrapPhrase p = Phrases [p]
962
963expr2C :: Expression -> State RenderState Doc
964expr2C (Expression s) = return $ text s
965expr2C bop@(BinOp op expr1 expr2) = do
966    e1 <- expr2C expr1
967    t1 <- gets lastType
968    e2 <- expr2C expr2
969    t2 <- gets lastType
970    case (op2C op, t1, t2) of
971        ("+", BTAString, BTAString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strconcatA" (fff t1 t2 BTString))
972        ("+", BTAString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strappendA" (fff t1 t2  BTAString))
973        ("+", BTChar, BTAString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strprependA" (fff t1 t2  BTAString))
974        ("!=", BTAString, BTAString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strncompareA" (fff t1 t2  BTBool))
975        (_, BTAString, _) -> error $ "unhandled bin op with ansistring on the left side: " ++ show bop
976        (_, _, BTAString) -> error $ "unhandled bin op with ansistring on the right side: " ++ show bop
977        ("+", BTString, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strconcat" (fff t1 t2  BTString))
978        ("+", BTString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strappend" (fff t1 t2  BTString))
979        ("+", BTChar, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strprepend" (fff t1 t2  BTString))
980        ("+", BTChar, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_chrconcat" (fff t1 t2  BTString))
981        ("==", BTString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcomparec" (fff t1 t2  BTBool))
982
983        -- for function/procedure comparision
984        ("==", BTVoid, _) -> procCompare expr1 expr2 "=="
985        ("==", BTFunction _ _ _ _, _) -> procCompare expr1 expr2 "=="
986
987        ("!=", BTVoid, _) -> procCompare expr1 expr2 "!="
988        ("!=", BTFunction _ _ _ _, _) -> procCompare expr1 expr2 "!="
989
990        ("==", BTString, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcompare" (fff t1 t2  BTBool))
991        ("!=", BTString, _) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strncompare" (fff t1 t2  BTBool))
992        ("&", BTBool, _) -> return $ parens e1 <+> text "&&" <+> parens e2
993        ("|", BTBool, _) -> return $ parens e1 <+> text "||" <+> parens e2
994        (_, BTRecord t1 _, BTRecord t2 _) -> do
995            i <- op2CTyped op [SimpleType (Identifier t1 undefined), SimpleType (Identifier t2 undefined)]
996            ref2C $ FunCall [expr1, expr2] (SimpleReference i)
997        (_, BTRecord t1 _, BTInt _) -> do
998            -- aw, "LongInt" here is hwengine-specific hack
999            i <- op2CTyped op [SimpleType (Identifier t1 undefined), SimpleType (Identifier "LongInt" undefined)]
1000            ref2C $ FunCall [expr1, expr2] (SimpleReference i)
1001        ("in", _, _) ->
1002            case expr2 of
1003                 SetExpression set -> do
1004                     ids <- mapM (id2C IOLookup) set
1005                     modify(\s -> s{lastType = BTBool})
1006                     return . parens . hcat . punctuate (text " || ") . map (\i -> parens $ e1 <+> text "==" <+> i) $ ids
1007                 _ -> error "'in' against not set expression"
1008        (o, _, _) | o `elem` boolOps -> do
1009                        modify(\s -> s{lastType = BTBool})
1010                        return $ parens e1 <+> text o <+> parens e2
1011                  | otherwise -> do
1012                        o' <- return $ case o of
1013                            "/(float)" -> text "/(float)" -- pascal returns real value
1014                            _ -> text o
1015                        e1' <- return $ case (o, t1, t2) of
1016                                ("-", BTInt False, BTInt False) -> parens $ text "(int64_t)" <+> parens e1
1017                                _ -> parens e1
1018                        e2' <- return $ case (o, t1, t2) of
1019                                ("-", BTInt False, BTInt False) -> parens $ text "(int64_t)" <+> parens e2
1020                                _ -> parens e2
1021                        return $ e1' <+> o' <+> e2'
1022    where
1023        fff t1 t2 = BTFunction False False [(False, t1), (False, t2)]
1024        boolOps = ["==", "!=", "<", ">", "<=", ">="]
1025        procCompare expr1 expr2 op =
1026            case (expr1, expr2) of
1027                (Reference r1, Reference r2) -> do
1028                    id1 <- ref2C r1
1029                    id2 <- ref2C r2
1030                    return $ (parens id1) <+> text op <+> (parens id2)
1031                (_, _) -> error $ "Two non reference type vars are compared but they have type of BTVoid or BTFunction\n" ++ show expr1 ++ "\n" ++ show expr2
1032
1033expr2C (NumberLiteral s) = do
1034    modify(\s -> s{lastType = BTInt True})
1035    return $ text s
1036expr2C (FloatLiteral s) = return $ text s
1037expr2C (HexNumber s) = return $ text "0x" <> (text . map toLower $ s)
1038{-expr2C (StringLiteral [a]) = do
1039    modify(\s -> s{lastType = BTChar})
1040    return . quotes . text $ escape a
1041    where
1042        escape '\'' = "\\\'"
1043        escape a = [a]-}
1044expr2C (StringLiteral s) = addStringConst s
1045expr2C (PCharLiteral s) = return . doubleQuotes $ text s
1046expr2C (Reference ref) = do
1047   isfunc <- gets isFunctionType
1048   modify(\s -> s{isFunctionType = False}) -- reset
1049   if isfunc then ref2CF ref False else ref2CF ref True
1050expr2C (PrefixOp op expr) = do
1051    e <- expr2C expr
1052    lt <- gets lastType
1053    case lt of
1054        BTRecord t _ -> do
1055            i <- op2CTyped op [SimpleType (Identifier t undefined)]
1056            ref2C $ FunCall [expr] (SimpleReference i)
1057        BTBool -> do
1058            o <- return $ case op of
1059                     "not" -> text "!"
1060                     _ -> text (op2C op)
1061            return $ o <> parens e
1062        _ -> return $ text (op2C op) <> parens e
1063expr2C Null = return $ text "NULL"
1064expr2C (CharCode a) = do
1065    modify(\s -> s{lastType = BTChar})
1066    return $ text "0x" <> text (showHex (read a) "")
1067expr2C (HexCharCode a) = if length a <= 2 then return $ quotes $ text "\\x" <> text (map toLower a) else expr2C $ HexNumber a
1068expr2C (SetExpression ids) = mapM (id2C IOLookup) ids >>= return . parens . hcat . punctuate (text " | ")
1069
1070expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "low" _))) = do
1071    e' <- liftM (map toLower . render) $ expr2C e
1072    lt <- gets lastType
1073    case lt of
1074         BTEnum _-> return $ int 0
1075         BTInt _ -> case e' of
1076                  "longint" -> return $ int (-2147483648)
1077         BTArray {} -> return $ int 0
1078         _ -> error $ "BuiltInFunCall 'low' from " ++ show e ++ "\ntype: " ++ show lt
1079expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "high" _))) = do
1080    e' <- liftM (map toLower . render) $ expr2C e
1081    lt <- gets lastType
1082    case lt of
1083         BTEnum a -> return . int $ length a - 1
1084         BTInt _ -> case e' of
1085                  "longint" -> return $ int (2147483647)
1086         BTString -> return $ int 255
1087         BTArray (RangeFromTo _ n) _ _ -> initExpr2C n
1088         _ -> error $ "BuiltInFunCall 'high' from " ++ show e ++ "\ntype: " ++ show lt
1089expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "ord" _))) = liftM parens $ expr2C e
1090expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "succ" _))) = liftM (<> text " + 1") $ expr2C e
1091expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "pred" _))) = do
1092    e'<- expr2C e
1093    return $ text "(int)" <> parens e' <> text " - 1"
1094expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "length" _))) = do
1095    e' <- expr2C e
1096    lt <- gets lastType
1097    modify (\s -> s{lastType = BTInt True})
1098    case lt of
1099         BTString -> return $ text "fpcrtl_Length" <> parens e'
1100         BTAString -> return $ text "fpcrtl_LengthA" <> parens e'
1101         BTArray RangeInfinite _ _ -> error $ "length() called on variable size array " ++ show e'
1102         BTArray (RangeFromTo _ n) _ _ -> initExpr2C (BuiltInFunction "succ" [n])
1103         _ -> error $ "length() called on " ++ show lt
1104expr2C (BuiltInFunCall [e, e1, e2] (SimpleReference (Identifier "copy" _))) = do
1105    e1' <- expr2C e1
1106    e2' <- expr2C e2
1107    e' <- expr2C e
1108    lt <- gets lastType
1109    let f name = return $ text name <> parens (hsep $ punctuate (char ',') [e', e1', e2'])
1110    case lt of
1111         BTString -> f "fpcrtl_copy"
1112         BTAString -> f "fpcrtl_copyA"
1113         _ -> error $ "copy() called on " ++ show lt
1114
1115expr2C (BuiltInFunCall params ref) = do
1116    r <- ref2C ref
1117    t <- gets lastType
1118    ps <- mapM expr2C params
1119    case t of
1120        BTFunction _ _ _ t' -> do
1121            modify (\s -> s{lastType = t'})
1122        _ -> error $ "BuiltInFunCall `" ++ show ref ++ "`, lastType: " ++ show t
1123    return $
1124        r <> parens (hsep . punctuate (char ',') $ ps)
1125expr2C a = error $ "Don't know how to render " ++ show a
1126
1127ref2CF :: Reference -> Bool -> State RenderState Doc
1128ref2CF (SimpleReference name) addParens = do
1129    i <- id2C IOLookup name
1130    t <- gets lastType
1131    case t of
1132         BTFunction _ _ _ rt -> do
1133             modify(\s -> s{lastType = rt})
1134             return $ if addParens then i <> parens empty else i --xymeng: removed parens
1135         _ -> return $ i
1136ref2CF r@(RecordField (SimpleReference _) (SimpleReference _)) addParens = do
1137    i <- ref2C r
1138    t <- gets lastType
1139    case t of
1140         BTFunction _ _ _ rt -> do
1141             modify(\s -> s{lastType = rt})
1142             return $ if addParens then i <> parens empty else i
1143         _ -> return $ i
1144ref2CF r _ = ref2C r
1145
1146ref2C :: Reference -> State RenderState Doc
1147-- rewrite into proper form
1148ref2C (RecordField ref1 (ArrayElement exprs ref2)) = ref2C $ ArrayElement exprs (RecordField ref1 ref2)
1149ref2C (RecordField ref1 (Dereference ref2)) = ref2C $ Dereference (RecordField ref1 ref2)
1150ref2C (RecordField ref1 (RecordField ref2 ref3)) = ref2C $ RecordField (RecordField ref1 ref2) ref3
1151ref2C (RecordField ref1 (FunCall params ref2)) = ref2C $ FunCall params (RecordField ref1 ref2)
1152ref2C (ArrayElement (a:b:xs) ref) = ref2C $ ArrayElement (b:xs) (ArrayElement [a] ref)
1153-- conversion routines
1154ref2C ae@(ArrayElement [expr] ref) = do
1155    e <- expr2C expr
1156    r <- ref2C ref
1157    t <- gets lastType
1158    case t of
1159         (BTArray _ _ t') -> modify (\st -> st{lastType = t'})
1160--         (BTFunctionReturn _ (BTArray _ _ t')) -> modify (\st -> st{lastType = t'})
1161--         (BTFunctionReturn _ (BTString)) -> modify (\st -> st{lastType = BTChar})
1162         BTString -> modify (\st -> st{lastType = BTChar})
1163         BTAString -> modify (\st -> st{lastType = BTChar})
1164         (BTPointerTo t) -> do
1165                t'' <- fromPointer (show t) =<< gets lastType
1166                case t'' of
1167                     BTChar -> modify (\st -> st{lastType = BTChar})
1168                     a -> error $ "Getting element of " ++ show a ++ "\nReference: " ++ show ae
1169         a -> error $ "Getting element of " ++ show a ++ "\nReference: " ++ show ae
1170    case t of
1171         BTString ->  return $ r <> text ".s" <> brackets e
1172         BTAString ->  return $ r <> text ".s" <> brackets e
1173         _ -> return $ r <> brackets e
1174ref2C (SimpleReference name) = id2C IOLookup name
1175ref2C rf@(RecordField (Dereference ref1) ref2) = do
1176    r1 <- ref2C ref1
1177    t <- fromPointer (show ref1) =<< gets lastType
1178    r2 <- case t of
1179        BTRecord _ rs -> withRecordNamespace "" (rec2Records rs) $ ref2C ref2
1180        BTUnit -> error "What??"
1181        a -> error $ "dereferencing from " ++ show a ++ "\n" ++ show rf
1182    return $
1183        r1 <> text "->" <> r2
1184ref2C rf@(RecordField ref1 ref2) = do
1185    r1 <- ref2C ref1
1186    t <- gets lastType
1187    case t of
1188        BTRecord _ rs -> do
1189            r2 <- withRecordNamespace "" (rec2Records rs) $ ref2C ref2
1190            return $ r1 <> text "." <> r2
1191        BTUnit -> withLastIdNamespace $ ref2C ref2
1192        a -> error $ "dereferencing from " ++ show a ++ "\n" ++ show rf
1193ref2C d@(Dereference ref) = do
1194    r <- ref2C ref
1195    t <- fromPointer (show d) =<< gets lastType
1196    modify (\st -> st{lastType = t})
1197    return $ (parens $ text "*" <> r)
1198ref2C f@(FunCall params ref) = do
1199    r <- fref2C ref
1200    t <- gets lastType
1201    case t of
1202        BTFunction _ _ bts t' -> do
1203            ps <- liftM (parens . hsep . punctuate (char ',')) $
1204                    if (length params) == (length bts) -- hot fix for pas2cSystem and pas2cRedo functions since they don't have params
1205                    then
1206                        mapM expr2CHelper (zip params bts)
1207                    else mapM expr2C params
1208            modify (\s -> s{lastType = t'})
1209            return $ r <> ps
1210        _ -> case (ref, params) of
1211                  (SimpleReference i, [p]) -> ref2C $ TypeCast i p
1212                  _ -> error $ "ref2C FunCall erroneous type cast detected: " ++ show f ++ "\nType detected: " ++ show t ++ "\n" ++ show ref ++ "\n" ++ show params ++ "\n" ++ show t
1213    where
1214    fref2C (SimpleReference name) = id2C (IOLookupFunction $ length params) name
1215    fref2C a = ref2C a
1216    expr2CHelper :: (Expression, (Bool, BaseType)) -> State RenderState Doc
1217    expr2CHelper (e, (_, BTFunction _ _ _ _)) = do
1218        modify (\s -> s{isFunctionType = True})
1219        expr2C e
1220    expr2CHelper (e, (isVar, _)) = if isVar then liftM (((<>) $ text "&") . parens) $ (expr2C e) else expr2C e
1221
1222ref2C (Address ref) = do
1223    r <- ref2C ref
1224    lt <- gets lastType
1225    case lt of
1226        BTFunction True _ _ _ -> return $ text "&" <> parens r
1227        _ -> return $ text "&" <> parens r
1228ref2C (TypeCast t'@(Identifier i _) expr) = do
1229    lt <- expr2C expr >> gets lastType
1230    case (map toLower i, lt) of
1231        ("pchar", BTString) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "_pchar" $ BTPointerTo BTChar))
1232        ("pchar", BTAString) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "_pcharA" $ BTPointerTo BTChar))
1233        ("shortstring", BTAString) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "astr2str" $ BTString))
1234        ("shortstring", BTPointerTo _) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "pchar2str" $ BTString))
1235        ("ansistring", BTPointerTo _) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "pchar2astr" $ BTAString))
1236        ("ansistring", BTString) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "str2astr" $ BTAString))
1237        (a, _) -> do
1238            e <- expr2C expr
1239            t <- id2C IOLookup t'
1240            return . parens $ parens t <> e
1241ref2C (RefExpression expr) = expr2C expr
1242
1243
1244op2C :: String -> String
1245op2C "or" = "|"
1246op2C "and" = "&"
1247op2C "not" = "~"
1248op2C "xor" = "^"
1249op2C "div" = "/"
1250op2C "mod" = "%"
1251op2C "shl" = "<<"
1252op2C "shr" = ">>"
1253op2C "<>" = "!="
1254op2C "=" = "=="
1255op2C "/" = "/(float)"
1256op2C a = a
1257
1258