1 {-# LANGUAGE ScopedTypeVariables #-}

     2 module Pas2C where

     3 

     4 import Text.PrettyPrint.HughesPJ

     5 import Data.Maybe

     6 import Data.Char

     7 import Text.Parsec.Prim hiding (State)

     8 import Control.Monad.State

     9 import System.IO

    10 import System.Directory

    11 import Control.Monad.IO.Class

    12 import PascalPreprocessor

    13 import Control.Exception

    14 import System.IO.Error

    15 import qualified Data.Map as Map

    16 import qualified Data.Set as Set

    17 import Data.List (find)

    18 import Numeric

    19 

    20 import PascalParser(pascalUnit)

    21 import PascalUnitSyntaxTree

    22 

    23 

    24 data InsertOption =

    25     IOInsert

    26     | IOInsertWithType Doc

    27     | IOLookup

    28     | IOLookupLast

    29     | IOLookupFunction Int

    30     | IODeferred

    31 

    32 data Record = Record

    33     {

    34         lcaseId :: String,

    35         baseType :: BaseType,

    36         typeDecl :: Doc

    37     }

    38     deriving Show

    39 type Records = Map.Map String [Record]

    40 data RenderState = RenderState

    41     {

    42         currentScope :: Records,

    43         lastIdentifier :: String,

    44         lastType :: BaseType,

    45         lastIdTypeDecl :: Doc,

    46         stringConsts :: [(String, String)],

    47         uniqCounter :: Int,

    48         toMangle :: Set.Set String,

    49         currentUnit :: String,

    50         currentFunctionResult :: String,

    51         namespaces :: Map.Map String Records

    52     }

    53 

    54 rec2Records = map (\(a, b) -> Record a b empty)

    55 

    56 emptyState = RenderState Map.empty "" BTUnknown empty [] 0 Set.empty "" ""

    57 

    58 getUniq :: State RenderState Int

    59 getUniq = do

    60     i <- gets uniqCounter

    61     modify(\s -> s{uniqCounter = uniqCounter s + 1})

    62     return i

    63 

    64 addStringConst :: String -> State RenderState Doc

    65 addStringConst str = do

    66     strs <- gets stringConsts

    67     let a = find ((==) str . snd) strs

    68     if isJust a then

    69         do

    70         modify (\s -> s{lastType = BTString})

    71         return . text . fst . fromJust $ a

    72     else

    73         do

    74         i <- getUniq

    75         let sn = "__str" ++ show i

    76         modify (\s -> s{lastType = BTString, stringConsts = (sn, str) : strs})

    77         return $ text sn

    78 

    79 escapeStr :: String -> String

    80 escapeStr = foldr escapeChar []

    81 

    82 escapeChar :: Char -> ShowS

    83 escapeChar '"' s = "\\\"" ++ s

    84 escapeChar '\\' s = "\\\\" ++ s

    85 escapeChar a s = a : s

    86 

    87 strInit :: String -> Doc

    88 strInit a = text "STRINIT" <> parens (doubleQuotes (text $ escapeStr a))

    89 

    90 renderStringConsts :: State RenderState Doc

    91 renderStringConsts = liftM (vcat . map (\(a, b) -> text "static const string255" <+> (text a) <+> text "=" <+> strInit b <> semi))

    92     $ gets stringConsts

    93 

    94 docToLower :: Doc -> Doc

    95 docToLower = text . map toLower . render

    96 

    97 pas2C :: String -> String -> String -> String -> IO ()

    98 pas2C fn inputPath outputPath alternateInputPath = do

    99     s <- flip execStateT initState $ f fn

   100     renderCFiles s outputPath

   101     where

   102     printLn = liftIO . hPutStrLn stdout

   103     print = liftIO . hPutStr stdout

   104     initState = Map.empty

   105     f :: String -> StateT (Map.Map String PascalUnit) IO ()

   106     f fileName = do

   107         processed <- gets $ Map.member fileName

   108         unless processed $ do

   109             print ("Preprocessing '" ++ fileName ++ ".pas'... ")

   110             fc' <- liftIO

   111                 $ tryJust (guard . isDoesNotExistError)

   112                 $ preprocess inputPath alternateInputPath (fileName ++ ".pas")

   113             case fc' of

   114                 (Left a) -> do

   115                     modify (Map.insert fileName (System []))

   116                     printLn "doesn't exist"

   117                 (Right fc) -> do

   118                     print "ok, parsing... "

   119                     let ptree = parse pascalUnit fileName fc

   120                     case ptree of

   121                          (Left a) -> do

   122                             liftIO $ writeFile (outputPath ++ "preprocess.out") fc

   123                             printLn $ show a ++ "\nsee preprocess.out for preprocessed source"

   124                             fail "stop"

   125                          (Right a) -> do

   126                             printLn "ok"

   127                             modify (Map.insert fileName a)

   128                             mapM_ f (usesFiles a)

   129 

   130 

   131 renderCFiles :: Map.Map String PascalUnit -> String -> IO ()

   132 renderCFiles units outputPath = do

   133     let u = Map.toList units

   134     let nss = Map.map (toNamespace nss) units

   135     --hPutStrLn stderr $ "Units: " ++ (show . Map.keys . Map.filter (not . Map.null) $ nss)

   136     --writeFile "pas2c.log" $ unlines . map (\t -> show (fst t) ++ "\n" ++ (unlines . map ((:) '\t' . show) . snd $ t)) . Map.toList $ nss

   137     mapM_ (toCFiles outputPath nss) u

   138     where

   139     toNamespace :: Map.Map String Records -> PascalUnit -> Records

   140     toNamespace nss (System tvs) =

   141         currentScope $ execState f (emptyState nss)

   142         where

   143         f = do

   144             checkDuplicateFunDecls tvs

   145             mapM_ (tvar2C True False True False) tvs

   146     toNamespace nss (Redo tvs) = -- functions that are re-implemented, add prefix to all of them

   147         currentScope $ execState f (emptyState nss){currentUnit = "fpcrtl_"}

   148         where

   149         f = do

   150             checkDuplicateFunDecls tvs

   151             mapM_ (tvar2C True False True False) tvs

   152     toNamespace _ (Program {}) = Map.empty

   153     toNamespace nss (Unit (Identifier i _) interface _ _ _) =

   154         currentScope $ execState (interface2C interface True) (emptyState nss){currentUnit = map toLower i ++ "_"}

   155 

   156 

   157 withState' :: (RenderState -> RenderState) -> State RenderState a -> State RenderState a

   158 withState' f sf = do

   159     st <- liftM f get

   160     let (a, s) = runState sf st

   161     modify(\st -> st{

   162         lastType = lastType s

   163         , uniqCounter = uniqCounter s

   164         , stringConsts = stringConsts s

   165         })

   166     return a

   167 

   168 withLastIdNamespace f = do

   169     li <- gets lastIdentifier

   170     nss <- gets namespaces

   171     withState' (\st -> st{currentScope = fromMaybe Map.empty $ Map.lookup li (namespaces st)}) f

   172 

   173 withRecordNamespace :: String -> [Record] -> State RenderState Doc -> State RenderState Doc

   174 withRecordNamespace _ [] = error "withRecordNamespace: empty record"

   175 withRecordNamespace prefix recs = withState' f

   176     where

   177         f st = st{currentScope = Map.unionWith un records (currentScope st), currentUnit = ""}

   178         records = Map.fromList $ map (\(Record a b d) -> (map toLower a, [Record (prefix ++ a) b d])) recs

   179         un [a] b = a : b

   180 

   181 toCFiles :: String -> Map.Map String Records -> (String, PascalUnit) -> IO ()

   182 toCFiles _ _ (_, System _) = return ()

   183 toCFiles _ _ (_, Redo _) = return ()

   184 toCFiles outputPath ns p@(fn, pu) = do

   185     hPutStrLn stdout $ "Rendering '" ++ fn ++ "'..."

   186     toCFiles' p

   187     where

   188     toCFiles' (fn, p@(Program {})) = writeFile (outputPath ++ fn ++ ".c") $ "#include \"fpcrtl.h\"\n" ++ (render2C initialState . pascal2C) p

   189     toCFiles' (fn, (Unit unitId@(Identifier i _) interface implementation _ _)) = do

   190         let (a, s) = runState (id2C IOInsert (setBaseType BTUnit unitId) >> interface2C interface True) initialState{currentUnit = map toLower i ++ "_"}

   191             (a', s') = runState (id2C IOInsert (setBaseType BTUnit unitId) >> interface2C interface False) initialState{currentUnit = map toLower i ++ "_"}

   192         writeFile (outputPath ++ fn ++ ".h") $ "#pragma once\n\n#include \"pas2c.h\"\n\n" ++ (render (a $+$ text ""))

   193         writeFile (outputPath ++ fn ++ ".c") $ "#include \"fpcrtl.h\"\n\n#include \"" ++ fn ++ ".h\"\n" ++ render (a' $+$ text "") ++ (render2C s . implementation2C) implementation

   194     initialState = emptyState ns

   195 

   196     render2C :: RenderState -> State RenderState Doc -> String

   197     render2C a = render . ($+$ empty) . flip evalState a

   198 

   199 

   200 usesFiles :: PascalUnit -> [String]

   201 usesFiles (Program _ (Implementation uses _) _) = ["pas2cSystem", "pas2cRedo"] ++ uses2List uses

   202 usesFiles (Unit _ (Interface uses1 _) (Implementation uses2 _) _ _) = ["pas2cSystem", "pas2cRedo"] ++ uses2List uses1 ++ uses2List uses2

   203 usesFiles (System {}) = []

   204 usesFiles (Redo {}) = []

   205 

   206 pascal2C :: PascalUnit -> State RenderState Doc

   207 pascal2C (Unit _ interface implementation init fin) =

   208     liftM2 ($+$) (interface2C interface True) (implementation2C implementation)

   209 

   210 pascal2C (Program _ implementation mainFunction) = do

   211     impl <- implementation2C implementation

   212     [main] <- tvar2C True False True True (FunctionDeclaration (Identifier "main" BTInt) False (SimpleType $ Identifier "int" BTInt) [VarDeclaration False False ([Identifier "argc" BTInt], SimpleType (Identifier "Integer" BTInt)) Nothing, VarDeclaration False False ([Identifier "argv" BTUnknown], SimpleType (Identifier "PPChar" BTUnknown)) Nothing] (Just (TypesAndVars [], mainFunction)))

   213     return $ impl $+$ main

   214 

   215 

   216 -- the second bool indicates whether do normal interface translation or generate variable declarations

   217 -- that will be inserted into implementation files

   218 interface2C :: Interface -> Bool -> State RenderState Doc

   219 interface2C (Interface uses tvars) True = do

   220     u <- uses2C uses

   221     tv <- typesAndVars2C True True True tvars

   222     r <- renderStringConsts

   223     return (u $+$ r $+$ tv)

   224 interface2C (Interface uses tvars) False = do

   225     u <- uses2C uses

   226     tv <- typesAndVars2C True False False tvars

   227     r <- renderStringConsts

   228     return tv

   229 

   230 implementation2C :: Implementation -> State RenderState Doc

   231 implementation2C (Implementation uses tvars) = do

   232     u <- uses2C uses

   233     tv <- typesAndVars2C True False True tvars

   234     r <- renderStringConsts

   235     return (u $+$ r $+$ tv)

   236 

   237 checkDuplicateFunDecls :: [TypeVarDeclaration] -> State RenderState ()

   238 checkDuplicateFunDecls tvs =

   239     modify $ \s -> s{toMangle = Map.keysSet . Map.filter (> 1) . foldr ins initMap $ tvs}

   240     where

   241         initMap = Map.empty

   242         --initMap = Map.fromList [("reset", 2)]

   243         ins (FunctionDeclaration (Identifier i _) _ _ _ _) m = Map.insertWith (+) (map toLower i) 1 m

   244         ins _ m = m

   245 

   246 -- the second bool indicates whether declare variable as extern or not

   247 -- the third bool indicates whether include types or not

   248 

   249 typesAndVars2C :: Bool -> Bool -> Bool -> TypesAndVars -> State RenderState Doc

   250 typesAndVars2C b externVar includeType(TypesAndVars ts) = do

   251     checkDuplicateFunDecls ts

   252     liftM (vcat . map (<> semi) . concat) $ mapM (tvar2C b externVar includeType False) ts

   253 

   254 setBaseType :: BaseType -> Identifier -> Identifier

   255 setBaseType bt (Identifier i _) = Identifier i bt

   256 

   257 uses2C :: Uses -> State RenderState Doc

   258 uses2C uses@(Uses unitIds) = do

   259 

   260     mapM_ injectNamespace (Identifier "pas2cSystem" undefined : unitIds)

   261     mapM_ injectNamespace (Identifier "pas2cRedo" undefined : unitIds)

   262     mapM_ (id2C IOInsert . setBaseType BTUnit) unitIds

   263     return $ vcat . map (\i -> text $ "#include \"" ++ i ++ ".h\"") $ uses2List uses

   264     where

   265     injectNamespace (Identifier i _) = do

   266         getNS <- gets (flip Map.lookup . namespaces)

   267         modify (\s -> s{currentScope = Map.unionWith (++) (fromMaybe Map.empty (getNS i)) $ currentScope s})

   268 

   269 uses2List :: Uses -> [String]

   270 uses2List (Uses ids) = map (\(Identifier i _) -> i) ids

   271 

   272 

   273 setLastIdValues vv = (\s -> s{lastType = baseType vv, lastIdentifier = lcaseId vv, lastIdTypeDecl = typeDecl vv})

   274 

   275 id2C :: InsertOption -> Identifier -> State RenderState Doc

   276 id2C IOInsert i = id2C (IOInsertWithType empty) i

   277 id2C (IOInsertWithType d) (Identifier i t) = do

   278     ns <- gets currentScope

   279     tom <- gets (Set.member n . toMangle)

   280     cu <- gets currentUnit

   281     let (i', t') = case (t, tom) of

   282             (BTFunction _ p _, True) -> (cu ++ i ++ ('_' : show p), t)

   283             (BTFunction _ _ _, _) -> (cu ++ i, t)

   284             (BTVarParam t', _) -> ('(' : '*' : i ++ ")" , t')

   285             _ -> (i, t)

   286     modify (\s -> s{currentScope = Map.insertWith (++) n [Record i' t' d] (currentScope s), lastIdentifier = n})

   287     return $ text i'

   288     where

   289         n = map toLower i

   290 

   291 id2C IOLookup i = id2CLookup head i

   292 id2C IOLookupLast i = id2CLookup last i

   293 id2C (IOLookupFunction params) (Identifier i t) = do

   294     let i' = map toLower i

   295     v <- gets $ Map.lookup i' . currentScope

   296     lt <- gets lastType

   297     if isNothing v then

   298         error $ "Not defined: '" ++ i' ++ "'\n" ++ show lt ++ "\nwith num of params = " ++ show params ++ "\n" ++ show v

   299         else

   300         let vv = fromMaybe (head $ fromJust v) . find checkParam $ fromJust v in

   301             modify (setLastIdValues vv) >> (return . text . lcaseId $ vv)

   302     where

   303         checkParam (Record _ (BTFunction _ p _) _) = p == params

   304         checkParam _ = False

   305 id2C IODeferred (Identifier i t) = do

   306     let i' = map toLower i

   307     v <- gets $ Map.lookup i' . currentScope

   308     if (isNothing v) then

   309         modify (\s -> s{lastType = BTUnknown, lastIdentifier = i}) >> return (text i)

   310         else

   311         let vv = head $ fromJust v in modify (setLastIdValues vv) >> (return . text . lcaseId $ vv)

   312 

   313 id2CLookup :: ([Record] -> Record) -> Identifier -> State RenderState Doc

   314 id2CLookup f (Identifier i t) = do

   315     let i' = map toLower i

   316     v <- gets $ Map.lookup i' . currentScope

   317     lt <- gets lastType

   318     if isNothing v then

   319         error $ "Not defined: '" ++ i' ++ "'\n" ++ show lt

   320         else

   321         let vv = f $ fromJust v in modify (setLastIdValues vv) >> (return . text . lcaseId $ vv)

   322 

   323 

   324 id2CTyped :: TypeDecl -> Identifier -> State RenderState Doc

   325 id2CTyped = id2CTyped2 Nothing

   326 

   327 id2CTyped2 :: Maybe Doc -> TypeDecl -> Identifier -> State RenderState Doc

   328 id2CTyped2 md t (Identifier i _) = do

   329     tb <- resolveType t

   330     case (t, tb) of

   331         (_, BTUnknown) -> do

   332             error $ "id2CTyped: type BTUnknown for " ++ show i ++ "\ntype: " ++ show t

   333         (SimpleType {}, BTRecord _ r) -> do

   334             ts <- type2C t

   335             id2C (IOInsertWithType $ ts empty) (Identifier i (BTRecord (render $ ts empty) r))

   336         (_, BTRecord _ r) -> do

   337             ts <- type2C t

   338             id2C (IOInsertWithType $ ts empty) (Identifier i (BTRecord i r))

   339         _ -> case md of

   340                 Nothing -> id2C IOInsert (Identifier i tb)

   341                 Just ts -> id2C (IOInsertWithType ts) (Identifier i tb)

   342 

   343 

   344 resolveType :: TypeDecl -> State RenderState BaseType

   345 resolveType st@(SimpleType (Identifier i _)) = do

   346     let i' = map toLower i

   347     v <- gets $ Map.lookup i' . currentScope

   348     if isJust v then return . baseType . head $ fromJust v else return $ f i'

   349     where

   350     f "integer" = BTInt

   351     f "pointer" = BTPointerTo BTVoid

   352     f "boolean" = BTBool

   353     f "float" = BTFloat

   354     f "char" = BTChar

   355     f "string" = BTString

   356     f _ = error $ "Unknown system type: " ++ show st

   357 resolveType (PointerTo (SimpleType (Identifier i _))) = return . BTPointerTo $ BTUnresolved (map toLower i)

   358 resolveType (PointerTo t) = liftM BTPointerTo $ resolveType t

   359 resolveType (RecordType tv mtvs) = do

   360     tvs <- mapM f (concat $ tv : fromMaybe [] mtvs)

   361     return . BTRecord "" . concat $ tvs

   362     where

   363         f :: TypeVarDeclaration -> State RenderState [(String, BaseType)]

   364         f (VarDeclaration _ _ (ids, td) _) = mapM (\(Identifier i _) -> liftM ((,) i) $ resolveType td) ids

   365 resolveType (ArrayDecl (Just i) t) = do

   366     t' <- resolveType t

   367     return $ BTArray i BTInt t'

   368 resolveType (ArrayDecl Nothing t) = liftM (BTArray RangeInfinite BTInt) $ resolveType t

   369 resolveType (FunctionType t a) = liftM (BTFunction False (length a)) $ resolveType t

   370 resolveType (DeriveType (InitHexNumber _)) = return BTInt

   371 resolveType (DeriveType (InitNumber _)) = return BTInt

   372 resolveType (DeriveType (InitFloat _)) = return BTFloat

   373 resolveType (DeriveType (InitString _)) = return BTString

   374 resolveType (DeriveType (InitBinOp {})) = return BTInt

   375 resolveType (DeriveType (InitPrefixOp _ e)) = initExpr2C e >> gets lastType

   376 resolveType (DeriveType (BuiltInFunction{})) = return BTInt

   377 resolveType (DeriveType (InitReference (Identifier{}))) = return BTBool -- TODO: derive from actual type

   378 resolveType (DeriveType _) = return BTUnknown

   379 resolveType (String _) = return BTString

   380 resolveType VoidType = return BTVoid

   381 resolveType (Sequence ids) = return $ BTEnum $ map (\(Identifier i _) -> map toLower i) ids

   382 resolveType (RangeType _) = return $ BTVoid

   383 resolveType (Set t) = liftM BTSet $ resolveType t

   384 resolveType (VarParamType t) = liftM BTVarParam $ resolveType t

   385 

   386 

   387 resolve :: String -> BaseType -> State RenderState BaseType

   388 resolve s (BTUnresolved t) = do

   389     v <- gets $ Map.lookup t . currentScope

   390     if isJust v then

   391         resolve s . baseType . head . fromJust $ v

   392         else

   393         error $ "Unknown type " ++ show t ++ "\n" ++ s

   394 resolve _ t = return t

   395 

   396 fromPointer :: String -> BaseType -> State RenderState BaseType

   397 fromPointer s (BTPointerTo t) = resolve s t

   398 fromPointer s t = do

   399     error $ "Dereferencing from non-pointer type " ++ show t ++ "\n" ++ s

   400 

   401 

   402 functionParams2C params = liftM (hcat . punctuate comma . concat) $ mapM (tvar2C False False True True) params

   403 

   404 numberOfDeclarations :: [TypeVarDeclaration] -> Int

   405 numberOfDeclarations = sum . map cnt

   406     where

   407         cnt (VarDeclaration _ _ (ids, _) _) = length ids

   408         cnt _ = 1

   409 

   410 hasPassByReference :: [TypeVarDeclaration] -> Bool

   411 hasPassByReference = or . map isVar

   412     where

   413         isVar (VarDeclaration v _ (_, _) _) = v

   414         isVar _ = error $ "hasPassByReference called not on function parameters"

   415 

   416 toIsVarList :: [TypeVarDeclaration] -> [Bool]

   417 toIsVarList = concatMap isVar

   418     where

   419         isVar (VarDeclaration v _ (p, _) _) = replicate (length p) v

   420         isVar _ = error $ "toIsVarList called not on function parameters"

   421 

   422 

   423 funWithVarsToDefine :: String -> [TypeVarDeclaration] -> Doc

   424 funWithVarsToDefine n params = text "#define" <+> text n <> parens abc <+> text (n ++ "__vars") <> parens cparams

   425     where

   426         abc = hcat . punctuate comma . map (char . fst) $ ps

   427         cparams = hcat . punctuate comma . map (\(c, v) -> if v then char '&' <> parens (char c) else char c) $ ps

   428         ps = zip ['a'..] (toIsVarList params)

   429 

   430 fun2C :: Bool -> String -> TypeVarDeclaration -> State RenderState [Doc]

   431 fun2C _ _ (FunctionDeclaration name inline returnType params Nothing) = do

   432     t <- type2C returnType

   433     t'<- gets lastType

   434     p <- withState' id $ functionParams2C params

   435     n <- liftM render . id2C IOInsert $ setBaseType (BTFunction hasVars (numberOfDeclarations params) t') name

   436     let decor = if inline then text "inline" else empty

   437     if hasVars then

   438         return [funWithVarsToDefine n params $+$ decor <+> t empty <+> text (n ++ "__vars") <> parens p]

   439         else

   440         return [decor <+> t empty <+> text n <> parens p]

   441     where

   442         hasVars = hasPassByReference params

   443 

   444 

   445 fun2C True rv (FunctionDeclaration name@(Identifier i _) inline returnType params (Just (tvars, phrase))) = do

   446     let res = docToLower $ text rv <> text "_result"

   447     t <- type2C returnType

   448     t'<- gets lastType

   449 

   450     notDeclared <- liftM isNothing . gets $ Map.lookup (map toLower i) . currentScope

   451 

   452     n <- liftM render . id2C IOInsert $ setBaseType (BTFunction hasVars (numberOfDeclarations params) t') name

   453 

   454     let isVoid = case returnType of

   455             VoidType -> True

   456             _ -> False

   457 

   458     (p, ph) <- withState' (\st -> st{currentScope = Map.insertWith un (map toLower rv) [Record (render res) t' empty] $ currentScope st

   459             , currentFunctionResult = if isVoid then [] else render res}) $ do

   460         p <- functionParams2C params

   461         ph <- liftM2 ($+$) (typesAndVars2C False False True tvars) (phrase2C' phrase)

   462         return (p, ph)

   463 

   464     let phrasesBlock = if isVoid then ph else t empty <+> res <> semi $+$ ph $+$ text "return" <+> res <> semi

   465     let define = if hasVars then text "#ifndef" <+> text n $+$ funWithVarsToDefine n params $+$ text "#endif" else empty

   466     let decor = if inline then text "inline" else empty

   467     return [

   468         define

   469         $+$

   470         --(if notDeclared && hasVars then funWithVarsToDefine n params else empty) $+$

   471         decor <+> t empty <+> text (if hasVars then n ++ "__vars" else n) <> parens p

   472         $+$

   473         text "{"

   474         $+$

   475         nest 4 phrasesBlock

   476         $+$

   477         text "}"]

   478     where

   479     phrase2C' (Phrases p) = liftM vcat $ mapM phrase2C p

   480     phrase2C' p = phrase2C p

   481     un [a] b = a : b

   482     hasVars = hasPassByReference params

   483 

   484 fun2C False _ (FunctionDeclaration (Identifier name _) _ _ _ _) = error $ "nested functions not allowed: " ++ name

   485 fun2C _ tv _ = error $ "fun2C: I don't render " ++ show tv

   486 

   487 -- the second bool indicates whether declare variable as extern or not

   488 -- the third bool indicates whether include types or not

   489 -- the fourth bool indicates whether ignore initialization or not (basically for dynamic arrays since we cannot do initialization in function params)

   490 tvar2C :: Bool -> Bool -> Bool -> Bool -> TypeVarDeclaration -> State RenderState [Doc]

   491 tvar2C b _ includeType _ f@(FunctionDeclaration (Identifier name _) _ _ _ _) = do

   492     t <- fun2C b name f

   493     if includeType then return t else return []

   494 tvar2C _ _ includeType _ td@(TypeDeclaration i' t) = do

   495     i <- id2CTyped t i'

   496     tp <- type2C t

   497     return $ if includeType then [text "typedef" <+> tp i] else []

   498 

   499 tvar2C _ _ _ _ (VarDeclaration True _ (ids, t) Nothing) = do

   500     t' <- liftM ((empty <+>) . ) $ type2C t

   501     liftM (map(\i -> t' i)) $ mapM (id2CTyped2 (Just $ t' empty) (VarParamType t)) ids

   502 

   503 tvar2C _ externVar includeType ignoreInit (VarDeclaration _ isConst (ids, t) mInitExpr) = do

   504     t' <- liftM (((if isConst then text "static const" else if externVar 

   505                                                                 then text "extern"

   506                                                                 else empty)

   507                    <+>) . ) $ type2C t

   508     ie <- initExpr mInitExpr

   509     lt <- gets lastType

   510     case (isConst, lt, ids, mInitExpr) of

   511          (True, BTInt, [i], Just _) -> do

   512              i' <- id2CTyped t i

   513              return $ if includeType then [text "enum" <> braces (i' <+> ie)] else []

   514          (True, BTFloat, [i], Just e) -> do

   515              i' <- id2CTyped t i

   516              ie <- initExpr2C e

   517              return $ if includeType then [text "#define" <+> i' <+> parens ie <> text "\n"] else []

   518          (_, BTFunction{}, _, Nothing) -> liftM (map(\i -> t' i)) $ mapM (id2CTyped t) ids

   519          (_, BTArray r _ _, [i], _) -> do

   520             i' <- id2CTyped t i

   521             ie' <- return $ case (r, mInitExpr, ignoreInit) of

   522                 (RangeInfinite, Nothing, False) -> text "= NULL" -- force dynamic array to be initialized as NULL if not initialized at all

   523                 (_, _, _) -> ie

   524             result <- liftM (map(\i -> varDeclDecision isConst includeType (t' i) ie')) $ mapM (id2CTyped t) ids           

   525             case (r, ignoreInit) of

   526                 (RangeInfinite, False) -> 

   527                     -- if the array is dynamic, add dimension info to it

   528                     return $ [dimDecl] ++ result

   529                     where 

   530                         arrayDimStr = show $ arrayDimension t

   531                         arrayDimInitExp = text ("={" ++ ".dim = " ++ arrayDimStr ++ ", .a = {0, 0, 0, 0}}")

   532                         dimDecl = varDeclDecision isConst includeType (text "fpcrtl_dimension_t" <+>  i' <> text "_dimension_info") arrayDimInitExp

   533                     

   534                 (_, _) -> return result

   535             

   536          _ -> liftM (map(\i -> varDeclDecision isConst includeType (t' i) ie)) $ mapM (id2CTyped2 (Just $ t' empty) t) ids

   537     where

   538     initExpr Nothing = return $ empty

   539     initExpr (Just e) = liftM (text "=" <+>) (initExpr2C e)

   540     varDeclDecision True True varStr expStr = varStr <+> expStr

   541     varDeclDecision False True varStr expStr = if externVar then varStr else varStr <+> expStr

   542     varDeclDecision False False varStr expStr = varStr <+> expStr

   543     varDeclDecision True False varStr expStr = empty

   544     arrayDimension a = case a of

   545         ArrayDecl Nothing t -> let a = arrayDimension t in if a > 3 then error "Dynamic array with dimension > 4 is not supported." else 1 + arrayDimension t

   546         ArrayDecl _ _ -> error "Mixed dynamic array and static array are not supported."

   547         _ -> 0

   548 

   549 tvar2C f _ _ _ (OperatorDeclaration op (Identifier i _) inline ret params body) = do

   550     r <- op2CTyped op (extractTypes params)

   551     fun2C f i (FunctionDeclaration r inline ret params body)

   552 

   553 

   554 op2CTyped :: String -> [TypeDecl] -> State RenderState Identifier

   555 op2CTyped op t = do

   556     t' <- liftM (render . hcat . punctuate (char '_') . map (\t -> t empty)) $ mapM type2C t

   557     bt <- gets lastType

   558     return $ Identifier (t' ++ "_op_" ++ opStr) bt

   559     where

   560     opStr = case op of

   561                     "+" -> "add"

   562                     "-" -> "sub"

   563                     "*" -> "mul"

   564                     "/" -> "div"

   565                     "/(float)" -> "div"

   566                     "=" -> "eq"

   567                     "<" -> "lt"

   568                     ">" -> "gt"

   569                     "<>" -> "neq"

   570                     _ -> error $ "op2CTyped: unknown op '" ++ op ++ "'"

   571 

   572 extractTypes :: [TypeVarDeclaration] -> [TypeDecl]

   573 extractTypes = concatMap f

   574     where

   575         f (VarDeclaration _ _ (ids, t) _) = replicate (length ids) t

   576         f a = error $ "extractTypes: can't extract from " ++ show a

   577 

   578 initExpr2C, initExpr2C' :: InitExpression -> State RenderState Doc

   579 initExpr2C (InitArray values) = liftM (braces . vcat . punctuate comma) $ mapM initExpr2C values

   580 initExpr2C a = initExpr2C' a

   581 initExpr2C' InitNull = return $ text "NULL"

   582 initExpr2C' (InitAddress expr) = do

   583     ie <- initExpr2C' expr

   584     lt <- gets lastType

   585     case lt of

   586         BTFunction True _ _ -> return $ text "&" <> ie <> text "__vars"

   587         _ -> return $ text "&" <> ie

   588 initExpr2C' (InitPrefixOp op expr) = liftM (text (op2C op) <>) (initExpr2C' expr)

   589 initExpr2C' (InitBinOp op expr1 expr2) = do

   590     e1 <- initExpr2C' expr1

   591     e2 <- initExpr2C' expr2

   592     return $ parens $ e1 <+> text (op2C op) <+> e2

   593 initExpr2C' (InitNumber s) = return $ text s

   594 initExpr2C' (InitFloat s) = return $ text s

   595 initExpr2C' (InitHexNumber s) = return $ text "0x" <> (text . map toLower $ s)

   596 initExpr2C' (InitString [a]) = return . quotes $ text [a]

   597 initExpr2C' (InitString s) = return $ strInit s

   598 initExpr2C' (InitChar a) = return $ quotes $ text "\\x" <> text (showHex (read a) "")

   599 initExpr2C' (InitReference i) = id2C IOLookup i

   600 initExpr2C' (InitRecord fields) = do

   601     (fs :: [Doc]) <- mapM (\(Identifier a _, b) -> liftM (text "." <> text a <+> equals <+>) $ initExpr2C b) fields

   602     return $ lbrace $+$ (nest 4 . vcat . punctuate comma $ fs) $+$ rbrace

   603 initExpr2C' (InitArray [value]) = initExpr2C value

   604 initExpr2C' r@(InitRange (Range i@(Identifier i' _))) = do

   605     id2C IOLookup i

   606     t <- gets lastType

   607     case t of

   608          BTEnum s -> return . int $ length s

   609          BTInt -> case i' of

   610                        "byte" -> return $ int 256

   611                        _ -> error $ "InitRange identifier: " ++ i'

   612          _ -> error $ "InitRange: " ++ show r

   613 initExpr2C' (InitRange (RangeFromTo (InitNumber "0") r)) = initExpr2C $ BuiltInFunction "succ" [r]

   614 initExpr2C' (InitRange (RangeFromTo (InitChar "0") (InitChar r))) = initExpr2C $ BuiltInFunction "succ" [InitNumber r]

   615 initExpr2C' (InitRange a) = error $ show a --return $ text "<<range>>"

   616 initExpr2C' (InitSet []) = return $ text "0"

   617 initExpr2C' (InitSet a) = return $ text "<<set>>"

   618 initExpr2C' (BuiltInFunction "low" [InitReference e]) = return $

   619     case e of

   620          (Identifier "LongInt" _) -> int (-2^31)

   621          (Identifier "SmallInt" _) -> int (-2^15)

   622          _ -> error $ "BuiltInFunction 'low': " ++ show e

   623 initExpr2C' (BuiltInFunction "high" [e]) = do

   624     initExpr2C e

   625     t <- gets lastType

   626     case t of

   627          (BTArray i _ _) -> initExpr2C' $ BuiltInFunction "pred" [InitRange i]

   628          a -> error $ "BuiltInFunction 'high': " ++ show a

   629 initExpr2C' (BuiltInFunction "succ" [BuiltInFunction "pred" [e]]) = initExpr2C' e

   630 initExpr2C' (BuiltInFunction "pred" [BuiltInFunction "succ" [e]]) = initExpr2C' e

   631 initExpr2C' (BuiltInFunction "succ" [e]) = liftM (<> text " + 1") $ initExpr2C' e

   632 initExpr2C' (BuiltInFunction "pred" [e]) = liftM (<> text " - 1") $ initExpr2C' e

   633 initExpr2C' b@(BuiltInFunction _ _) = error $ show b

   634 initExpr2C' a = error $ "initExpr2C: don't know how to render " ++ show a

   635 

   636 

   637 range2C :: InitExpression -> State RenderState [Doc]

   638 range2C (InitString [a]) = return [quotes $ text [a]]

   639 range2C (InitRange (Range i)) = liftM (flip (:) []) $ id2C IOLookup i

   640 range2C (InitRange (RangeFromTo (InitString [a]) (InitString [b]))) = return $ map (\i -> quotes $ text [i]) [a..b]

   641 range2C a = liftM (flip (:) []) $ initExpr2C a

   642 

   643 baseType2C :: String -> BaseType -> Doc

   644 baseType2C _ BTFloat = text "float"

   645 baseType2C _ BTBool = text "bool"

   646 baseType2C _ BTString = text "string255"

   647 baseType2C s a = error $ "baseType2C: " ++ show a ++ "\n" ++ s

   648 

   649 type2C :: TypeDecl -> State RenderState (Doc -> Doc)

   650 type2C (SimpleType i) = liftM (\i a -> i <+> a) $ id2C IOLookup i

   651 type2C t = do

   652     r <- type2C' t

   653     rt <- resolveType t

   654     modify (\st -> st{lastType = rt})

   655     return r

   656     where

   657     type2C' VoidType = return (text "void" <+>)

   658     type2C' (String l) = return (text "string255" <+>)--return (text ("string" ++ show l) <+>)

   659     type2C' (PointerTo (SimpleType i)) = do

   660         i' <- id2C IODeferred i

   661         lt <- gets lastType

   662         case lt of

   663              BTRecord _ _ -> return $ \a -> text "struct __" <> i' <+> text "*" <+> a

   664              BTUnknown -> return $ \a -> text "struct __" <> i' <+> text "*" <+> a

   665              _ -> return $ \a -> i' <+> text "*" <+> a

   666     type2C' (PointerTo t) = liftM (\t a -> t (parens $ text "*" <> a)) $ type2C t

   667     type2C' (RecordType tvs union) = do

   668         t <- withState' f $ mapM (tvar2C False False True False) tvs

   669         u <- unions

   670         return $ \i -> text "struct __" <> i <+> lbrace $+$ nest 4 ((vcat . map (<> semi) . concat $ t) $$ u) $+$ rbrace <+> i

   671         where

   672             f s = s{currentUnit = ""}

   673             unions = case union of

   674                      Nothing -> return empty

   675                      Just a -> do

   676                          structs <- mapM struct2C a

   677                          return $ text "union" $+$ braces (nest 4 $ vcat structs) <> semi

   678             struct2C tvs = do

   679                 t <- withState' f $ mapM (tvar2C False False True False) tvs

   680                 return $ text "struct" $+$ braces (nest 4 (vcat . map (<> semi) . concat $ t)) <> semi

   681     type2C' (RangeType r) = return (text "int" <+>)

   682     type2C' (Sequence ids) = do

   683         is <- mapM (id2C IOInsert . setBaseType bt) ids

   684         return (text "enum" <+> (braces . vcat . punctuate comma . map (\(a, b) -> a <+> equals <+> text "0x" <> text (showHex b "")) $ zip is [0..]) <+>)

   685         where

   686             bt = BTEnum $ map (\(Identifier i _) -> map toLower i) ids

   687     type2C' (ArrayDecl Nothing t) = type2C (PointerTo t)

   688     type2C' (ArrayDecl (Just r) t) = do

   689         t' <- type2C t

   690         lt <- gets lastType

   691         ft <- case lt of

   692                 -- BTFunction {} -> type2C (PointerTo t)

   693                 _ -> return t'

   694         r' <- initExpr2C (InitRange r)

   695         return $ \i -> ft i <> brackets r'

   696     type2C' (Set t) = return (text "<<set>>" <+>)

   697     type2C' (FunctionType returnType params) = do

   698         t <- type2C returnType

   699         p <- withState' id $ functionParams2C params

   700         return (\i -> (t empty <> (parens $ text "*" <> i) <> parens p))

   701     type2C' (DeriveType (InitBinOp _ _ i)) = type2C' (DeriveType i)

   702     type2C' (DeriveType (InitPrefixOp _ i)) = type2C' (DeriveType i)

   703     type2C' (DeriveType (InitNumber _)) = return (text "int" <+>)

   704     type2C' (DeriveType (InitHexNumber _)) = return (text "int" <+>)

   705     type2C' (DeriveType (InitFloat _)) = return (text "float" <+>)

   706     type2C' (DeriveType (BuiltInFunction {})) = return (text "int" <+>)

   707     type2C' (DeriveType (InitString {})) = return (text "string255" <+>)

   708     type2C' (DeriveType r@(InitReference {})) = do

   709         initExpr2C r

   710         t <- gets lastType

   711         return (baseType2C (show r) t <+>)

   712     type2C' (DeriveType a) = error $ "Can't derive type from " ++ show a

   713 

   714 phrase2C :: Phrase -> State RenderState Doc

   715 phrase2C (Phrases p) = do

   716     ps <- mapM phrase2C p

   717     return $ text "{" $+$ (nest 4 . vcat $ ps) $+$ text "}"

   718 phrase2C (ProcCall f@(FunCall {}) []) = liftM (<> semi) $ ref2C f

   719 phrase2C (ProcCall ref []) = liftM (<> semi) $ ref2CF ref

   720 phrase2C (ProcCall ref params) = error $ "ProcCall"{-do

   721     r <- ref2C ref

   722     ps <- mapM expr2C params

   723     return $ r <> parens (hsep . punctuate (char ',') $ ps) <> semi -}

   724 phrase2C (IfThenElse (expr) phrase1 mphrase2) = do

   725     e <- expr2C expr

   726     p1 <- (phrase2C . wrapPhrase) phrase1

   727     el <- elsePart

   728     return $

   729         text "if" <> parens e $+$ p1 $+$ el

   730     where

   731     elsePart | isNothing mphrase2 = return $ empty

   732              | otherwise = liftM (text "else" $$) $ (phrase2C . wrapPhrase) (fromJust mphrase2)

   733 phrase2C (Assignment ref expr) = do

   734     r <- ref2C ref

   735     t <- gets lastType

   736     case (t, expr) of

   737         (BTFunction {}, (Reference r')) -> do

   738             e <- ref2C r'

   739             return $ r <+> text "=" <+> e <> semi

   740         (BTString, _) -> do

   741             e <- expr2C expr

   742             lt <- gets lastType

   743             case lt of

   744                 -- assume pointer to char for simplicity

   745                 BTPointerTo _ -> do

   746                     e <- expr2C $ Reference $ FunCall [Reference $ RefExpression expr] (SimpleReference (Identifier "pchar2str" BTUnknown))

   747                     return $ r <+> text "=" <+> e <> semi

   748                 BTString -> do

   749                     e <- expr2C expr

   750                     return $ r <+> text "=" <+> e <> semi

   751                 _ -> error $ "Assignment to string from " ++ show lt

   752         (BTArray _ _ _, _) -> do

   753             case expr of

   754                 Reference er -> do

   755                     exprRef <- ref2C er

   756                     exprT <- gets lastType

   757                     case exprT of

   758                         BTArray RangeInfinite _ _ ->

   759                             return $ text "FIXME: assign a dynamic array to an array"

   760                         BTArray _ _ _ -> phrase2C $

   761                                 ProcCall (FunCall

   762                                     [

   763                                     Reference $ ref

   764                                     , Reference $ RefExpression expr

   765                                     , Reference $ FunCall [expr] (SimpleReference (Identifier "sizeof" BTUnknown))

   766                                     ]

   767                                     (SimpleReference (Identifier "memcpy" BTUnknown))

   768                                     ) []

   769                         _ -> return $ text "FIXME: assign a non-specific value to an array"

   770 

   771                 _ -> return $ text "FIXME: dynamic array assignment 2"

   772         _ -> do

   773             e <- expr2C expr

   774             return $ r <+> text "=" <+> e <> semi

   775 phrase2C (WhileCycle expr phrase) = do

   776     e <- expr2C expr

   777     p <- phrase2C $ wrapPhrase phrase

   778     return $ text "while" <> parens e $$ p

   779 phrase2C (SwitchCase expr cases mphrase) = do

   780     e <- expr2C expr

   781     cs <- mapM case2C cases

   782     d <- dflt

   783     return $

   784         text "switch" <> parens e $+$ braces (nest 4 . vcat $ cs ++ d)

   785     where

   786     case2C :: ([InitExpression], Phrase) -> State RenderState Doc

   787     case2C (e, p) = do

   788         ies <- mapM range2C e

   789         ph <- phrase2C p

   790         return $

   791              vcat (map (\i -> text "case" <+> i <> colon) . concat $ ies) <> nest 4 (ph $+$ text "break;")

   792     dflt | isNothing mphrase = return [text "default: break;"] -- avoid compiler warning

   793          | otherwise = do

   794              ph <- mapM phrase2C $ fromJust mphrase

   795              return [text "default:" <+> nest 4 (vcat ph)]

   796 

   797 phrase2C wb@(WithBlock ref p) = do

   798     r <- ref2C ref

   799     t <- gets lastType

   800     case t of

   801         (BTRecord _ rs) -> withRecordNamespace (render r ++ ".") (rec2Records rs) $ phrase2C $ wrapPhrase p

   802         a -> do

   803             error $ "'with' block referencing non-record type " ++ show a ++ "\n" ++ show wb

   804 phrase2C (ForCycle i' e1' e2' p up) = do

   805     i <- id2C IOLookup i'

   806     iType <- gets lastIdTypeDecl

   807     e1 <- expr2C e1'

   808     e2 <- expr2C e2'

   809     let inc = if up then "inc" else "dec"

   810     let add = if up then "+ 1" else "- 1"

   811     let iEnd = i <> text "__end__"

   812     ph <- phrase2C . appendPhrase (BuiltInFunctionCall [Reference $ SimpleReference i'] (SimpleReference (Identifier inc BTUnknown))) $ wrapPhrase p

   813     return . braces $

   814         i <+> text "=" <+> e1 <> semi

   815         $$

   816         iType <+> iEnd <+> text "=" <+> e2 <> semi

   817         $$ 

   818         text "if" <+> (parens $ i <+> text "<=" <+> iEnd) <+> text "do" <+> ph <+>

   819         text "while" <> parens (i <+> text "!=" <+> iEnd <+> text add) <> semi

   820     where

   821         appendPhrase p (Phrases ps) = Phrases $ ps ++ [p]

   822 phrase2C (RepeatCycle e' p') = do

   823     e <- expr2C e'

   824     p <- phrase2C (Phrases p')

   825     return $ text "do" <+> p <+> text "while" <> parens (text "!" <> parens e) <> semi

   826 phrase2C NOP = return $ text ";"

   827 

   828 phrase2C (BuiltInFunctionCall [] (SimpleReference (Identifier "exit" BTUnknown))) = do

   829     f <- gets currentFunctionResult

   830     if null f then

   831         return $ text "return" <> semi

   832         else

   833         return $ text "return" <+> text f <> semi

   834 phrase2C (BuiltInFunctionCall [] (SimpleReference (Identifier "break" BTUnknown))) = return $ text "break" <> semi

   835 phrase2C (BuiltInFunctionCall [] (SimpleReference (Identifier "continue" BTUnknown))) = return $ text "continue" <> semi

   836 phrase2C (BuiltInFunctionCall [e] (SimpleReference (Identifier "exit" BTUnknown))) = liftM (\e -> text "return" <+> e <> semi) $ expr2C e

   837 phrase2C (BuiltInFunctionCall [e] (SimpleReference (Identifier "dec" BTUnknown))) = liftM (\e -> text "--" <> e <> semi) $ expr2C e

   838 phrase2C (BuiltInFunctionCall [e1, e2] (SimpleReference (Identifier "dec" BTUnknown))) = liftM2 (\a b -> a <> text " -= " <> b <> semi) (expr2C e1) (expr2C e2)

   839 phrase2C (BuiltInFunctionCall [e] (SimpleReference (Identifier "inc" BTUnknown))) = liftM (\e -> text "++" <> e <> semi) $ expr2C e

   840 phrase2C (BuiltInFunctionCall [e1, e2] (SimpleReference (Identifier "inc" BTUnknown))) = liftM2 (\a b -> a <+> text "+=" <+> b <> semi) (expr2C e1) (expr2C e2)

   841 phrase2C a = error $ "phrase2C: " ++ show a

   842 

   843 wrapPhrase p@(Phrases _) = p

   844 wrapPhrase p = Phrases [p]

   845 

   846 expr2C :: Expression -> State RenderState Doc

   847 expr2C (Expression s) = return $ text s

   848 expr2C b@(BinOp op expr1 expr2) = do

   849     e1 <- expr2C expr1

   850     t1 <- gets lastType

   851     e2 <- expr2C expr2

   852     t2 <- gets lastType

   853     case (op2C op, t1, t2) of

   854         ("+", BTString, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strconcat" (BTFunction False 2 BTString))

   855         ("+", BTString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strappend" (BTFunction False 2 BTString))

   856         ("+", BTChar, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strprepend" (BTFunction False 2 BTString))

   857         ("+", BTChar, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_chrconcat" (BTFunction False 2 BTString))

   858         ("==", BTString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcomparec" (BTFunction False 2 BTBool))

   859         ("==", BTString, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcompare" (BTFunction False 2 BTBool))

   860         ("!=", BTString, _) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strncompare" (BTFunction False 2 BTBool))

   861         ("&", BTBool, _) -> return $ parens e1 <+> text "&&" <+> parens e2

   862         ("|", BTBool, _) -> return $ parens e1 <+> text "||" <+> parens e2

   863         (_, BTRecord t1 _, BTRecord t2 _) -> do

   864             i <- op2CTyped op [SimpleType (Identifier t1 undefined), SimpleType (Identifier t2 undefined)]

   865             ref2C $ FunCall [expr1, expr2] (SimpleReference i)

   866         (_, BTRecord t1 _, BTInt) -> do

   867             -- aw, "LongInt" here is hwengine-specific hack

   868             i <- op2CTyped op [SimpleType (Identifier t1 undefined), SimpleType (Identifier "LongInt" undefined)]

   869             ref2C $ FunCall [expr1, expr2] (SimpleReference i)

   870         ("in", _, _) ->

   871             case expr2 of

   872                  SetExpression set -> do

   873                      ids <- mapM (id2C IOLookup) set

   874                      modify(\s -> s{lastType = BTBool})

   875                      return . parens . hcat . punctuate (text " || ") . map (\i -> parens $ e1 <+> text "==" <+> i) $ ids

   876                  _ -> error "'in' against not set expression"

   877         (o, _, _) | o `elem` boolOps -> do

   878                         modify(\s -> s{lastType = BTBool})

   879                         return $ parens e1 <+> text o <+> parens e2

   880                   | otherwise -> do

   881                         o' <- return $ case o of

   882                             "/(float)" -> text "/(float)" -- pascal returns real value

   883                             _ -> text o

   884                         e1' <- return $ case (o, t1, t2) of

   885                                 ("-", BTInt, BTInt) -> parens $ text "(int64_t)" <+> parens e1

   886                                 _ -> parens e1

   887                         e2' <- return $ case (o, t1, t2) of

   888                                 ("-", BTInt, BTInt) -> parens $ text "(int64_t)" <+> parens e2

   889                                 _ -> parens e2

   890                         return $ e1' <+> o' <+> e2'

   891     where

   892         boolOps = ["==", "!=", "<", ">", "<=", ">="]

   893 expr2C (NumberLiteral s) = do

   894     modify(\s -> s{lastType = BTInt})

   895     return $ text s

   896 expr2C (FloatLiteral s) = return $ text s

   897 expr2C (HexNumber s) = return $ text "0x" <> (text . map toLower $ s)

   898 {-expr2C (StringLiteral [a]) = do

   899     modify(\s -> s{lastType = BTChar})

   900     return . quotes . text $ escape a

   901     where

   902         escape '\'' = "\\\'"

   903         escape a = [a]-}

   904 expr2C (StringLiteral s) = addStringConst s

   905 expr2C (PCharLiteral s) = return . doubleQuotes $ text s

   906 expr2C (Reference ref) = ref2CF ref

   907 expr2C (PrefixOp op expr) = do

   908     e <- expr2C expr

   909     lt <- gets lastType

   910     case lt of

   911         BTRecord t _ -> do

   912             i <- op2CTyped op [SimpleType (Identifier t undefined)]

   913             ref2C $ FunCall [expr] (SimpleReference i)

   914         BTBool -> do

   915             o <- return $ case op of

   916                      "not" -> text "!"

   917                      _ -> text (op2C op)

   918             return $ o <> parens e

   919         _ -> return $ text (op2C op) <> parens e

   920 expr2C Null = return $ text "NULL"

   921 expr2C (CharCode a) = do

   922     modify(\s -> s{lastType = BTChar})

   923     return $ quotes $ text "\\x" <> text (showHex (read a) "")

   924 expr2C (HexCharCode a) = if length a <= 2 then return $ quotes $ text "\\x" <> text (map toLower a) else expr2C $ HexNumber a

   925 expr2C (SetExpression ids) = mapM (id2C IOLookup) ids >>= return . parens . hcat . punctuate (text " | ")

   926 

   927 expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "low" _))) = do

   928     e' <- liftM (map toLower . render) $ expr2C e

   929     lt <- gets lastType

   930     case lt of

   931          BTEnum a -> return $ int 0

   932          BTInt -> case e' of

   933                   "longint" -> return $ int (-2147483648)

   934          BTArray {} -> return $ int 0

   935          _ -> error $ "BuiltInFunCall 'low' from " ++ show e ++ "\ntype: " ++ show lt

   936 expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "high" _))) = do

   937     e' <- liftM (map toLower . render) $ expr2C e

   938     lt <- gets lastType

   939     case lt of

   940          BTEnum a -> return . int $ length a - 1

   941          BTInt -> case e' of

   942                   "longint" -> return $ int (2147483647)

   943          BTString -> return $ int 255

   944          BTArray (RangeFromTo _ n) _ _ -> initExpr2C n

   945          _ -> error $ "BuiltInFunCall 'high' from " ++ show e ++ "\ntype: " ++ show lt

   946 expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "ord" _))) = liftM parens $ expr2C e

   947 expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "succ" _))) = liftM (<> text " + 1") $ expr2C e

   948 expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "pred" _))) = liftM (<> text " - (int64_t)1") $ expr2C e

   949 expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "length" _))) = do

   950     e' <- expr2C e

   951     lt <- gets lastType

   952     modify (\s -> s{lastType = BTInt})

   953     case lt of

   954          BTString -> return $ text "fpcrtl_Length" <> parens e'

   955          BTArray RangeInfinite _ _ -> error $ "length() called on variable size array " ++ show e'

   956          BTArray (RangeFromTo _ n) _ _ -> initExpr2C (BuiltInFunction "succ" [n])

   957          _ -> error $ "length() called on " ++ show lt

   958 expr2C (BuiltInFunCall params ref) = do

   959     r <- ref2C ref

   960     t <- gets lastType

   961     ps <- mapM expr2C params

   962     case t of

   963         BTFunction _ _ t' -> do

   964             modify (\s -> s{lastType = t'})

   965         _ -> error $ "BuiltInFunCall lastType: " ++ show t

   966     return $

   967         r <> parens (hsep . punctuate (char ',') $ ps)

   968 expr2C a = error $ "Don't know how to render " ++ show a

   969 

   970 ref2CF :: Reference -> State RenderState Doc

   971 ref2CF (SimpleReference name) = do

   972     i <- id2C IOLookup name

   973     t <- gets lastType

   974     case t of

   975          BTFunction _ _ rt -> do

   976              modify(\s -> s{lastType = rt})

   977              return $ i <> parens empty --xymeng: removed parens

   978          _ -> return $ i

   979 ref2CF r@(RecordField (SimpleReference _) (SimpleReference _)) = do

   980     i <- ref2C r

   981     t <- gets lastType

   982     case t of

   983          BTFunction _ _ rt -> do

   984              modify(\s -> s{lastType = rt})

   985              return $ i <> parens empty

   986          _ -> return $ i

   987 ref2CF r = ref2C r

   988 

   989 ref2C :: Reference -> State RenderState Doc

   990 -- rewrite into proper form

   991 ref2C (RecordField ref1 (ArrayElement exprs ref2)) = ref2C $ ArrayElement exprs (RecordField ref1 ref2)

   992 ref2C (RecordField ref1 (Dereference ref2)) = ref2C $ Dereference (RecordField ref1 ref2)

   993 ref2C (RecordField ref1 (RecordField ref2 ref3)) = ref2C $ RecordField (RecordField ref1 ref2) ref3

   994 ref2C (RecordField ref1 (FunCall params ref2)) = ref2C $ FunCall params (RecordField ref1 ref2)

   995 ref2C (ArrayElement (a:b:xs) ref) = ref2C $ ArrayElement (b:xs) (ArrayElement [a] ref)

   996 -- conversion routines

   997 ref2C ae@(ArrayElement [expr] ref) = do

   998     e <- expr2C expr

   999     r <- ref2C ref

  1000     t <- gets lastType

  1001     case t of

  1002          (BTArray _ _ t') -> modify (\st -> st{lastType = t'})

  1003 --         (BTFunctionReturn _ (BTArray _ _ t')) -> modify (\st -> st{lastType = t'})

  1004 --         (BTFunctionReturn _ (BTString)) -> modify (\st -> st{lastType = BTChar})

  1005          (BTString) -> modify (\st -> st{lastType = BTChar})

  1006          (BTPointerTo t) -> do

  1007                 t'' <- fromPointer (show t) =<< gets lastType

  1008                 case t'' of

  1009                      BTChar -> modify (\st -> st{lastType = BTChar})

  1010                      a -> error $ "Getting element of " ++ show a ++ "\nReference: " ++ show ae

  1011          a -> error $ "Getting element of " ++ show a ++ "\nReference: " ++ show ae

  1012     case t of

  1013          BTString ->  return $ r <> text ".s" <> brackets e

  1014          _ -> return $ r <> brackets e

  1015 ref2C (SimpleReference name) = id2C IOLookup name

  1016 ref2C rf@(RecordField (Dereference ref1) ref2) = do

  1017     r1 <- ref2C ref1

  1018     t <- fromPointer (show ref1) =<< gets lastType

  1019     r2 <- case t of

  1020         BTRecord _ rs -> withRecordNamespace "" (rec2Records rs) $ ref2C ref2

  1021         BTUnit -> error "What??"

  1022         a -> error $ "dereferencing from " ++ show a ++ "\n" ++ show rf

  1023     return $

  1024         r1 <> text "->" <> r2

  1025 ref2C rf@(RecordField ref1 ref2) = do

  1026     r1 <- ref2C ref1

  1027     t <- gets lastType

  1028     case t of

  1029         BTRecord _ rs -> do

  1030             r2 <- withRecordNamespace "" (rec2Records rs) $ ref2C ref2

  1031             return $ r1 <> text "." <> r2

  1032         BTUnit -> withLastIdNamespace $ ref2C ref2

  1033         a -> error $ "dereferencing from " ++ show a ++ "\n" ++ show rf

  1034 ref2C d@(Dereference ref) = do

  1035     r <- ref2C ref

  1036     t <- fromPointer (show d) =<< gets lastType

  1037     modify (\st -> st{lastType = t})

  1038     return $ (parens $ text "*" <> r)

  1039 ref2C f@(FunCall params ref) = do

  1040     r <- fref2C ref

  1041     t <- gets lastType

  1042     case t of

  1043         BTFunction _ _ t' -> do

  1044             ps <- liftM (parens . hsep . punctuate (char ',')) $ mapM expr2C params

  1045             modify (\s -> s{lastType = t'})

  1046             return $ r <> ps

  1047         _ -> case (ref, params) of

  1048                   (SimpleReference i, [p]) -> ref2C $ TypeCast i p

  1049                   _ -> error $ "ref2C FunCall erroneous type cast detected: " ++ show f ++ "\nType detected: " ++ show t

  1050     where

  1051     fref2C (SimpleReference name) = id2C (IOLookupFunction $ length params) name

  1052     fref2C a = ref2C a

  1053 

  1054 ref2C (Address ref) = do

  1055     r <- ref2C ref

  1056     lt <- gets lastType

  1057     case lt of

  1058         BTFunction True _ _ -> return $ text "&" <> parens (r <> text "__vars")

  1059         _ -> return $ text "&" <> parens r

  1060 ref2C (TypeCast t'@(Identifier i _) expr) = do

  1061     lt <- expr2C expr >> gets lastType

  1062     case (map toLower i, lt) of

  1063         ("pchar", BTString) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "_pchar" $ BTPointerTo BTChar))

  1064         ("shortstring", BTPointerTo _) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "pchar2str" $ BTString))

  1065         (a, _) -> do

  1066             e <- expr2C expr

  1067             t <- id2C IOLookup t'

  1068             return . parens $ parens t <> e

  1069 ref2C (RefExpression expr) = expr2C expr

  1070 

  1071 

  1072 op2C :: String -> String

  1073 op2C "or" = "|"

  1074 op2C "and" = "&"

  1075 op2C "not" = "~"

  1076 op2C "xor" = "^"

  1077 op2C "div" = "/"

  1078 op2C "mod" = "%"

  1079 op2C "shl" = "<<"

  1080 op2C "shr" = ">>"

  1081 op2C "<>" = "!="

  1082 op2C "=" = "=="

  1083 op2C "/" = "/(float)"

  1084 op2C a = a

  1085