7 

     7 import Text.Parsec.Prim hiding (State)

     8 

     8 import Control.Monad.State

     9 pascal2C :: PascalUnit -> Doc

     9 import System.IO

    10 pascal2C (Unit unitName interface implementation init fin) = implementation2C implementation

    10 import System.Directory

    11 

    11 import Control.Monad.IO.Class

    12 

    12 import PascalPreprocessor

    13 implementation2C :: Implementation -> Doc

    13 import Control.Exception

    14 implementation2C (Implementation uses tvars) = typesAndVars2C tvars

    14 import System.IO.Error

    15 

    15 import qualified Data.Map as Map

    16 

    16 import qualified Data.Set as Set

    17 typesAndVars2C :: TypesAndVars -> Doc

    17 import Data.List (find)

    18 typesAndVars2C (TypesAndVars ts) = vcat $ map tvar2C ts

    18 import Numeric

    19 

    19 

    20 

    20 import PascalParser(pascalUnit)

    21 tvar2C :: TypeVarDeclaration -> Doc

    21 import PascalUnitSyntaxTree

    22 tvar2C (FunctionDeclaration (Identifier name) returnType Nothing) = 

    22 

    23     type2C returnType <+> text (name ++ "();")

    23 

    24 

    24 data InsertOption =

    25     

    25     IOInsert

    26 tvar2C (FunctionDeclaration (Identifier name) returnType (Just phrase)) = 

    26     | IOInsertWithType Doc

    27     type2C returnType <+> text (name ++ "()") 

    27     | IOLookup

    28     $$

    28     | IOLookupLast

    29     phrase2C phrase

    29     | IOLookupFunction Int

    30 tvar2C _ = empty

    30     | IODeferred

    31 

    31 

    32 type2C :: TypeDecl -> Doc

    32 data Record = Record

    33 type2C UnknownType = text "void"

    33     {

    34 type2C _ = text "<<type>>"

    34         lcaseId :: String,

    35 

    35         baseType :: BaseType,

    36 phrase2C :: Phrase -> Doc

    36         typeDecl :: Doc

    37 phrase2C (Phrases p) = text "{" $+$ (nest 4 . vcat . map phrase2C $ p) $+$ text "}"

    37     }

    38 phrase2C (ProcCall (Identifier name) params) = text name <> parens (hsep . punctuate (char ',') . map expr2C $ params) <> semi

    38     deriving Show

    39 phrase2C (IfThenElse (expr) phrase1 mphrase2) = text "if" <> parens (expr2C expr) $+$ (phrase2C . wrapPhrase) phrase1 $+$ elsePart

    39 type Records = Map.Map String [Record]

    40     where

    40 data RenderState = RenderState

    41     elsePart | isNothing mphrase2 = empty

    41     {

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

    42         currentScope :: Records,

    43 phrase2C (Assignment ref expr) = ref2C ref <> text " = " <> expr2C expr <> semi

    43         lastIdentifier :: String,

    44 phrase2C (WhileCycle expr phrase) = text "while" <> parens (expr2C expr) $$ (phrase2C $ wrapPhrase phrase)

    44         lastType :: BaseType,

    45 phrase2C (SwitchCase expr cases mphrase) = text "switch" <> parens (expr2C expr) <> text "of" $+$ (nest 4 . vcat . map case2C) cases

    45         lastIdTypeDecl :: Doc,

    46     where

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

    47     case2C :: (Expression, Phrase) -> Doc

    47         uniqCounter :: Int,

    48     case2C (e, p) = text "case" <+> parens (expr2C e) <> char ':' <> nest 4 (phrase2C p $+$ text "break;")

    48         toMangle :: Set.Set String,

    49 {-

    49         currentUnit :: String,

    50         | RepeatCycle Expression Phrase

    50         currentFunctionResult :: String,

    51         | ForCycle

    51         namespaces :: Map.Map String Records

    52         -}

    52     }

    53 phrase2C _ = empty

    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

    58 expr2C :: Expression -> Doc

   847 expr2C :: Expression -> State RenderState Doc

    59 expr2C (Expression s) = text s

   848 expr2C (Expression s) = return $ text s

    60 expr2C (BinOp op expr1 expr2) = parens $ (expr2C expr1) <+> op2C op <+> (expr2C expr2)

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

    61 expr2C (NumberLiteral s) = text s

   850     e1 <- expr2C expr1

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

   851     t1 <- gets lastType

    63 expr2C (StringLiteral s) = doubleQuotes $ text s 

   852     e2 <- expr2C expr2

    64 expr2C (Reference ref) = ref2C ref

   853     t2 <- gets lastType

    65 expr2C (PrefixOp op expr) = op2C op <+> expr2C expr

   854     case (op2C op, t1, t2) of

    66     {-

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

    67     | PostfixOp String Expression

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

    68     | CharCode String

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

    69     -}            

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

    70 expr2C _ = empty

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

    71 

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

    72 

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

    73 ref2C :: Reference -> Doc

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

    74 ref2C (ArrayElement exprs ref) = ref2C ref <> (brackets . hcat) (punctuate comma $ map expr2C exprs)

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

    75 ref2C (SimpleReference (Identifier name)) = text name

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

    76 ref2C (RecordField (Dereference ref1) ref2) = ref2C ref1 <> text "->" <> ref2C ref2

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

    77 ref2C (RecordField ref1 ref2) = ref2C ref1 <> text "." <> ref2C ref2

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

    78 ref2C (Dereference ref) = parens $ text "*" <> ref2C ref

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

    79 ref2C (FunCall params ref) = ref2C ref <> parens (hsep . punctuate (char ',') . map expr2C $ params)

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

    80 ref2C (Address ref) = text "&" <> ref2C ref

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

    81 

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

    82 op2C "or" = text "|"

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

    83 op2C "and" = text "&"

   872             case expr2 of

    84 op2C "not" = text "!"

   873                  SetExpression set -> do

    85 op2C "xor" = text "^"

   874                      ids <- mapM (id2C IOLookup) set

    86 op2C "div" = text "/"

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

    87 op2C "mod" = text "%"

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

    88 op2C "shl" = text "<<"

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

    89 op2C "shr" = text ">>"

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

    90 op2C "<>" = text "!="

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

    91 op2C "=" = text "=="

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

    92 op2C a = text a

   881                   | otherwise -> do

    93 

   882                         o' <- return $ case o of

    94 maybeVoid "" = "void"

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

    95 maybeVoid a = a

   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