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 -> IO ()

    98 pas2C fn = do

    99     setCurrentDirectory "../hedgewars/"

   100     s <- flip execStateT initState $ f fn

   101     renderCFiles s

   102     where

   103     printLn = liftIO . hPutStrLn stdout

   104     print = liftIO . hPutStr stdout

   105     initState = Map.empty

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

   107     f fileName = do

   108         processed <- gets $ Map.member fileName

   109         unless processed $ do

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

   111             fc' <- liftIO

   112                 $ tryJust (guard . isDoesNotExistError)

   113                 $ preprocess (fileName ++ ".pas")

   114             case fc' of

   115                 (Left a) -> do

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

   117                     printLn "doesn't exist"

   118                 (Right fc) -> do

   119                     print "ok, parsing... "

   120                     let ptree = parse pascalUnit fileName fc

   121                     case ptree of

   122                          (Left a) -> do

   123                             liftIO $ writeFile "preprocess.out" fc

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

   125                             fail "stop"

   126                          (Right a) -> do

   127                             printLn "ok"

   128                             modify (Map.insert fileName a)

   129                             mapM_ f (usesFiles a)

   130 

   131 

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

   133 renderCFiles units = do

   134     let u = Map.toList units

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

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

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

   138     mapM_ (toCFiles nss) u

   139     where

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

   141     toNamespace nss (System tvs) =

   142         currentScope $ execState f (emptyState nss)

   143         where

   144         f = do

   145             checkDuplicateFunDecls tvs

   146             mapM_ (tvar2C True False True False) tvs

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

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

   149         where

   150         f = do

   151             checkDuplicateFunDecls tvs

   152             mapM_ (tvar2C True False True False) tvs

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

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

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

   156 

   157 

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

   159 withState' f sf = do

   160     st <- liftM f get

   161     let (a, s) = runState sf st

   162     modify(\st -> st{

   163         lastType = lastType s

   164         , uniqCounter = uniqCounter s

   165         , stringConsts = stringConsts s

   166         })

   167     return a

   168 

   169 withLastIdNamespace f = do

   170     li <- gets lastIdentifier

   171     nss <- gets namespaces

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

   173 

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

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

   176 withRecordNamespace prefix recs = withState' f

   177     where

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

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

   180         un [a] b = a : b

   181 

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

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

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

   185 toCFiles ns p@(fn, pu) = do

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

   187     toCFiles' p

   188     where

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

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

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

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

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

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

   195     initialState = emptyState ns

   196 

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

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

   199 

   200 

   201 usesFiles :: PascalUnit -> [String]

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

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

   204 usesFiles (System {}) = []

   205 usesFiles (Redo {}) = []

   206 

   207 pascal2C :: PascalUnit -> State RenderState Doc

   208 pascal2C (Unit _ interface implementation init fin) =

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

   210 

   211 pascal2C (Program _ implementation mainFunction) = do

   212     impl <- implementation2C implementation

   213     [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)))

   214     return $ impl $+$ main

   215 

   216 

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

   218 -- that will be inserted into implementation files

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

   220 interface2C (Interface uses tvars) True = do

   221     u <- uses2C uses

   222     tv <- typesAndVars2C True True True tvars

   223     r <- renderStringConsts

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

   225 interface2C (Interface uses tvars) False = do

   226     u <- uses2C uses

   227     tv <- typesAndVars2C True False False tvars

   228     r <- renderStringConsts

   229     return tv

   230 

   231 implementation2C :: Implementation -> State RenderState Doc

   232 implementation2C (Implementation uses tvars) = do

   233     u <- uses2C uses

   234     tv <- typesAndVars2C True False True tvars

   235     r <- renderStringConsts

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

   237 

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

   239 checkDuplicateFunDecls tvs =

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

   241     where

   242         initMap = Map.empty

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

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

   245         ins _ m = m

   246 

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

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

   249 

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

   251 typesAndVars2C b externVar includeType(TypesAndVars ts) = do

   252     checkDuplicateFunDecls ts

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

   254 

   255 setBaseType :: BaseType -> Identifier -> Identifier

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

   257 

   258 uses2C :: Uses -> State RenderState Doc

   259 uses2C uses@(Uses unitIds) = do

   260 

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

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

   263     mapM_ (id2C IOInsert . setBaseType BTUnit) unitIds

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

   265     where

   266     injectNamespace (Identifier i _) = do

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

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

   269 

   270 uses2List :: Uses -> [String]

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

   272 

   273 

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

   275 

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

   277 id2C IOInsert i = id2C (IOInsertWithType empty) i

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

   279     ns <- gets currentScope

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

   281     cu <- gets currentUnit

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

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

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

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

   286             _ -> (i, t)

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

   288     return $ text i'

   289     where

   290         n = map toLower i

   291 

   292 id2C IOLookup i = id2CLookup head i

   293 id2C IOLookupLast i = id2CLookup last i

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

   295     let i' = map toLower i

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

   297     lt <- gets lastType

   298     if isNothing v then

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

   300         else

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

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

   303     where

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

   305         checkParam _ = False

   306 id2C IODeferred (Identifier i t) = do

   307     let i' = map toLower i

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

   309     if (isNothing v) then

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

   311         else

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

   313 

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

   315 id2CLookup f (Identifier i t) = do

   316     let i' = map toLower i

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

   318     lt <- gets lastType

   319     if isNothing v then

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

   321         else

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

   323 

   324 

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

   326 id2CTyped = id2CTyped2 Nothing

   327 

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

   329 id2CTyped2 md t (Identifier i _) = do

   330     tb <- resolveType t

   331     case (t, tb) of

   332         (_, BTUnknown) -> do

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

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

   335             ts <- type2C t

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

   337         (_, BTRecord _ r) -> do

   338             ts <- type2C t

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

   340         _ -> case md of

   341                 Nothing -> id2C IOInsert (Identifier i tb)

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

   343 

   344 

   345 resolveType :: TypeDecl -> State RenderState BaseType

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

   347     let i' = map toLower i

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

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

   350     where

   351     f "integer" = BTInt

   352     f "pointer" = BTPointerTo BTVoid

   353     f "boolean" = BTBool

   354     f "float" = BTFloat

   355     f "char" = BTChar

   356     f "string" = BTString

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

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

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

   360 resolveType (RecordType tv mtvs) = do

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

   362     return . BTRecord "" . concat $ tvs

   363     where

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

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

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

   367     t' <- resolveType t

   368     return $ BTArray i BTInt t'

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

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

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

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

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

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

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

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

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

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

   379 resolveType (DeriveType _) = return BTUnknown

   380 resolveType (String _) = return BTString

   381 resolveType VoidType = return BTVoid

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

   383 resolveType (RangeType _) = return $ BTVoid

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

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

   386 

   387 

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

   389 resolve s (BTUnresolved t) = do

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

   391     if isJust v then

   392         resolve s . baseType . head . fromJust $ v

   393         else

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

   395 resolve _ t = return t

   396 

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

   398 fromPointer s (BTPointerTo t) = resolve s t

   399 fromPointer s t = do

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

   401 

   402 

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

   404 

   405 numberOfDeclarations :: [TypeVarDeclaration] -> Int

   406 numberOfDeclarations = sum . map cnt

   407     where

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

   409         cnt _ = 1

   410 

   411 hasPassByReference :: [TypeVarDeclaration] -> Bool

   412 hasPassByReference = or . map isVar

   413     where

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

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

   416 

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

   418 toIsVarList = concatMap isVar

   419     where

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

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

   422 

   423 

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

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

   426     where

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

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

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

   430 

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

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

   433     t <- type2C returnType

   434     t'<- gets lastType

   435     p <- withState' id $ functionParams2C params

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

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

   438     if hasVars then

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

   440         else

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

   442     where

   443         hasVars = hasPassByReference params

   444 

   445 

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

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

   448     t <- type2C returnType

   449     t'<- gets lastType

   450 

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

   452 

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

   454 

   455     let isVoid = case returnType of

   456             VoidType -> True

   457             _ -> False

   458 

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

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

   461         p <- functionParams2C params

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

   463         return (p, ph)

   464 

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

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

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

   468     return [

   469         define

   470         $+$

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

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

   473         $+$

   474         text "{"

   475         $+$

   476         nest 4 phrasesBlock

   477         $+$

   478         text "}"]

   479     where

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

   481     phrase2C' p = phrase2C p

   482     un [a] b = a : b

   483     hasVars = hasPassByReference params

   484 

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

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

   487 

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

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

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

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

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

   493     t <- fun2C b name f

   494     if includeType then return t else return []

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

   496     i <- id2CTyped t i'

   497     tp <- type2C t

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

   499 

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

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

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

   503 

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

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

   506                                                                 then text "extern"

   507                                                                 else empty)

   508                    <+>) . ) $ type2C t

   509     ie <- initExpr mInitExpr

   510     lt <- gets lastType

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

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

   513              i' <- id2CTyped t i

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

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

   516              i' <- id2CTyped t i

   517              ie <- initExpr2C e

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

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

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

   521             i' <- id2CTyped t i

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

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

   524                 (_, _, _) -> ie

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

   526             case (r, ignoreInit) of

   527                 (RangeInfinite, False) ->

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

   529                     return $ [dimDecl] ++ result

   530                     where

   531                         arrayDimStr = show $ arrayDimension t

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

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

   534 

   535                 (_, _) -> return result

   536 

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

   538     where

   539     initExpr Nothing = return $ empty

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

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

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

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

   544     varDeclDecision True False varStr expStr = empty

   545     arrayDimension a = case a of

   546         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

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

   548         _ -> 0

   549 

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

   551     r <- op2CTyped op (extractTypes params)

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

   553 

   554 

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

   556 op2CTyped op t = do

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

   558     bt <- gets lastType

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

   560     where

   561     opStr = case op of

   562                     "+" -> "add"

   563                     "-" -> "sub"

   564                     "*" -> "mul"

   565                     "/" -> "div"

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

   567                     "=" -> "eq"

   568                     "<" -> "lt"

   569                     ">" -> "gt"

   570                     "<>" -> "neq"

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

   572 

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

   574 extractTypes = concatMap f

   575     where

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

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

   578 

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

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

   581 initExpr2C a = initExpr2C' a

   582 initExpr2C' InitNull = return $ text "NULL"

   583 initExpr2C' (InitAddress expr) = do

   584     ie <- initExpr2C' expr

   585     lt <- gets lastType

   586     case lt of

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

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

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

   590 initExpr2C' (InitBinOp op expr1 expr2) = do

   591     e1 <- initExpr2C' expr1

   592     e2 <- initExpr2C' expr2

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

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

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

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

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

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

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

   600 initExpr2C' (InitReference i) = id2C IOLookup i

   601 initExpr2C' (InitRecord fields) = do

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

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

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

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

   606     id2C IOLookup i

   607     t <- gets lastType

   608     case t of

   609          BTEnum s -> return . int $ length s

   610          BTInt -> case i' of

   611                        "byte" -> return $ int 256

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

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

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

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

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

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

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

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

   620     case e of

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

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

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

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

   625     initExpr2C e

   626     t <- gets lastType

   627     case t of

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

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

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

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

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

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

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

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

   636 

   637 

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

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

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

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

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

   643 

   644 baseType2C :: String -> BaseType -> Doc

   645 baseType2C _ BTFloat = text "float"

   646 baseType2C _ BTBool = text "bool"

   647 baseType2C _ BTString = text "string255"

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

   649 

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

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

   652 type2C t = do

   653     r <- type2C' t

   654     rt <- resolveType t

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

   656     return r

   657     where

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

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

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

   661         i' <- id2C IODeferred i

   662         lt <- gets lastType

   663         case lt of

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

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

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

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

   668     type2C' (RecordType tvs union) = do

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

   670         u <- unions

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

   672         where

   673             f s = s{currentUnit = ""}

   674             unions = case union of

   675                      Nothing -> return empty

   676                      Just a -> do

   677                          structs <- mapM struct2C a

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

   679             struct2C tvs = do

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

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

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

   683     type2C' (Sequence ids) = do

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

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

   686         where

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

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

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

   690         t' <- type2C t

   691         lt <- gets lastType

   692         ft <- case lt of

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

   694                 _ -> return t'

   695         r' <- initExpr2C (InitRange r)

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

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

   698     type2C' (FunctionType returnType params) = do

   699         t <- type2C returnType

   700         p <- withState' id $ functionParams2C params

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

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

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

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

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

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

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

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

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

   710         initExpr2C r

   711         t <- gets lastType

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

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

   714 

   715 phrase2C :: Phrase -> State RenderState Doc

   716 phrase2C (Phrases p) = do

   717     ps <- mapM phrase2C p

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

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

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

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

   722     r <- ref2C ref

   723     ps <- mapM expr2C params

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

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

   726     e <- expr2C expr

   727     p1 <- (phrase2C . wrapPhrase) phrase1

   728     el <- elsePart

   729     return $

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

   731     where

   732     elsePart | isNothing mphrase2 = return $ empty

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

   734 phrase2C (Assignment ref expr) = do

   735     r <- ref2C ref

   736     t <- gets lastType

   737     case (t, expr) of

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

   739             e <- ref2C r'

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

   741         (BTString, _) -> do

   742             e <- expr2C expr

   743             lt <- gets lastType

   744             case lt of

   745                 -- assume pointer to char for simplicity

   746                 BTPointerTo _ -> do

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

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

   749                 BTString -> do

   750                     e <- expr2C expr

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

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

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

   754             case expr of

   755                 Reference er -> do

   756                     exprRef <- ref2C er

   757                     exprT <- gets lastType

   758                     case exprT of

   759                         BTArray RangeInfinite _ _ ->

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

   761                         BTArray _ _ _ -> phrase2C $

   762                                 ProcCall (FunCall

   763                                     [

   764                                     Reference $ ref

   765                                     , Reference $ RefExpression expr

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

   767                                     ]

   768                                     (SimpleReference (Identifier "memcpy" BTUnknown))

   769                                     ) []

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

   771 

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

   773         _ -> do

   774             e <- expr2C expr

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

   776 phrase2C (WhileCycle expr phrase) = do

   777     e <- expr2C expr

   778     p <- phrase2C $ wrapPhrase phrase

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

   780 phrase2C (SwitchCase expr cases mphrase) = do

   781     e <- expr2C expr

   782     cs <- mapM case2C cases

   783     d <- dflt

   784     return $

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

   786     where

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

   788     case2C (e, p) = do

   789         ies <- mapM range2C e

   790         ph <- phrase2C p

   791         return $

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

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

   794          | otherwise = do

   795              ph <- mapM phrase2C $ fromJust mphrase

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

   797 

   798 phrase2C wb@(WithBlock ref p) = do

   799     r <- ref2C ref

   800     t <- gets lastType

   801     case t of

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

   803         a -> do

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

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

   806     i <- id2C IOLookup i'

   807     iType <- gets lastIdTypeDecl

   808     e1 <- expr2C e1'

   809     e2 <- expr2C e2'

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

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

   812     let iEnd = i <> text "__end__"

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

   814     return . braces $

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

   816         $$

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

   818         $$

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

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

   821     where

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

   823 phrase2C (RepeatCycle e' p') = do

   824     e <- expr2C e'

   825     p <- phrase2C (Phrases p')

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

   827 phrase2C NOP = return $ text ";"

   828 

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

   830     f <- gets currentFunctionResult

   831     if null f then

   832         return $ text "return" <> semi

   833         else

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

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

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

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

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

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

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

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

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

   843 

   844 wrapPhrase p@(Phrases _) = p

   845 wrapPhrase p = Phrases [p]

   846 

   847 expr2C :: Expression -> State RenderState Doc

   848 expr2C (Expression s) = return $ text s

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

   850     e1 <- expr2C expr1

   851     t1 <- gets lastType

   852     e2 <- expr2C expr2

   853     t2 <- gets lastType

   854     case (op2C op, t1, t2) of

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

   872             case expr2 of

   873                  SetExpression set -> do

   874                      ids <- mapM (id2C IOLookup) set

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

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

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

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

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

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

   881                   | otherwise -> do

   882                         o' <- return $ case o of

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

   884                             _ -> text o

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

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

   887                                 _ -> parens e1

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

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

   890                                 _ -> parens e2

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

   892     where

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

   894 expr2C (NumberLiteral s) = do

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

   896     return $ text s

   897 expr2C (FloatLiteral s) = return $ text s

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

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

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

   901     return . quotes . text $ escape a

   902     where

   903         escape '\'' = "\\\'"

   904         escape a = [a]-}

   905 expr2C (StringLiteral s) = addStringConst s

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

   907 expr2C (Reference ref) = ref2CF ref

   908 expr2C (PrefixOp op expr) = do

   909     e <- expr2C expr

   910     lt <- gets lastType

   911     case lt of

   912         BTRecord t _ -> do

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

   914             ref2C $ FunCall [expr] (SimpleReference i)

   915         BTBool -> do

   916             o <- return $ case op of

   917                      "not" -> text "!"

   918                      _ -> text (op2C op)

   919             return $ o <> parens e

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

   921 expr2C Null = return $ text "NULL"

   922 expr2C (CharCode a) = do

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

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

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

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

   927 

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

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

   930     lt <- gets lastType

   931     case lt of

   932          BTEnum a -> return $ int 0

   933          BTInt -> case e' of

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

   935          BTArray {} -> return $ int 0

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

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

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

   939     lt <- gets lastType

   940     case lt of

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

   942          BTInt -> case e' of

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

   944          BTString -> return $ int 255

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

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

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

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

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

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

   951     e' <- expr2C e

   952     lt <- gets lastType

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

   954     case lt of

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

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

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

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

   959 expr2C (BuiltInFunCall params ref) = do

   960     r <- ref2C ref

   961     t <- gets lastType

   962     ps <- mapM expr2C params

   963     case t of

   964         BTFunction _ _ t' -> do

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

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

   967     return $

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

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

   970 

   971 ref2CF :: Reference -> State RenderState Doc

   972 ref2CF (SimpleReference name) = do

   973     i <- id2C IOLookup name

   974     t <- gets lastType

   975     case t of

   976          BTFunction _ _ rt -> do

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

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

   979          _ -> return $ i

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

   981     i <- ref2C r

   982     t <- gets lastType

   983     case t of

   984          BTFunction _ _ rt -> do

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

   986              return $ i <> parens empty

   987          _ -> return $ i

   988 ref2CF r = ref2C r

   989 

   990 ref2C :: Reference -> State RenderState Doc

   991 -- rewrite into proper form

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

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

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

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

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

   997 -- conversion routines

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

   999     e <- expr2C expr

  1000     r <- ref2C ref

  1001     t <- gets lastType

  1002     case t of

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

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

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

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

  1007          (BTPointerTo t) -> do

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

  1009                 case t'' of

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

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

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

  1013     case t of

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

  1015          _ -> return $ r <> brackets e

  1016 ref2C (SimpleReference name) = id2C IOLookup name

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

  1018     r1 <- ref2C ref1

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

  1020     r2 <- case t of

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

  1022         BTUnit -> error "What??"

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

  1024     return $

  1025         r1 <> text "->" <> r2

  1026 ref2C rf@(RecordField ref1 ref2) = do

  1027     r1 <- ref2C ref1

  1028     t <- gets lastType

  1029     case t of

  1030         BTRecord _ rs -> do

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

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

  1033         BTUnit -> withLastIdNamespace $ ref2C ref2

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

  1035 ref2C d@(Dereference ref) = do

  1036     r <- ref2C ref

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

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

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

  1040 ref2C f@(FunCall params ref) = do

  1041     r <- fref2C ref

  1042     t <- gets lastType

  1043     case t of

  1044         BTFunction _ _ t' -> do

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

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

  1047             return $ r <> ps

  1048         _ -> case (ref, params) of

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

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

  1051     where

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

  1053     fref2C a = ref2C a

  1054 

  1055 ref2C (Address ref) = do

  1056     r <- ref2C ref

  1057     lt <- gets lastType

  1058     case lt of

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

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

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

  1062     lt <- expr2C expr >> gets lastType

  1063     case (map toLower i, lt) of

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

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

  1066         (a, _) -> do

  1067             e <- expr2C expr

  1068             t <- id2C IOLookup t'

  1069             return . parens $ parens t <> e

  1070 ref2C (RefExpression expr) = expr2C expr

  1071 

  1072 

  1073 op2C :: String -> String

  1074 op2C "or" = "|"

  1075 op2C "and" = "&"

  1076 op2C "not" = "~"

  1077 op2C "xor" = "^"

  1078 op2C "div" = "/"

  1079 op2C "mod" = "%"

  1080 op2C "shl" = "<<"

  1081 op2C "shr" = ">>"

  1082 op2C "<>" = "!="

  1083 op2C "=" = "=="

  1084 op2C "/" = "/(float)"

  1085 op2C a = a

  1086