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         isFunctionType :: Bool, -- set to true if the current function parameter is functiontype

    46         lastIdTypeDecl :: Doc,

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

    48         uniqCounter :: Int,

    49         toMangle :: Set.Set String,

    50         enums :: [(String, [String])], -- store all declared enums

    51         currentUnit :: String,

    52         currentFunctionResult :: String,

    53         namespaces :: Map.Map String Records

    54     }

    55 

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

    57 

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

    59 

    60 getUniq :: State RenderState Int

    61 getUniq = do

    62     i <- gets uniqCounter

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

    64     return i

    65 

    66 addStringConst :: String -> State RenderState Doc

    67 addStringConst str = do

    68     strs <- gets stringConsts

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

    70     if isJust a then

    71         do

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

    73         return . text . fst . fromJust $ a

    74     else

    75         do

    76         i <- getUniq

    77         let sn = "__str" ++ show i

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

    79         return $ text sn

    80 

    81 escapeStr :: String -> String

    82 escapeStr = foldr escapeChar []

    83 

    84 escapeChar :: Char -> ShowS

    85 escapeChar '"' s = "\\\"" ++ s

    86 escapeChar '\\' s = "\\\\" ++ s

    87 escapeChar a s = a : s

    88 

    89 strInit :: String -> Doc

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

    91 

    92 renderStringConsts :: State RenderState Doc

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

    94     $ gets stringConsts

    95 

    96 docToLower :: Doc -> Doc

    97 docToLower = text . map toLower . render

    98 

    99 pas2C :: String -> String -> String -> String -> [String] -> IO ()

   100 pas2C fn inputPath outputPath alternateInputPath symbols = do

   101     s <- flip execStateT initState $ f fn

   102     renderCFiles s outputPath

   103     where

   104     printLn = liftIO . hPutStrLn stdout

   105     print = liftIO . hPutStr stdout

   106     initState = Map.empty

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

   108     f fileName = do

   109         processed <- gets $ Map.member fileName

   110         unless processed $ do

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

   112             fc' <- liftIO

   113                 $ tryJust (guard . isDoesNotExistError)

   114                 $ preprocess inputPath alternateInputPath (fileName ++ ".pas") symbols

   115             case fc' of

   116                 (Left a) -> do

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

   118                     printLn "doesn't exist"

   119                 (Right fc) -> do

   120                     print "ok, parsing... "

   121                     let ptree = parse pascalUnit fileName fc

   122                     case ptree of

   123                          (Left a) -> do

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

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

   126                             fail "stop"

   127                          (Right a) -> do

   128                             printLn "ok"

   129                             modify (Map.insert fileName a)

   130                             mapM_ f (usesFiles a)

   131 

   132 

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

   134 renderCFiles units outputPath = do

   135     let u = Map.toList units

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

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

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

   139     mapM_ (toCFiles outputPath nss) u

   140     where

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

   142     toNamespace nss (System tvs) =

   143         currentScope $ execState f (emptyState nss)

   144         where

   145         f = do

   146             checkDuplicateFunDecls tvs

   147             mapM_ (tvar2C True False True False) tvs

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

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

   150         where

   151         f = do

   152             checkDuplicateFunDecls tvs

   153             mapM_ (tvar2C True False True False) tvs

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

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

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

   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 :: String -> Map.Map String Records -> (String, PascalUnit) -> IO ()

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

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

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

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

   187     toCFiles' p

   188     where

   189     toCFiles' (fn, p@(Program {})) = writeFile (outputPath ++ 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             enumDecl = (renderEnum2Strs (enums s) False)

   194             enumImpl = (renderEnum2Strs (enums s) True)

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

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

   197     initialState = emptyState ns

   198 

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

   200     render2C st p =

   201         let (a, s) = runState p st in

   202         render a

   203 

   204 renderEnum2Strs :: [(String, [String])] -> Bool -> String

   205 renderEnum2Strs enums implement =

   206     render $ foldl ($+$) empty $ map (\en -> let d = decl (fst en) in if implement then d $+$ enum2strBlock (snd en) else d <> semi) enums

   207     where

   208     decl id = text "string255 __attribute__((overloadable)) fpcrtl_GetEnumName" <> parens (text "int dummy, const" <+> text id <+> text "enumvar")

   209     enum2strBlock en =

   210             text "{"

   211             $+$

   212             (nest 4 $

   213                 text "switch(enumvar){"

   214                 $+$

   215                 (foldl ($+$) empty $ map (\e -> text "case" <+> text e <> colon $+$ (nest 4 $ text "return fpcrtl_make_string" <> (parens $ doubleQuotes $ text e) <> semi $+$ text "break;")) en)

   216                 $+$

   217                 text "default: assert(0);"

   218                 $+$

   219                 (nest 4 $ text "return fpcrtl_make_string(\"nonsense\");")

   220                 $+$

   221                 text "}"

   222             )

   223             $+$

   224             text "}"

   225 

   226 usesFiles :: PascalUnit -> [String]

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

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

   229 usesFiles (System {}) = []

   230 usesFiles (Redo {}) = []

   231 

   232 pascal2C :: PascalUnit -> State RenderState Doc

   233 pascal2C (Unit _ interface implementation init fin) =

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

   235 

   236 pascal2C (Program _ implementation mainFunction) = do

   237     impl <- implementation2C implementation

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

   239 

   240     return $ impl $+$ main

   241 

   242 

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

   244 -- that will be inserted into implementation files

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

   246 interface2C (Interface uses tvars) True = do

   247     u <- uses2C uses

   248     tv <- typesAndVars2C True True True tvars

   249     r <- renderStringConsts

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

   251 interface2C (Interface uses tvars) False = do

   252     u <- uses2C uses

   253     tv <- typesAndVars2C True False False tvars

   254     r <- renderStringConsts

   255     return tv

   256 

   257 implementation2C :: Implementation -> State RenderState Doc

   258 implementation2C (Implementation uses tvars) = do

   259     u <- uses2C uses

   260     tv <- typesAndVars2C True False True tvars

   261     r <- renderStringConsts

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

   263 

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

   265 checkDuplicateFunDecls tvs =

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

   267     where

   268         initMap = Map.empty

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

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

   271         ins _ m = m

   272 

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

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

   275 

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

   277 typesAndVars2C b externVar includeType(TypesAndVars ts) = do

   278     checkDuplicateFunDecls ts

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

   280 

   281 setBaseType :: BaseType -> Identifier -> Identifier

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

   283 

   284 uses2C :: Uses -> State RenderState Doc

   285 uses2C uses@(Uses unitIds) = do

   286 

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

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

   289     mapM_ (id2C IOInsert . setBaseType BTUnit) unitIds

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

   291     where

   292     injectNamespace (Identifier i _) = do

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

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

   295 

   296 uses2List :: Uses -> [String]

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

   298 

   299 

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

   301 

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

   303 id2C IOInsert i = id2C (IOInsertWithType empty) i

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

   305     ns <- gets currentScope

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

   307     cu <- gets currentUnit

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

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

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

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

   312             _ -> (i, t)

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

   314     return $ text i'

   315     where

   316         n = map toLower i

   317 

   318 id2C IOLookup i = id2CLookup head i

   319 id2C IOLookupLast i = id2CLookup last i

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

   321     let i' = map toLower i

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

   323     lt <- gets lastType

   324     if isNothing v then

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

   326         else

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

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

   329     where

   330         checkParam (Record _ (BTFunction _ p _) _) = (length p) == params

   331         checkParam _ = False

   332 id2C IODeferred (Identifier i t) = do

   333     let i' = map toLower i

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

   335     if (isNothing v) then

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

   337         else

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

   339 

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

   341 id2CLookup f (Identifier i t) = do

   342     let i' = map toLower i

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

   344     lt <- gets lastType

   345     if isNothing v then

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

   347         else

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

   349 

   350 

   351 

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

   353 id2CTyped = id2CTyped2 Nothing

   354 

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

   356 id2CTyped2 md t (Identifier i _) = do

   357     tb <- resolveType t

   358     case (t, tb) of

   359         (_, BTUnknown) -> do

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

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

   362             ts <- type2C t

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

   364         (_, BTRecord _ r) -> do

   365             ts <- type2C t

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

   367         _ -> case md of

   368                 Nothing -> id2C IOInsert (Identifier i tb)

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

   370 

   371 typeVarDecl2BaseType :: [TypeVarDeclaration] -> State RenderState [(Bool, BaseType)]

   372 typeVarDecl2BaseType d = do

   373     st <- get

   374     result <- sequence $ concat $ map resolveType' d

   375     put st -- restore state (not sure if necessary)

   376     return result

   377     where

   378         resolveType' :: TypeVarDeclaration -> [State RenderState (Bool, BaseType)]

   379         resolveType' (VarDeclaration isVar _ (ids, t) _) = replicate (length ids) (resolveTypeHelper' (resolveType t) isVar)

   380         resolveType' _ = error "typeVarDecl2BaseType: not a VarDeclaration"

   381         resolveTypeHelper' :: State RenderState BaseType -> Bool -> State RenderState (Bool, BaseType)

   382         resolveTypeHelper' st b = do

   383             bt <- st

   384             return (b, bt)

   385 

   386 resolveType :: TypeDecl -> State RenderState BaseType

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

   388     let i' = map toLower i

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

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

   391     where

   392     f "uinteger" = BTInt False

   393     f "integer" = BTInt True

   394     f "pointer" = BTPointerTo BTVoid

   395     f "boolean" = BTBool

   396     f "float" = BTFloat

   397     f "char" = BTChar

   398     f "string" = BTString

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

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

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

   402 resolveType (RecordType tv mtvs) = do

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

   404     return . BTRecord "" . concat $ tvs

   405     where

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

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

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

   409     t' <- resolveType t

   410     return $ BTArray i (BTInt True) t'

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

   412 resolveType (FunctionType t a) = do

   413     bts <- typeVarDecl2BaseType a

   414     liftM (BTFunction False bts) $ resolveType t

   415 resolveType (DeriveType (InitHexNumber _)) = return (BTInt True)

   416 resolveType (DeriveType (InitNumber _)) = return (BTInt True)

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

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

   419 resolveType (DeriveType (InitBinOp {})) = return (BTInt True)

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

   421 resolveType (DeriveType (BuiltInFunction{})) = return (BTInt True)

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

   423 resolveType (DeriveType _) = return BTUnknown

   424 resolveType (String _) = return BTString

   425 resolveType VoidType = return BTVoid

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

   427 resolveType (RangeType _) = return $ BTVoid

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

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

   430 

   431 

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

   433 resolve s (BTUnresolved t) = do

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

   435     if isJust v then

   436         resolve s . baseType . head . fromJust $ v

   437         else

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

   439 resolve _ t = return t

   440 

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

   442 fromPointer s (BTPointerTo t) = resolve s t

   443 fromPointer s t = do

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

   445 

   446 

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

   448 

   449 numberOfDeclarations :: [TypeVarDeclaration] -> Int

   450 numberOfDeclarations = sum . map cnt

   451     where

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

   453         cnt _ = 1

   454 

   455 hasPassByReference :: [TypeVarDeclaration] -> Bool

   456 hasPassByReference = or . map isVar

   457     where

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

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

   460 

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

   462 toIsVarList = concatMap isVar

   463     where

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

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

   466 

   467 

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

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

   470     where

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

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

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

   474 

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

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

   477     t <- type2C returnType

   478     t'<- gets lastType

   479     bts <- typeVarDecl2BaseType params

   480     p <- withState' id $ functionParams2C params

   481     n <- liftM render . id2C IOInsert $ setBaseType (BTFunction False bts t') name

   482     let decor = if overload then text "__attribute__((overloadable))" else empty

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

   484 

   485 fun2C True rv (FunctionDeclaration name@(Identifier i bt) inline overload returnType params (Just (tvars, phrase))) = do

   486     let isVoid = case returnType of

   487             VoidType -> True

   488             _ -> False

   489 

   490     let res = docToLower $ text rv <> if isVoid then empty else text "_result"

   491     t <- type2C returnType

   492     t' <- gets lastType

   493 

   494     bts <- typeVarDecl2BaseType params

   495     cu <- gets currentUnit

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

   497 

   498     n <- liftM render . id2C IOInsert $ setBaseType (BTFunction hasVars bts t') name

   499     let resultId = if isVoid

   500                     then n -- void type doesn't have result, solving recursive procedure calls

   501                     else (render res)

   502 

   503     (p, ph) <- withState' (\st -> st{currentScope = Map.insertWith un (map toLower rv) [Record resultId (if isVoid then (BTFunction hasVars bts t') else t') empty] $ currentScope st

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

   505         p <- functionParams2C params

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

   507         return (p, ph)

   508 

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

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

   511     let inlineDecor = if inline then case notDeclared of

   512                                     True -> text "static inline"

   513                                     False -> text "inline"

   514                           else empty

   515         overloadDecor = if overload then text "__attribute__((overloadable))" else empty

   516     return [

   517         --define

   518         -- $+$

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

   520         inlineDecor <+> t empty <+> overloadDecor <+> text n <> parens p

   521         $+$

   522         text "{"

   523         $+$

   524         nest 4 phrasesBlock

   525         $+$

   526         text "}"]

   527     where

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

   529     phrase2C' p = phrase2C p

   530     un [a] b = a : b

   531     hasVars = hasPassByReference params

   532 

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

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

   535 

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

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

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

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

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

   541     t <- fun2C b name f

   542     if includeType then return t else return []

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

   544     i <- id2CTyped t i'

   545     tp <- type2C t

   546     let res = if includeType then [text "typedef" <+> tp i] else []

   547     case t of

   548         (Sequence ids) -> do

   549             modify(\s -> s{enums = (render i, map (\(Identifier i _) -> i) ids) : enums s})

   550             return res

   551         _ -> return res

   552 

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

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

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

   556 

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

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

   559                                                                 then text "extern"

   560                                                                 else empty)

   561                    <+>) . ) $ type2C t

   562     ie <- initExpr mInitExpr

   563     lt <- gets lastType

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

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

   566              i' <- id2CTyped t i

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

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

   569              i' <- id2CTyped t i

   570              ie <- initExpr2C e

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

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

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

   574             i' <- id2CTyped t i

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

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

   577                 (_, _, _) -> ie

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

   579             case (r, ignoreInit) of

   580                 (RangeInfinite, False) ->

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

   582                     return $ [dimDecl] ++ result

   583                     where

   584                         arrayDimStr = show $ arrayDimension t

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

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

   587 

   588                 (_, _) -> return result

   589 

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

   591     where

   592     initExpr Nothing = return $ empty

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

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

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

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

   597     varDeclDecision True False varStr expStr = empty

   598     arrayDimension a = case a of

   599         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

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

   601         _ -> 0

   602 

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

   604     r <- op2CTyped op (extractTypes params)

   605     fun2C f i (FunctionDeclaration r inline False ret params body)

   606 

   607 

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

   609 op2CTyped op t = do

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

   611     bt <- gets lastType

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

   613     where

   614     opStr = case op of

   615                     "+" -> "add"

   616                     "-" -> "sub"

   617                     "*" -> "mul"

   618                     "/" -> "div"

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

   620                     "=" -> "eq"

   621                     "<" -> "lt"

   622                     ">" -> "gt"

   623                     "<>" -> "neq"

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

   625 

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

   627 extractTypes = concatMap f

   628     where

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

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

   631 

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

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

   634 initExpr2C a = initExpr2C' a

   635 initExpr2C' InitNull = return $ text "NULL"

   636 initExpr2C' (InitAddress expr) = do

   637     ie <- initExpr2C' expr

   638     lt <- gets lastType

   639     case lt of

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

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

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

   643 initExpr2C' (InitBinOp op expr1 expr2) = do

   644     e1 <- initExpr2C' expr1

   645     e2 <- initExpr2C' expr2

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

   647 initExpr2C' (InitNumber s) = do

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

   649                                 return $ text s

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

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

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

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

   654 initExpr2C' (InitChar a) = return $ text "0x" <> text (showHex (read a) "")

   655 initExpr2C' (InitReference i) = id2C IOLookup i

   656 initExpr2C' (InitRecord fields) = do

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

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

   659 --initExpr2C' (InitArray [InitRecord fields]) = do

   660 --    e <- initExpr2C $ InitRecord fields

   661 --    return $ braces $ e

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

   663     id2C IOLookup i

   664     t <- gets lastType

   665     case t of

   666          BTEnum s -> return . int $ length s

   667          BTInt _ -> case i' of

   668                        "byte" -> return $ int 256

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

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

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

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

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

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

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

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

   677     case e of

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

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

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

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

   682     initExpr2C e

   683     t <- gets lastType

   684     case t of

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

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

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

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

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

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

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

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

   693 

   694 

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

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

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

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

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

   700 

   701 baseType2C :: String -> BaseType -> Doc

   702 baseType2C _ BTFloat = text "float"

   703 baseType2C _ BTBool = text "bool"

   704 baseType2C _ BTString = text "string255"

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

   706 

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

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

   709 type2C t = do

   710     r <- type2C' t

   711     rt <- resolveType t

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

   713     return r

   714     where

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

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

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

   718         i' <- id2C IODeferred i

   719         lt <- gets lastType

   720         case lt of

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

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

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

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

   725     type2C' (RecordType tvs union) = do

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

   727         u <- unions

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

   729         where

   730             f s = s{currentUnit = ""}

   731             unions = case union of

   732                      Nothing -> return empty

   733                      Just a -> do

   734                          structs <- mapM struct2C a

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

   736             struct2C tvs = do

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

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

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

   740     type2C' (Sequence ids) = do

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

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

   743         where

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

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

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

   747         t' <- type2C t

   748         lt <- gets lastType

   749         ft <- case lt of

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

   751                 _ -> return t'

   752         r' <- initExpr2C (InitRange r)

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

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

   755     type2C' (FunctionType returnType params) = do

   756         t <- type2C returnType

   757         p <- withState' id $ functionParams2C params

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

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

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

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

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

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

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

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

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

   767         initExpr2C r

   768         t <- gets lastType

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

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

   771 

   772 phrase2C :: Phrase -> State RenderState Doc

   773 phrase2C (Phrases p) = do

   774     ps <- mapM phrase2C p

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

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

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

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

   779     r <- ref2C ref

   780     ps <- mapM expr2C params

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

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

   783     e <- expr2C expr

   784     p1 <- (phrase2C . wrapPhrase) phrase1

   785     el <- elsePart

   786     return $

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

   788     where

   789     elsePart | isNothing mphrase2 = return $ empty

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

   791 phrase2C asgn@(Assignment ref expr) = do

   792     r <- ref2C ref

   793     t <- gets lastType

   794     case (t, expr) of

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

   796             e <- ref2C r'

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

   798         (BTString, _) -> do

   799             e <- expr2C expr

   800             lt <- gets lastType

   801             case lt of

   802                 -- assume pointer to char for simplicity

   803                 BTPointerTo _ -> do

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

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

   806                 BTString -> do

   807                     e <- expr2C expr

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

   809                 _ -> error $ "Assignment to string from " ++ show asgn

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

   811             case expr of

   812                 Reference er -> do

   813                     exprRef <- ref2C er

   814                     exprT <- gets lastType

   815                     case exprT of

   816                         BTArray RangeInfinite _ _ ->

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

   818                         BTArray _ _ _ -> phrase2C $

   819                                 ProcCall (FunCall

   820                                     [

   821                                     Reference $ ref

   822                                     , Reference $ RefExpression expr

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

   824                                     ]

   825                                     (SimpleReference (Identifier "memcpy" BTUnknown))

   826                                     ) []

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

   828 

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

   830         _ -> do

   831             e <- expr2C expr

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

   833 phrase2C (WhileCycle expr phrase) = do

   834     e <- expr2C expr

   835     p <- phrase2C $ wrapPhrase phrase

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

   837 phrase2C (SwitchCase expr cases mphrase) = do

   838     e <- expr2C expr

   839     cs <- mapM case2C cases

   840     d <- dflt

   841     return $

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

   843     where

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

   845     case2C (e, p) = do

   846         ies <- mapM range2C e

   847         ph <- phrase2C p

   848         return $

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

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

   851          | otherwise = do

   852              ph <- mapM phrase2C $ fromJust mphrase

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

   854 

   855 phrase2C wb@(WithBlock ref p) = do

   856     r <- ref2C ref

   857     t <- gets lastType

   858     case t of

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

   860         a -> do

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

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

   863     i <- id2C IOLookup i'

   864     iType <- gets lastIdTypeDecl

   865     e1 <- expr2C e1'

   866     e2 <- expr2C e2'

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

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

   869     let iEnd = i <> text "__end__"

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

   871     return . braces $

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

   873         $$

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

   875         $$

   876         text "if" <+> (parens $ i <+> text (if up then "<=" else ">=") <+> iEnd) <+> text "do" <+> ph <+>

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

   878     where

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

   880 phrase2C (RepeatCycle e' p') = do

   881     e <- expr2C e'

   882     p <- phrase2C (Phrases p')

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

   884 

   885 phrase2C NOP = return $ text ";"

   886 

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

   888     f <- gets currentFunctionResult

   889     if null f then

   890         return $ text "return" <> semi

   891         else

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

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

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

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

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

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

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

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

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

   901 

   902 wrapPhrase p@(Phrases _) = p

   903 wrapPhrase p = Phrases [p]

   904 

   905 expr2C :: Expression -> State RenderState Doc

   906 expr2C (Expression s) = return $ text s

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

   908     e1 <- expr2C expr1

   909     t1 <- gets lastType

   910     e2 <- expr2C expr2

   911     t2 <- gets lastType

   912     case (op2C op, t1, t2) of

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

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

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

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

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

   918 

   919         -- for function/procedure comparision

   920         ("==", BTVoid, _) -> procCompare expr1 expr2 "=="

   921         ("==", BTFunction _ _ _, _) -> procCompare expr1 expr2 "=="

   922 

   923         ("!=", BTVoid, _) -> procCompare expr1 expr2 "!="

   924         ("!=", BTFunction _ _ _, _) -> procCompare expr1 expr2 "!="

   925 

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

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

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

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

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

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

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

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

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

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

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

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

   938             case expr2 of

   939                  SetExpression set -> do

   940                      ids <- mapM (id2C IOLookup) set

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

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

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

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

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

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

   947                   | otherwise -> do

   948                         o' <- return $ case o of

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

   950                             _ -> text o

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

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

   953                                 _ -> parens e1

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

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

   956                                 _ -> parens e2

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

   958     where

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

   960         procCompare expr1 expr2 op =

   961             case (expr1, expr2) of

   962                 (Reference r1, Reference r2) -> do

   963                     id1 <- ref2C r1

   964                     id2 <- ref2C r2

   965                     return $ (parens id1) <+> text op <+> (parens id2)

   966                 (_, _) -> error $ "Two non reference type vars are compared but they have type of BTVoid or BTFunction\n" ++ show expr1 ++ "\n" ++ show expr2

   967 

   968 expr2C (NumberLiteral s) = do

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

   970     return $ text s

   971 expr2C (FloatLiteral s) = return $ text s

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

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

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

   975     return . quotes . text $ escape a

   976     where

   977         escape '\'' = "\\\'"

   978         escape a = [a]-}

   979 expr2C (StringLiteral s) = addStringConst s

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

   981 expr2C (Reference ref) = do

   982    isfunc <- gets isFunctionType

   983    modify(\s -> s{isFunctionType = False}) -- reset

   984    if isfunc then ref2CF ref False else ref2CF ref True

   985 expr2C (PrefixOp op expr) = do

   986     e <- expr2C expr

   987     lt <- gets lastType

   988     case lt of

   989         BTRecord t _ -> do

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

   991             ref2C $ FunCall [expr] (SimpleReference i)

   992         BTBool -> do

   993             o <- return $ case op of

   994                      "not" -> text "!"

   995                      _ -> text (op2C op)

   996             return $ o <> parens e

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

   998 expr2C Null = return $ text "NULL"

   999 expr2C (CharCode a) = do

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

  1001     return $ text "0x" <> text (showHex (read a) "")

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

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

  1004 

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

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

  1007     lt <- gets lastType

  1008     case lt of

  1009          BTEnum a -> return $ int 0

  1010          BTInt _ -> case e' of

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

  1012          BTArray {} -> return $ int 0

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

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

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

  1016     lt <- gets lastType

  1017     case lt of

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

  1019          BTInt _ -> case e' of

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

  1021          BTString -> return $ int 255

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

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

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

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

  1026 expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "pred" _))) = do

  1027     e'<- expr2C e

  1028     return $ text "(int)" <> parens e' <> text " - 1"

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

  1030     e' <- expr2C e

  1031     lt <- gets lastType

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

  1033     case lt of

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

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

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

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

  1038 expr2C (BuiltInFunCall params ref) = do

  1039     r <- ref2C ref

  1040     t <- gets lastType

  1041     ps <- mapM expr2C params

  1042     case t of

  1043         BTFunction _ _ t' -> do

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

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

  1046     return $

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

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

  1049 

  1050 ref2CF :: Reference -> Bool -> State RenderState Doc

  1051 ref2CF (SimpleReference name) addParens = do

  1052     i <- id2C IOLookup name

  1053     t <- gets lastType

  1054     case t of

  1055          BTFunction _ _ rt -> do

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

  1057              return $ if addParens then i <> parens empty else i --xymeng: removed parens

  1058          _ -> return $ i

  1059 ref2CF r@(RecordField (SimpleReference _) (SimpleReference _)) addParens = do

  1060     i <- ref2C r

  1061     t <- gets lastType

  1062     case t of

  1063          BTFunction _ _ rt -> do

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

  1065              return $ if addParens then i <> parens empty else i

  1066          _ -> return $ i

  1067 ref2CF r _ = ref2C r

  1068 

  1069 ref2C :: Reference -> State RenderState Doc

  1070 -- rewrite into proper form

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

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

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

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

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

  1076 -- conversion routines

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

  1078     e <- expr2C expr

  1079     r <- ref2C ref

  1080     t <- gets lastType

  1081     case t of

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

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

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

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

  1086          (BTPointerTo t) -> do

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

  1088                 case t'' of

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

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

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

  1092     case t of

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

  1094          _ -> return $ r <> brackets e

  1095 ref2C (SimpleReference name) = id2C IOLookup name

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

  1097     r1 <- ref2C ref1

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

  1099     r2 <- case t of

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

  1101         BTUnit -> error "What??"

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

  1103     return $

  1104         r1 <> text "->" <> r2

  1105 ref2C rf@(RecordField ref1 ref2) = do

  1106     r1 <- ref2C ref1

  1107     t <- gets lastType

  1108     case t of

  1109         BTRecord _ rs -> do

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

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

  1112         BTUnit -> withLastIdNamespace $ ref2C ref2

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

  1114 ref2C d@(Dereference ref) = do

  1115     r <- ref2C ref

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

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

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

  1119 ref2C f@(FunCall params ref) = do

  1120     r <- fref2C ref

  1121     t <- gets lastType

  1122     case t of

  1123         BTFunction _ bts t' -> do

  1124             ps <- liftM (parens . hsep . punctuate (char ',')) $

  1125                     if (length params) == (length bts) -- hot fix for pas2cSystem and pas2cRedo functions since they don't have params

  1126                     then

  1127                         mapM expr2CHelper (zip params bts)

  1128                     else mapM expr2C params

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

  1130             return $ r <> ps

  1131         _ -> case (ref, params) of

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

  1133                   _ -> error $ "ref2C FunCall erroneous type cast detected: " ++ show f ++ "\nType detected: " ++ show t ++ "\n" ++ show ref ++ "\n" ++ show params ++ "\n" ++ show t

  1134     where