tools/pas2c/Pas2C.hs
changeset 10113 b26c2772e754
parent 10111 459bc720cea1
child 10120 b7f632c12784
equal deleted inserted replaced
10111:459bc720cea1 10113:b26c2772e754
     5 import Data.Maybe
     5 import Data.Maybe
     6 import Data.Char
     6 import Data.Char
     7 import Text.Parsec.Prim hiding (State)
     7 import Text.Parsec.Prim hiding (State)
     8 import Control.Monad.State
     8 import Control.Monad.State
     9 import System.IO
     9 import System.IO
    10 import System.Directory
       
    11 import Control.Monad.IO.Class
       
    12 import PascalPreprocessor
    10 import PascalPreprocessor
    13 import Control.Exception
    11 import Control.Exception
    14 import System.IO.Error
    12 import System.IO.Error
    15 import qualified Data.Map as Map
    13 import qualified Data.Map as Map
    16 import qualified Data.Set as Set
    14 import qualified Data.Set as Set
    51         currentUnit :: String,
    49         currentUnit :: String,
    52         currentFunctionResult :: String,
    50         currentFunctionResult :: String,
    53         namespaces :: Map.Map String Records
    51         namespaces :: Map.Map String Records
    54     }
    52     }
    55 
    53 
       
    54 rec2Records :: [(String, BaseType)] -> [Record]
    56 rec2Records = map (\(a, b) -> Record a b empty)
    55 rec2Records = map (\(a, b) -> Record a b empty)
    57 
    56 
       
    57 emptyState :: Map.Map String Records -> RenderState
    58 emptyState = RenderState Map.empty "" BTUnknown False empty [] 0 Set.empty [] "" ""
    58 emptyState = RenderState Map.empty "" BTUnknown False empty [] 0 Set.empty [] "" ""
    59 
    59 
    60 getUniq :: State RenderState Int
    60 getUniq :: State RenderState Int
    61 getUniq = do
    61 getUniq = do
    62     i <- gets uniqCounter
    62     i <- gets uniqCounter
   100 pas2C fn inputPath outputPath alternateInputPath symbols = do
   100 pas2C fn inputPath outputPath alternateInputPath symbols = do
   101     s <- flip execStateT initState $ f fn
   101     s <- flip execStateT initState $ f fn
   102     renderCFiles s outputPath
   102     renderCFiles s outputPath
   103     where
   103     where
   104     printLn = liftIO . hPutStrLn stdout
   104     printLn = liftIO . hPutStrLn stdout
   105     print = liftIO . hPutStr stdout
   105     print' = liftIO . hPutStr stdout
   106     initState = Map.empty
   106     initState = Map.empty
   107     f :: String -> StateT (Map.Map String PascalUnit) IO ()
   107     f :: String -> StateT (Map.Map String PascalUnit) IO ()
   108     f fileName = do
   108     f fileName = do
   109         processed <- gets $ Map.member fileName
   109         processed <- gets $ Map.member fileName
   110         unless processed $ do
   110         unless processed $ do
   111             print ("Preprocessing '" ++ fileName ++ ".pas'... ")
   111             print' ("Preprocessing '" ++ fileName ++ ".pas'... ")
   112             fc' <- liftIO
   112             fc' <- liftIO
   113                 $ tryJust (guard . isDoesNotExistError)
   113                 $ tryJust (guard . isDoesNotExistError)
   114                 $ preprocess inputPath alternateInputPath (fileName ++ ".pas") symbols
   114                 $ preprocess inputPath alternateInputPath (fileName ++ ".pas") symbols
   115             case fc' of
   115             case fc' of
   116                 (Left a) -> do
   116                 (Left _) -> do
   117                     modify (Map.insert fileName (System []))
   117                     modify (Map.insert fileName (System []))
   118                     printLn "doesn't exist"
   118                     printLn "doesn't exist"
   119                 (Right fc) -> do
   119                 (Right fc) -> do
   120                     print "ok, parsing... "
   120                     print' "ok, parsing... "
   121                     let ptree = parse pascalUnit fileName fc
   121                     let ptree = parse pascalUnit fileName fc
   122                     case ptree of
   122                     case ptree of
   123                          (Left a) -> do
   123                          (Left a) -> do
   124                             liftIO $ writeFile (outputPath ++ "preprocess.out") fc
   124                             liftIO $ writeFile (outputPath ++ "preprocess.out") fc
   125                             printLn $ show a ++ "\nsee preprocess.out for preprocessed source"
   125                             printLn $ show a ++ "\nsee preprocess.out for preprocessed source"
   157 
   157 
   158 withState' :: (RenderState -> RenderState) -> State RenderState a -> State RenderState a
   158 withState' :: (RenderState -> RenderState) -> State RenderState a -> State RenderState a
   159 withState' f sf = do
   159 withState' f sf = do
   160     st <- liftM f get
   160     st <- liftM f get
   161     let (a, s) = runState sf st
   161     let (a, s) = runState sf st
   162     modify(\st -> st{
   162     modify(\st' -> st'{
   163         lastType = lastType s
   163         lastType = lastType s
   164         , uniqCounter = uniqCounter s
   164         , uniqCounter = uniqCounter s
   165         , stringConsts = stringConsts s
   165         , stringConsts = stringConsts s
   166         })
   166         })
   167     return a
   167     return a
   168 
   168 
       
   169 withLastIdNamespace :: State RenderState Doc -> State RenderState Doc
   169 withLastIdNamespace f = do
   170 withLastIdNamespace f = do
   170     li <- gets lastIdentifier
   171     li <- gets lastIdentifier
   171     nss <- gets namespaces
       
   172     withState' (\st -> st{currentScope = fromMaybe Map.empty $ Map.lookup li (namespaces st)}) f
   172     withState' (\st -> st{currentScope = fromMaybe Map.empty $ Map.lookup li (namespaces st)}) f
   173 
   173 
   174 withRecordNamespace :: String -> [Record] -> State RenderState Doc -> State RenderState Doc
   174 withRecordNamespace :: String -> [Record] -> State RenderState Doc -> State RenderState Doc
   175 withRecordNamespace _ [] = error "withRecordNamespace: empty record"
   175 withRecordNamespace _ [] = error "withRecordNamespace: empty record"
   176 withRecordNamespace prefix recs = withState' f
   176 withRecordNamespace prefix recs = withState' f
   177     where
   177     where
   178         f st = st{currentScope = Map.unionWith un records (currentScope st), currentUnit = ""}
   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
   179         records = Map.fromList $ map (\(Record a b d) -> (map toLower a, [Record (prefix ++ a) b d])) recs
   180         un [a] b = a : b
   180         un [a] b = a : b
       
   181         un _ _ = error "withRecordNamespace un: pattern not matched"
   181 
   182 
   182 toCFiles :: String -> Map.Map String Records -> (String, PascalUnit) -> IO ()
   183 toCFiles :: String -> Map.Map String Records -> (String, PascalUnit) -> IO ()
   183 toCFiles _ _ (_, System _) = return ()
   184 toCFiles _ _ (_, System _) = return ()
   184 toCFiles _ _ (_, Redo _) = return ()
   185 toCFiles _ _ (_, Redo _) = return ()
   185 toCFiles outputPath ns p@(fn, pu) = do
   186 toCFiles outputPath ns pu@(fileName, _) = do
   186     hPutStrLn stdout $ "Rendering '" ++ fn ++ "'..."
   187     hPutStrLn stdout $ "Rendering '" ++ fileName ++ "'..."
   187     toCFiles' p
   188     toCFiles' pu
   188     where
   189     where
   189     toCFiles' (fn, p@(Program {})) = writeFile (outputPath ++ fn ++ ".c") $ "#include \"fpcrtl.h\"\n" ++ (render2C initialState . pascal2C) p
   190     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     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         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             (a', _) = runState (id2C IOInsert (setBaseType BTUnit unitId) >> interface2C interface False) initialState{currentUnit = map toLower i ++ "_"}
   193             enumDecl = (renderEnum2Strs (enums s) False)
   194             enumDecl = (renderEnum2Strs (enums s) False)
   194             enumImpl = (renderEnum2Strs (enums s) True)
   195             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 ++ ".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         writeFile (outputPath ++ fn ++ ".c") $ "#include \"fpcrtl.h\"\n\n#include \"" ++ fn ++ ".h\"\n" ++ render (a' $+$ text "") ++ (render2C s . implementation2C) implementation ++ "\n" ++ enumImpl
       
   198     toCFiles' _ = undefined -- just pleasing compiler to not warn us
   197     initialState = emptyState ns
   199     initialState = emptyState ns
   198 
   200 
   199     render2C :: RenderState -> State RenderState Doc -> String
   201     render2C :: RenderState -> State RenderState Doc -> String
   200     render2C st p =
   202     render2C st p =
   201         let (a, s) = runState p st in
   203         let (a, _) = runState p st in
   202         render a
   204         render a
   203 
   205 
   204 renderEnum2Strs :: [(String, [String])] -> Bool -> String
   206 renderEnum2Strs :: [(String, [String])] -> Bool -> String
   205 renderEnum2Strs enums implement =
   207 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
   208     render $ foldl ($+$) empty $ map (\en -> let d = decl (fst en) in if implement then d $+$ enum2strBlock (snd en) else d <> semi) enums'
   207     where
   209     where
   208     decl id = text "string255 __attribute__((overloadable)) fpcrtl_GetEnumName" <> parens (text "int dummy, const" <+> text id <+> text "enumvar")
   210     decl id' = text "string255 __attribute__((overloadable)) fpcrtl_GetEnumName" <> parens (text "int dummy, const" <+> text id' <+> text "enumvar")
   209     enum2strBlock en =
   211     enum2strBlock en =
   210             text "{"
   212             text "{"
   211             $+$
   213             $+$
   212             (nest 4 $
   214             (nest 4 $
   213                 text "switch(enumvar){"
   215                 text "switch(enumvar){"
   228 usesFiles (Unit _ (Interface uses1 _) (Implementation uses2 _) _ _) = ["pas2cSystem", "pas2cRedo"] ++ uses2List uses1 ++ uses2List uses2
   230 usesFiles (Unit _ (Interface uses1 _) (Implementation uses2 _) _ _) = ["pas2cSystem", "pas2cRedo"] ++ uses2List uses1 ++ uses2List uses2
   229 usesFiles (System {}) = []
   231 usesFiles (System {}) = []
   230 usesFiles (Redo {}) = []
   232 usesFiles (Redo {}) = []
   231 
   233 
   232 pascal2C :: PascalUnit -> State RenderState Doc
   234 pascal2C :: PascalUnit -> State RenderState Doc
   233 pascal2C (Unit _ interface implementation init fin) =
   235 pascal2C (Unit _ interface implementation _ _) =
   234     liftM2 ($+$) (interface2C interface True) (implementation2C implementation)
   236     liftM2 ($+$) (interface2C interface True) (implementation2C implementation)
   235 
   237 
   236 pascal2C (Program _ implementation mainFunction) = do
   238 pascal2C (Program _ implementation mainFunction) = do
   237     impl <- implementation2C implementation
   239     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)))
   240     [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 
   241 
   240     return $ impl $+$ main
   242     return $ impl $+$ main
   241 
   243 
       
   244 pascal2C _ = error "pascal2C: pattern not matched"
   242 
   245 
   243 -- the second bool indicates whether do normal interface translation or generate variable declarations
   246 -- the second bool indicates whether do normal interface translation or generate variable declarations
   244 -- that will be inserted into implementation files
   247 -- that will be inserted into implementation files
   245 interface2C :: Interface -> Bool -> State RenderState Doc
   248 interface2C :: Interface -> Bool -> State RenderState Doc
   246 interface2C (Interface uses tvars) True = do
   249 interface2C (Interface uses tvars) True = do
   247     u <- uses2C uses
   250     u <- uses2C uses
   248     tv <- typesAndVars2C True True True tvars
   251     tv <- typesAndVars2C True True True tvars
   249     r <- renderStringConsts
   252     r <- renderStringConsts
   250     return (u $+$ r $+$ tv)
   253     return (u $+$ r $+$ tv)
   251 interface2C (Interface uses tvars) False = do
   254 interface2C (Interface uses tvars) False = do
   252     u <- uses2C uses
   255     void $ uses2C uses
   253     tv <- typesAndVars2C True False False tvars
   256     tv <- typesAndVars2C True False False tvars
   254     r <- renderStringConsts
   257     void $ renderStringConsts
   255     return tv
   258     return tv
   256 
   259 
   257 implementation2C :: Implementation -> State RenderState Doc
   260 implementation2C :: Implementation -> State RenderState Doc
   258 implementation2C (Implementation uses tvars) = do
   261 implementation2C (Implementation uses tvars) = do
   259     u <- uses2C uses
   262     u <- uses2C uses
   263 
   266 
   264 checkDuplicateFunDecls :: [TypeVarDeclaration] -> State RenderState ()
   267 checkDuplicateFunDecls :: [TypeVarDeclaration] -> State RenderState ()
   265 checkDuplicateFunDecls tvs =
   268 checkDuplicateFunDecls tvs =
   266     modify $ \s -> s{toMangle = Map.keysSet . Map.filter (> 1) . foldr ins initMap $ tvs}
   269     modify $ \s -> s{toMangle = Map.keysSet . Map.filter (> 1) . foldr ins initMap $ tvs}
   267     where
   270     where
       
   271         initMap :: Map.Map String Int
   268         initMap = Map.empty
   272         initMap = Map.empty
   269         --initMap = Map.fromList [("reset", 2)]
   273         --initMap = Map.fromList [("reset", 2)]
   270         ins (FunctionDeclaration (Identifier i _) _ _ _ _ _) m = Map.insertWith (+) (map toLower i) 1 m
   274         ins (FunctionDeclaration (Identifier i _) _ _ _ _ _) m = Map.insertWith (+) (map toLower i) 1 m
   271         ins _ m = m
   275         ins _ m = m
   272 
   276 
   295 
   299 
   296 uses2List :: Uses -> [String]
   300 uses2List :: Uses -> [String]
   297 uses2List (Uses ids) = map (\(Identifier i _) -> i) ids
   301 uses2List (Uses ids) = map (\(Identifier i _) -> i) ids
   298 
   302 
   299 
   303 
       
   304 setLastIdValues :: Record -> RenderState -> RenderState
   300 setLastIdValues vv = (\s -> s{lastType = baseType vv, lastIdentifier = lcaseId vv, lastIdTypeDecl = typeDecl vv})
   305 setLastIdValues vv = (\s -> s{lastType = baseType vv, lastIdentifier = lcaseId vv, lastIdTypeDecl = typeDecl vv})
   301 
   306 
   302 id2C :: InsertOption -> Identifier -> State RenderState Doc
   307 id2C :: InsertOption -> Identifier -> State RenderState Doc
   303 id2C IOInsert i = id2C (IOInsertWithType empty) i
   308 id2C IOInsert i = id2C (IOInsertWithType empty) i
   304 id2C (IOInsertWithType d) (Identifier i t) = do
   309 id2C (IOInsertWithType d) (Identifier i t) = do
   305     ns <- gets currentScope
       
   306     tom <- gets (Set.member n . toMangle)
   310     tom <- gets (Set.member n . toMangle)
   307     cu <- gets currentUnit
   311     cu <- gets currentUnit
   308     let (i', t') = case (t, tom) of
   312     let (i', t') = case (t, tom) of
   309             (BTFunction _ p _, True) -> (cu ++ i ++ ('_' : show (length p)), t)
   313             (BTFunction _ p _, True) -> (cu ++ i ++ ('_' : show (length p)), t)
   310             (BTFunction _ _ _, _) -> (cu ++ i, t)
   314             (BTFunction _ _ _, _) -> (cu ++ i, t)
   311             (BTVarParam t', _) -> ('(' : '*' : i ++ ")" , t')
   315             (BTVarParam t'', _) -> ('(' : '*' : i ++ ")" , t'')
   312             _ -> (i, t)
   316             _ -> (i, t)
   313     modify (\s -> s{currentScope = Map.insertWith (++) n [Record i' t' d] (currentScope s), lastIdentifier = n})
   317     modify (\s -> s{currentScope = Map.insertWith (++) n [Record i' t' d] (currentScope s), lastIdentifier = n})
   314     return $ text i'
   318     return $ text i'
   315     where
   319     where
   316         n = map toLower i
   320         n = map toLower i
   317 
   321 
   318 id2C IOLookup i = id2CLookup head i
   322 id2C IOLookup i = id2CLookup head i
   319 id2C IOLookupLast i = id2CLookup last i
   323 id2C IOLookupLast i = id2CLookup last i
   320 id2C (IOLookupFunction params) (Identifier i t) = do
   324 id2C (IOLookupFunction params) (Identifier i _) = do
   321     let i' = map toLower i
   325     let i' = map toLower i
   322     v <- gets $ Map.lookup i' . currentScope
   326     v <- gets $ Map.lookup i' . currentScope
   323     lt <- gets lastType
   327     lt <- gets lastType
   324     if isNothing v then
   328     if isNothing v then
   325         error $ "Not defined: '" ++ i' ++ "'\n" ++ show lt ++ "\nwith num of params = " ++ show params ++ "\n" ++ show v
   329         error $ "Not defined: '" ++ i' ++ "'\n" ++ show lt ++ "\nwith num of params = " ++ show params ++ "\n" ++ show v
   327         let vv = fromMaybe (head $ fromJust v) . find checkParam $ fromJust v in
   331         let vv = fromMaybe (head $ fromJust v) . find checkParam $ fromJust v in
   328             modify (setLastIdValues vv) >> (return . text . lcaseId $ vv)
   332             modify (setLastIdValues vv) >> (return . text . lcaseId $ vv)
   329     where
   333     where
   330         checkParam (Record _ (BTFunction _ p _) _) = (length p) == params
   334         checkParam (Record _ (BTFunction _ p _) _) = (length p) == params
   331         checkParam _ = False
   335         checkParam _ = False
   332 id2C IODeferred (Identifier i t) = do
   336 id2C IODeferred (Identifier i _) = do
   333     let i' = map toLower i
   337     let i' = map toLower i
   334     v <- gets $ Map.lookup i' . currentScope
   338     v <- gets $ Map.lookup i' . currentScope
   335     if (isNothing v) then
   339     if (isNothing v) then
   336         modify (\s -> s{lastType = BTUnknown, lastIdentifier = i}) >> return (text i)
   340         modify (\s -> s{lastType = BTUnknown, lastIdentifier = i}) >> return (text i)
   337         else
   341         else
   338         let vv = head $ fromJust v in modify (setLastIdValues vv) >> (return . text . lcaseId $ vv)
   342         let vv = head $ fromJust v in modify (setLastIdValues vv) >> (return . text . lcaseId $ vv)
   339 
   343 
   340 id2CLookup :: ([Record] -> Record) -> Identifier -> State RenderState Doc
   344 id2CLookup :: ([Record] -> Record) -> Identifier -> State RenderState Doc
   341 id2CLookup f (Identifier i t) = do
   345 id2CLookup f (Identifier i _) = do
   342     let i' = map toLower i
   346     let i' = map toLower i
   343     v <- gets $ Map.lookup i' . currentScope
   347     v <- gets $ Map.lookup i' . currentScope
   344     lt <- gets lastType
   348     lt <- gets lastType
   345     if isNothing v then
   349     if isNothing v then
   346         error $ "Not defined: '" ++ i' ++ "'\n" ++ show lt
   350         error $ "Not defined: '" ++ i' ++ "'\n" ++ show lt
   403     tvs <- mapM f (concat $ tv : fromMaybe [] mtvs)
   407     tvs <- mapM f (concat $ tv : fromMaybe [] mtvs)
   404     return . BTRecord "" . concat $ tvs
   408     return . BTRecord "" . concat $ tvs
   405     where
   409     where
   406         f :: TypeVarDeclaration -> State RenderState [(String, BaseType)]
   410         f :: TypeVarDeclaration -> State RenderState [(String, BaseType)]
   407         f (VarDeclaration _ _ (ids, td) _) = mapM (\(Identifier i _) -> liftM ((,) i) $ resolveType td) ids
   411         f (VarDeclaration _ _ (ids, td) _) = mapM (\(Identifier i _) -> liftM ((,) i) $ resolveType td) ids
       
   412         f _ = error "resolveType f: pattern not matched"
   408 resolveType (ArrayDecl (Just i) t) = do
   413 resolveType (ArrayDecl (Just i) t) = do
   409     t' <- resolveType t
   414     t' <- resolveType t
   410     return $ BTArray i (BTInt True) t'
   415     return $ BTArray i (BTInt True) t'
   411 resolveType (ArrayDecl Nothing t) = liftM (BTArray RangeInfinite (BTInt True)) $ resolveType t
   416 resolveType (ArrayDecl Nothing t) = liftM (BTArray RangeInfinite (BTInt True)) $ resolveType t
   412 resolveType (FunctionType t a) = do
   417 resolveType (FunctionType t a) = do
   442 fromPointer s (BTPointerTo t) = resolve s t
   447 fromPointer s (BTPointerTo t) = resolve s t
   443 fromPointer s t = do
   448 fromPointer s t = do
   444     error $ "Dereferencing from non-pointer type " ++ show t ++ "\n" ++ s
   449     error $ "Dereferencing from non-pointer type " ++ show t ++ "\n" ++ s
   445 
   450 
   446 
   451 
       
   452 functionParams2C :: [TypeVarDeclaration] -> State RenderState Doc
   447 functionParams2C params = liftM (hcat . punctuate comma . concat) $ mapM (tvar2C False False True True) params
   453 functionParams2C params = liftM (hcat . punctuate comma . concat) $ mapM (tvar2C False False True True) params
   448 
   454 
   449 numberOfDeclarations :: [TypeVarDeclaration] -> Int
   455 numberOfDeclarations :: [TypeVarDeclaration] -> Int
   450 numberOfDeclarations = sum . map cnt
   456 numberOfDeclarations = sum . map cnt
   451     where
   457     where
   471         abc = hcat . punctuate comma . map (char . fst) $ ps
   477         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
   478         cparams = hcat . punctuate comma . map (\(c, v) -> if v then char '&' <> parens (char c) else char c) $ ps
   473         ps = zip ['a'..] (toIsVarList params)
   479         ps = zip ['a'..] (toIsVarList params)
   474 
   480 
   475 fun2C :: Bool -> String -> TypeVarDeclaration -> State RenderState [Doc]
   481 fun2C :: Bool -> String -> TypeVarDeclaration -> State RenderState [Doc]
   476 fun2C _ _ (FunctionDeclaration name inline overload returnType params Nothing) = do
   482 fun2C _ _ (FunctionDeclaration name _ overload returnType params Nothing) = do
   477     t <- type2C returnType
   483     t <- type2C returnType
   478     t'<- gets lastType
   484     t'<- gets lastType
   479     bts <- typeVarDecl2BaseType params
   485     bts <- typeVarDecl2BaseType params
   480     p <- withState' id $ functionParams2C params
   486     p <- withState' id $ functionParams2C params
   481     n <- liftM render . id2C IOInsert $ setBaseType (BTFunction False bts t') name
   487     n <- liftM render . id2C IOInsert $ setBaseType (BTFunction False bts t') name
   482     let decor = if overload then text "__attribute__((overloadable))" else empty
   488     let decor = if overload then text "__attribute__((overloadable))" else empty
   483     return [t empty <+> decor <+> text n <> parens p]
   489     return [t empty <+> decor <+> text n <> parens p]
   484 
   490 
   485 fun2C True rv (FunctionDeclaration name@(Identifier i bt) inline overload returnType params (Just (tvars, phrase))) = do
   491 fun2C True rv (FunctionDeclaration name@(Identifier i _) inline overload returnType params (Just (tvars, phrase))) = do
   486     let isVoid = case returnType of
   492     let isVoid = case returnType of
   487             VoidType -> True
   493             VoidType -> True
   488             _ -> False
   494             _ -> False
   489 
   495 
   490     let res = docToLower $ text rv <> if isVoid then empty else text "_result"
   496     let res = docToLower $ text rv <> if isVoid then empty else text "_result"
   491     t <- type2C returnType
   497     t <- type2C returnType
   492     t' <- gets lastType
   498     t' <- gets lastType
   493 
   499 
   494     bts <- typeVarDecl2BaseType params
   500     bts <- typeVarDecl2BaseType params
   495     cu <- gets currentUnit
   501     --cu <- gets currentUnit
   496     notDeclared <- liftM isNothing . gets $ Map.lookup (map toLower i) . currentScope
   502     notDeclared <- liftM isNothing . gets $ Map.lookup (map toLower i) . currentScope
   497 
   503 
   498     n <- liftM render . id2C IOInsert $ setBaseType (BTFunction hasVars bts t') name
   504     n <- liftM render . id2C IOInsert $ setBaseType (BTFunction hasVars bts t') name
   499     let resultId = if isVoid
   505     let resultId = if isVoid
   500                     then n -- void type doesn't have result, solving recursive procedure calls
   506                     then n -- void type doesn't have result, solving recursive procedure calls
   505         p <- functionParams2C params
   511         p <- functionParams2C params
   506         ph <- liftM2 ($+$) (typesAndVars2C False False True tvars) (phrase2C' phrase)
   512         ph <- liftM2 ($+$) (typesAndVars2C False False True tvars) (phrase2C' phrase)
   507         return (p, ph)
   513         return (p, ph)
   508 
   514 
   509     let phrasesBlock = if isVoid then ph else t empty <+> res <> semi $+$ ph $+$ text "return" <+> res <> semi
   515     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
   516     --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
   517     let inlineDecor = if inline then case notDeclared of
   512                                     True -> text "static inline"
   518                                     True -> text "static inline"
   513                                     False -> text "inline"
   519                                     False -> text "inline"
   514                           else empty
   520                           else empty
   515         overloadDecor = if overload then text "__attribute__((overloadable))" else empty
   521         overloadDecor = if overload then text "__attribute__((overloadable))" else empty
   526         text "}"]
   532         text "}"]
   527     where
   533     where
   528     phrase2C' (Phrases p) = liftM vcat $ mapM phrase2C p
   534     phrase2C' (Phrases p) = liftM vcat $ mapM phrase2C p
   529     phrase2C' p = phrase2C p
   535     phrase2C' p = phrase2C p
   530     un [a] b = a : b
   536     un [a] b = a : b
       
   537     un _ _ = error "fun2C u: pattern not matched"
   531     hasVars = hasPassByReference params
   538     hasVars = hasPassByReference params
   532 
   539 
   533 fun2C False _ (FunctionDeclaration (Identifier name _) _ _ _ _ _) = error $ "nested functions not allowed: " ++ name
   540 fun2C False _ (FunctionDeclaration (Identifier name _) _ _ _ _ _) = error $ "nested functions not allowed: " ++ name
   534 fun2C _ tv _ = error $ "fun2C: I don't render " ++ show tv
   541 fun2C _ tv _ = error $ "fun2C: I don't render " ++ show tv
   535 
   542 
   538 -- the fourth bool indicates whether ignore initialization or not (basically for dynamic arrays since we cannot do initialization in function params)
   545 -- 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]
   546 tvar2C :: Bool -> Bool -> Bool -> Bool -> TypeVarDeclaration -> State RenderState [Doc]
   540 tvar2C b _ includeType _ f@(FunctionDeclaration (Identifier name _) _ _ _ _ _) = do
   547 tvar2C b _ includeType _ f@(FunctionDeclaration (Identifier name _) _ _ _ _ _) = do
   541     t <- fun2C b name f
   548     t <- fun2C b name f
   542     if includeType then return t else return []
   549     if includeType then return t else return []
   543 tvar2C _ _ includeType _ td@(TypeDeclaration i' t) = do
   550 tvar2C _ _ includeType _ (TypeDeclaration i' t) = do
   544     i <- id2CTyped t i'
   551     i <- id2CTyped t i'
   545     tp <- type2C t
   552     tp <- type2C t
   546     let res = if includeType then [text "typedef" <+> tp i] else []
   553     let res = if includeType then [text "typedef" <+> tp i] else []
   547     case t of
   554     case t of
   548         (Sequence ids) -> do
   555         (Sequence ids) -> do
   549             modify(\s -> s{enums = (render i, map (\(Identifier i _) -> i) ids) : enums s})
   556             modify(\s -> s{enums = (render i, map (\(Identifier id' _) -> id') ids) : enums s})
   550             return res
   557             return res
   551         _ -> return res
   558         _ -> return res
   552 
   559 
   553 tvar2C _ _ _ _ (VarDeclaration True _ (ids, t) Nothing) = do
   560 tvar2C _ _ _ _ (VarDeclaration True _ (ids, t) Nothing) = do
   554     t' <- liftM ((empty <+>) . ) $ type2C t
   561     t' <- liftM ((empty <+>) . ) $ type2C t
   565          (True, BTInt _, [i], Just _) -> do
   572          (True, BTInt _, [i], Just _) -> do
   566              i' <- id2CTyped t i
   573              i' <- id2CTyped t i
   567              return $ if includeType then [text "enum" <> braces (i' <+> ie)] else []
   574              return $ if includeType then [text "enum" <> braces (i' <+> ie)] else []
   568          (True, BTFloat, [i], Just e) -> do
   575          (True, BTFloat, [i], Just e) -> do
   569              i' <- id2CTyped t i
   576              i' <- id2CTyped t i
   570              ie <- initExpr2C e
   577              ie' <- initExpr2C e
   571              return $ if includeType then [text "#define" <+> i' <+> parens ie <> text "\n"] else []
   578              return $ if includeType then [text "#define" <+> i' <+> parens ie' <> text "\n"] else []
   572          (_, BTFunction{}, _, Nothing) -> liftM (map(\i -> t' i)) $ mapM (id2CTyped t) ids
   579          (_, BTFunction{}, _, Nothing) -> liftM (map(\i -> t' i)) $ mapM (id2CTyped t) ids
   573          (_, BTArray r _ _, [i], _) -> do
   580          (_, BTArray r _ _, [i], _) -> do
   574             i' <- id2CTyped t i
   581             i' <- id2CTyped t i
   575             ie' <- return $ case (r, mInitExpr, ignoreInit) of
   582             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
   583                 (RangeInfinite, Nothing, False) -> text "= NULL" -- force dynamic array to be initialized as NULL if not initialized at all
   577                 (_, _, _) -> ie
   584                 (_, _, _) -> ie
   578             result <- liftM (map(\i -> varDeclDecision isConst includeType (t' i) ie')) $ mapM (id2CTyped t) ids
   585             result <- liftM (map(\id' -> varDeclDecision isConst includeType (t' id') ie')) $ mapM (id2CTyped t) ids
   579             case (r, ignoreInit) of
   586             case (r, ignoreInit) of
   580                 (RangeInfinite, False) ->
   587                 (RangeInfinite, False) ->
   581                     -- if the array is dynamic, add dimension info to it
   588                     -- if the array is dynamic, add dimension info to it
   582                     return $ [dimDecl] ++ result
   589                     return $ [dimDecl] ++ result
   583                     where
   590                     where
   592     initExpr Nothing = return $ empty
   599     initExpr Nothing = return $ empty
   593     initExpr (Just e) = liftM (text "=" <+>) (initExpr2C e)
   600     initExpr (Just e) = liftM (text "=" <+>) (initExpr2C e)
   594     varDeclDecision True True varStr expStr = varStr <+> expStr
   601     varDeclDecision True True varStr expStr = varStr <+> expStr
   595     varDeclDecision False True varStr expStr = if externVar then varStr else varStr <+> expStr
   602     varDeclDecision False True varStr expStr = if externVar then varStr else varStr <+> expStr
   596     varDeclDecision False False varStr expStr = varStr <+> expStr
   603     varDeclDecision False False varStr expStr = varStr <+> expStr
   597     varDeclDecision True False varStr expStr = empty
   604     varDeclDecision True False _ _ = empty
   598     arrayDimension a = case a of
   605     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
   606         ArrayDecl Nothing t' -> let a' = arrayDimension t' in 
       
   607                                    if a' > 3 then error "Dynamic array with dimension > 4 is not supported." else 1 + a'
   600         ArrayDecl _ _ -> error "Mixed dynamic array and static array are not supported."
   608         ArrayDecl _ _ -> error "Mixed dynamic array and static array are not supported."
   601         _ -> 0
   609         _ -> 0
   602 
   610 
   603 tvar2C f _ _ _ (OperatorDeclaration op (Identifier i _) inline ret params body) = do
   611 tvar2C f _ _ _ (OperatorDeclaration op (Identifier i _) inline ret params body) = do
   604     r <- op2CTyped op (extractTypes params)
   612     r <- op2CTyped op (extractTypes params)
   605     fun2C f i (FunctionDeclaration r inline False ret params body)
   613     fun2C f i (FunctionDeclaration r inline False ret params body)
   606 
   614 
   607 
   615 
   608 op2CTyped :: String -> [TypeDecl] -> State RenderState Identifier
   616 op2CTyped :: String -> [TypeDecl] -> State RenderState Identifier
   609 op2CTyped op t = do
   617 op2CTyped op t = do
   610     t' <- liftM (render . hcat . punctuate (char '_') . map (\t -> t empty)) $ mapM type2C t
   618     t' <- liftM (render . hcat . punctuate (char '_') . map (\txt -> txt empty)) $ mapM type2C t
   611     bt <- gets lastType
   619     bt <- gets lastType
   612     return $ Identifier (t' ++ "_op_" ++ opStr) bt
   620     return $ Identifier (t' ++ "_op_" ++ opStr) bt
   613     where
   621     where
   614     opStr = case op of
   622     opStr = case op of
   615                     "+" -> "add"
   623                     "+" -> "add"
   643 initExpr2C' (InitBinOp op expr1 expr2) = do
   651 initExpr2C' (InitBinOp op expr1 expr2) = do
   644     e1 <- initExpr2C' expr1
   652     e1 <- initExpr2C' expr1
   645     e2 <- initExpr2C' expr2
   653     e2 <- initExpr2C' expr2
   646     return $ parens $ e1 <+> text (op2C op) <+> e2
   654     return $ parens $ e1 <+> text (op2C op) <+> e2
   647 initExpr2C' (InitNumber s) = do
   655 initExpr2C' (InitNumber s) = do
   648                                 modify(\s -> s{lastType = (BTInt True)})
   656                                 modify(\st -> st{lastType = (BTInt True)})
   649                                 return $ text s
   657                                 return $ text s
   650 initExpr2C' (InitFloat s) = return $ text s
   658 initExpr2C' (InitFloat s) = return $ text s
   651 initExpr2C' (InitHexNumber s) = return $ text "0x" <> (text . map toLower $ s)
   659 initExpr2C' (InitHexNumber s) = return $ text "0x" <> (text . map toLower $ s)
   652 initExpr2C' (InitString [a]) = return . quotes $ text [a]
   660 initExpr2C' (InitString [a]) = return . quotes $ text [a]
   653 initExpr2C' (InitString s) = return $ strInit s
   661 initExpr2C' (InitString s) = return $ strInit s
   658     return $ lbrace $+$ (nest 4 . vcat . punctuate comma $ fs) $+$ rbrace
   666     return $ lbrace $+$ (nest 4 . vcat . punctuate comma $ fs) $+$ rbrace
   659 --initExpr2C' (InitArray [InitRecord fields]) = do
   667 --initExpr2C' (InitArray [InitRecord fields]) = do
   660 --    e <- initExpr2C $ InitRecord fields
   668 --    e <- initExpr2C $ InitRecord fields
   661 --    return $ braces $ e
   669 --    return $ braces $ e
   662 initExpr2C' r@(InitRange (Range i@(Identifier i' _))) = do
   670 initExpr2C' r@(InitRange (Range i@(Identifier i' _))) = do
   663     id2C IOLookup i
   671     void $ id2C IOLookup i
   664     t <- gets lastType
   672     t <- gets lastType
   665     case t of
   673     case t of
   666          BTEnum s -> return . int $ length s
   674          BTEnum s -> return . int $ length s
   667          BTInt _ -> case i' of
   675          BTInt _ -> case i' of
   668                        "byte" -> return $ int 256
   676                        "byte" -> return $ int 256
   670          _ -> error $ "InitRange: " ++ show r
   678          _ -> error $ "InitRange: " ++ show r
   671 initExpr2C' (InitRange (RangeFromTo (InitNumber "0") r)) = initExpr2C $ BuiltInFunction "succ" [r]
   679 initExpr2C' (InitRange (RangeFromTo (InitNumber "0") r)) = initExpr2C $ BuiltInFunction "succ" [r]
   672 initExpr2C' (InitRange (RangeFromTo (InitChar "0") (InitChar r))) = initExpr2C $ BuiltInFunction "succ" [InitNumber r]
   680 initExpr2C' (InitRange (RangeFromTo (InitChar "0") (InitChar r))) = initExpr2C $ BuiltInFunction "succ" [InitNumber r]
   673 initExpr2C' (InitRange a) = error $ show a --return $ text "<<range>>"
   681 initExpr2C' (InitRange a) = error $ show a --return $ text "<<range>>"
   674 initExpr2C' (InitSet []) = return $ text "0"
   682 initExpr2C' (InitSet []) = return $ text "0"
   675 initExpr2C' (InitSet a) = return $ text "<<set>>"
   683 initExpr2C' (InitSet _) = return $ text "<<set>>"
   676 initExpr2C' (BuiltInFunction "low" [InitReference e]) = return $
   684 initExpr2C' (BuiltInFunction "low" [InitReference e]) = return $
   677     case e of
   685     case e of
   678          (Identifier "LongInt" _) -> int (-2^31)
   686          (Identifier "LongInt" _) -> int (-2^31)
   679          (Identifier "SmallInt" _) -> int (-2^15)
   687          (Identifier "SmallInt" _) -> int (-2^15)
   680          _ -> error $ "BuiltInFunction 'low': " ++ show e
   688          _ -> error $ "BuiltInFunction 'low': " ++ show e
   681 initExpr2C' (BuiltInFunction "high" [e]) = do
   689 initExpr2C' (BuiltInFunction "high" [e]) = do
   682     initExpr2C e
   690     void $ initExpr2C e
   683     t <- gets lastType
   691     t <- gets lastType
   684     case t of
   692     case t of
   685          (BTArray i _ _) -> initExpr2C' $ BuiltInFunction "pred" [InitRange i]
   693          (BTArray i _ _) -> initExpr2C' $ BuiltInFunction "pred" [InitRange i]
   686          a -> error $ "BuiltInFunction 'high': " ++ show a
   694          a -> error $ "BuiltInFunction 'high': " ++ show a
   687 initExpr2C' (BuiltInFunction "succ" [BuiltInFunction "pred" [e]]) = initExpr2C' e
   695 initExpr2C' (BuiltInFunction "succ" [BuiltInFunction "pred" [e]]) = initExpr2C' e
   703 baseType2C _ BTBool = text "bool"
   711 baseType2C _ BTBool = text "bool"
   704 baseType2C _ BTString = text "string255"
   712 baseType2C _ BTString = text "string255"
   705 baseType2C s a = error $ "baseType2C: " ++ show a ++ "\n" ++ s
   713 baseType2C s a = error $ "baseType2C: " ++ show a ++ "\n" ++ s
   706 
   714 
   707 type2C :: TypeDecl -> State RenderState (Doc -> Doc)
   715 type2C :: TypeDecl -> State RenderState (Doc -> Doc)
   708 type2C (SimpleType i) = liftM (\i a -> i <+> a) $ id2C IOLookup i
   716 type2C (SimpleType i) = liftM (\i' a -> i' <+> a) $ id2C IOLookup i
   709 type2C t = do
   717 type2C t = do
   710     r <- type2C' t
   718     r <- type2C' t
   711     rt <- resolveType t
   719     rt <- resolveType t
   712     modify (\st -> st{lastType = rt})
   720     modify (\st -> st{lastType = rt})
   713     return r
   721     return r
   719         lt <- gets lastType
   727         lt <- gets lastType
   720         case lt of
   728         case lt of
   721              BTRecord _ _ -> return $ \a -> text "struct __" <> i' <+> text "*" <+> a
   729              BTRecord _ _ -> return $ \a -> text "struct __" <> i' <+> text "*" <+> a
   722              BTUnknown -> return $ \a -> text "struct __" <> i' <+> text "*" <+> a
   730              BTUnknown -> return $ \a -> text "struct __" <> i' <+> text "*" <+> a
   723              _ -> return $ \a -> i' <+> text "*" <+> a
   731              _ -> return $ \a -> i' <+> text "*" <+> a
   724     type2C' (PointerTo t) = liftM (\t a -> t (parens $ text "*" <> a)) $ type2C t
   732     type2C' (PointerTo t) = liftM (\tx a -> tx (parens $ text "*" <> a)) $ type2C t
   725     type2C' (RecordType tvs union) = do
   733     type2C' (RecordType tvs union) = do
   726         t <- withState' f $ mapM (tvar2C False False True False) tvs
   734         t' <- withState' f $ mapM (tvar2C False False True False) tvs
   727         u <- unions
   735         u <- unions
   728         return $ \i -> text "struct __" <> i <+> lbrace $+$ nest 4 ((vcat . map (<> semi) . concat $ t) $$ u) $+$ rbrace <+> i
   736         return $ \i -> text "struct __" <> i <+> lbrace $+$ nest 4 ((vcat . map (<> semi) . concat $ t') $$ u) $+$ rbrace <+> i
   729         where
   737         where
   730             f s = s{currentUnit = ""}
   738             f s = s{currentUnit = ""}
   731             unions = case union of
   739             unions = case union of
   732                      Nothing -> return empty
   740                      Nothing -> return empty
   733                      Just a -> do
   741                      Just a -> do
   734                          structs <- mapM struct2C a
   742                          structs <- mapM struct2C a
   735                          return $ text "union" $+$ braces (nest 4 $ vcat structs) <> semi
   743                          return $ text "union" $+$ braces (nest 4 $ vcat structs) <> semi
   736             struct2C tvs = do
   744             struct2C stvs = do
   737                 t <- withState' f $ mapM (tvar2C False False True False) tvs
   745                 txts <- withState' f $ mapM (tvar2C False False True False) stvs
   738                 return $ text "struct" $+$ braces (nest 4 (vcat . map (<> semi) . concat $ t)) <> semi
   746                 return $ text "struct" $+$ braces (nest 4 (vcat . map (<> semi) . concat $ txts)) <> semi
   739     type2C' (RangeType r) = return (text "int" <+>)
   747     type2C' (RangeType r) = return (text "int" <+>)
   740     type2C' (Sequence ids) = do
   748     type2C' (Sequence ids) = do
   741         is <- mapM (id2C IOInsert . setBaseType bt) ids
   749         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..]) <+>)
   750         return (text "enum" <+> (braces . vcat . punctuate comma . map (\(a, b) -> a <+> equals <+> text "0x" <> text (showHex b "")) $ zip is [0..]) <+>)
   743         where
   751         where
   766     type2C' (DeriveType r@(InitReference {})) = do
   774     type2C' (DeriveType r@(InitReference {})) = do
   767         initExpr2C r
   775         initExpr2C r
   768         t <- gets lastType
   776         t <- gets lastType
   769         return (baseType2C (show r) t <+>)
   777         return (baseType2C (show r) t <+>)
   770     type2C' (DeriveType a) = error $ "Can't derive type from " ++ show a
   778     type2C' (DeriveType a) = error $ "Can't derive type from " ++ show a
       
   779     type2C' a = error $ "type2C: unknown type " ++ show a
   771 
   780 
   772 phrase2C :: Phrase -> State RenderState Doc
   781 phrase2C :: Phrase -> State RenderState Doc
   773 phrase2C (Phrases p) = do
   782 phrase2C (Phrases p) = do
   774     ps <- mapM phrase2C p
   783     ps <- mapM phrase2C p
   775     return $ text "{" $+$ (nest 4 . vcat $ ps) $+$ text "}"
   784     return $ text "{" $+$ (nest 4 . vcat $ ps) $+$ text "}"
   776 phrase2C (ProcCall f@(FunCall {}) []) = liftM (<> semi) $ ref2C f
   785 phrase2C (ProcCall f@(FunCall {}) []) = liftM (<> semi) $ ref2C f
   777 phrase2C (ProcCall ref []) = liftM (<> semi) $ ref2CF ref True
   786 phrase2C (ProcCall ref []) = liftM (<> semi) $ ref2CF ref True
   778 phrase2C (ProcCall ref params) = error $ "ProcCall"{-do
   787 phrase2C (ProcCall _ _) = error $ "ProcCall"{-do
   779     r <- ref2C ref
   788     r <- ref2C ref
   780     ps <- mapM expr2C params
   789     ps <- mapM expr2C params
   781     return $ r <> parens (hsep . punctuate (char ',') $ ps) <> semi -}
   790     return $ r <> parens (hsep . punctuate (char ',') $ ps) <> semi -}
   782 phrase2C (IfThenElse (expr) phrase1 mphrase2) = do
   791 phrase2C (IfThenElse (expr) phrase1 mphrase2) = do
   783     e <- expr2C expr
   792     e <- expr2C expr
   794     case (t, expr) of
   803     case (t, expr) of
   795         (BTFunction {}, (Reference r')) -> do
   804         (BTFunction {}, (Reference r')) -> do
   796             e <- ref2C r'
   805             e <- ref2C r'
   797             return $ r <+> text "=" <+> e <> semi
   806             return $ r <+> text "=" <+> e <> semi
   798         (BTString, _) -> do
   807         (BTString, _) -> do
   799             e <- expr2C expr
   808             void $ expr2C expr
   800             lt <- gets lastType
   809             lt <- gets lastType
   801             case lt of
   810             case lt of
   802                 -- assume pointer to char for simplicity
   811                 -- assume pointer to char for simplicity
   803                 BTPointerTo _ -> do
   812                 BTPointerTo _ -> do
   804                     e <- expr2C $ Reference $ FunCall [Reference $ RefExpression expr] (SimpleReference (Identifier "pchar2str" BTUnknown))
   813                     e <- expr2C $ Reference $ FunCall [Reference $ RefExpression expr] (SimpleReference (Identifier "pchar2str" BTUnknown))
   808                     return $ r <+> text "=" <+> e <> semi
   817                     return $ r <+> text "=" <+> e <> semi
   809                 _ -> error $ "Assignment to string from " ++ show asgn
   818                 _ -> error $ "Assignment to string from " ++ show asgn
   810         (BTArray _ _ _, _) -> do
   819         (BTArray _ _ _, _) -> do
   811             case expr of
   820             case expr of
   812                 Reference er -> do
   821                 Reference er -> do
   813                     exprRef <- ref2C er
   822                     void $ ref2C er
   814                     exprT <- gets lastType
   823                     exprT <- gets lastType
   815                     case exprT of
   824                     case exprT of
   816                         BTArray RangeInfinite _ _ ->
   825                         BTArray RangeInfinite _ _ ->
   817                             return $ text "FIXME: assign a dynamic array to an array"
   826                             return $ text "FIXME: assign a dynamic array to an array"
   818                         BTArray _ _ _ -> phrase2C $
   827                         BTArray _ _ _ -> phrase2C $
   902 wrapPhrase p@(Phrases _) = p
   911 wrapPhrase p@(Phrases _) = p
   903 wrapPhrase p = Phrases [p]
   912 wrapPhrase p = Phrases [p]
   904 
   913 
   905 expr2C :: Expression -> State RenderState Doc
   914 expr2C :: Expression -> State RenderState Doc
   906 expr2C (Expression s) = return $ text s
   915 expr2C (Expression s) = return $ text s
   907 expr2C b@(BinOp op expr1 expr2) = do
   916 expr2C (BinOp op expr1 expr2) = do
   908     e1 <- expr2C expr1
   917     e1 <- expr2C expr1
   909     t1 <- gets lastType
   918     t1 <- gets lastType
   910     e2 <- expr2C expr2
   919     e2 <- expr2C expr2
   911     t2 <- gets lastType
   920     t2 <- gets lastType
   912     case (op2C op, t1, t2) of
   921     case (op2C op, t1, t2) of
  1004 
  1013 
  1005 expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "low" _))) = do
  1014 expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "low" _))) = do
  1006     e' <- liftM (map toLower . render) $ expr2C e
  1015     e' <- liftM (map toLower . render) $ expr2C e
  1007     lt <- gets lastType
  1016     lt <- gets lastType
  1008     case lt of
  1017     case lt of
  1009          BTEnum a -> return $ int 0
  1018          BTEnum _-> return $ int 0
  1010          BTInt _ -> case e' of
  1019          BTInt _ -> case e' of
  1011                   "longint" -> return $ int (-2147483648)
  1020                   "longint" -> return $ int (-2147483648)
  1012          BTArray {} -> return $ int 0
  1021          BTArray {} -> return $ int 0
  1013          _ -> error $ "BuiltInFunCall 'low' from " ++ show e ++ "\ntype: " ++ show lt
  1022          _ -> error $ "BuiltInFunCall 'low' from " ++ show e ++ "\ntype: " ++ show lt
  1014 expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "high" _))) = do
  1023 expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "high" _))) = do