hedgewars: comparison tools/pas2c/Pas2C.hs

equal deleted inserted replaced

-:459bc720cea1
+:b26c2772e754
 import Data.Maybe
 import Data.Char
 import Text.Parsec.Prim hiding (State)
 import Control.Monad.State
 import System.IO
-import System.Directory
-import Control.Monad.IO.Class
 import PascalPreprocessor
 import Control.Exception
 import System.IO.Error
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 currentUnit :: String,
 currentFunctionResult :: String,
 namespaces :: Map.Map String Records
 }
+rec2Records :: [(String, BaseType)] -> [Record]
 rec2Records = map (\(a, b) -> Record a b empty)
+emptyState :: Map.Map String Records -> RenderState
 emptyState = RenderState Map.empty "" BTUnknown False empty [] 0 Set.empty [] "" ""
 getUniq :: State RenderState Int
 getUniq = do
 i <- gets uniqCounter
 pas2C fn inputPath outputPath alternateInputPath symbols = do
 s <- flip execStateT initState $ f fn
 renderCFiles s outputPath
 where
 printLn = liftIO . hPutStrLn stdout
-print = liftIO . hPutStr stdout
+print' = liftIO . hPutStr stdout
 initState = Map.empty
 f :: String -> StateT (Map.Map String PascalUnit) IO ()
 f fileName = do
 processed <- gets $ Map.member fileName
 unless processed $ do
-print ("Preprocessing '" ++ fileName ++ ".pas'... ")
+print' ("Preprocessing '" ++ fileName ++ ".pas'... ")
 fc' <- liftIO
 $ tryJust (guard . isDoesNotExistError)
 $ preprocess inputPath alternateInputPath (fileName ++ ".pas") symbols
 case fc' of
-(Left a) -> do
+(Left _) -> do
 modify (Map.insert fileName (System []))
 printLn "doesn't exist"
 (Right fc) -> do
-print "ok, parsing... "
+print' "ok, parsing... "
 let ptree = parse pascalUnit fileName fc
 case ptree of
 (Left a) -> do
 liftIO $ writeFile (outputPath ++ "preprocess.out") fc
 printLn $ show a ++ "\nsee preprocess.out for preprocessed source"
 withState' :: (RenderState -> RenderState) -> State RenderState a -> State RenderState a
 withState' f sf = do
 st <- liftM f get
 let (a, s) = runState sf st
-modify(\st -> st{
+modify(\st' -> st'{
 lastType = lastType s
 , uniqCounter = uniqCounter s
 , stringConsts = stringConsts s
 })
 return a
+withLastIdNamespace :: State RenderState Doc -> State RenderState Doc
 withLastIdNamespace f = do
 li <- gets lastIdentifier
-nss <- gets namespaces
 withState' (\st -> st{currentScope = fromMaybe Map.empty $ Map.lookup li (namespaces st)}) f
 withRecordNamespace :: String -> [Record] -> State RenderState Doc -> State RenderState Doc
 withRecordNamespace _ [] = error "withRecordNamespace: empty record"
 withRecordNamespace prefix recs = withState' f
 where
 f st = st{currentScope = Map.unionWith un records (currentScope st), currentUnit = ""}
 records = Map.fromList $ map (\(Record a b d) -> (map toLower a, [Record (prefix ++ a) b d])) recs
 un [a] b = a : b
+un _ _ = error "withRecordNamespace un: pattern not matched"
 toCFiles :: String -> Map.Map String Records -> (String, PascalUnit) -> IO ()
 toCFiles _ _ (_, System _) = return ()
 toCFiles _ _ (_, Redo _) = return ()
-toCFiles outputPath ns p@(fn, pu) = do
+toCFiles outputPath ns pu@(fileName, _) = do
-hPutStrLn stdout $ "Rendering '" ++ fn ++ "'..."
+hPutStrLn stdout $ "Rendering '" ++ fileName ++ "'..."
-toCFiles' p
+toCFiles' pu
 where
 toCFiles' (fn, p@(Program {})) = writeFile (outputPath ++ fn ++ ".c") $ "#include \"fpcrtl.h\"\n" ++ (render2C initialState . pascal2C) p
 toCFiles' (fn, (Unit unitId@(Identifier i _) interface implementation _ _)) = do
 let (a, s) = runState (id2C IOInsert (setBaseType BTUnit unitId) >> interface2C interface True) initialState{currentUnit = map toLower i ++ "_"}
-(a', s') = runState (id2C IOInsert (setBaseType BTUnit unitId) >> interface2C interface False) initialState{currentUnit = map toLower i ++ "_"}
+(a', _) = runState (id2C IOInsert (setBaseType BTUnit unitId) >> interface2C interface False) initialState{currentUnit = map toLower i ++ "_"}
 enumDecl = (renderEnum2Strs (enums s) False)
 enumImpl = (renderEnum2Strs (enums s) True)
 writeFile (outputPath ++ fn ++ ".h") $ "#pragma once\n\n#include \"pas2c.h\"\n\n" ++ (render (a $+$ text "")) ++ "\n" ++ enumDecl
 writeFile (outputPath ++ fn ++ ".c") $ "#include \"fpcrtl.h\"\n\n#include \"" ++ fn ++ ".h\"\n" ++ render (a' $+$ text "") ++ (render2C s . implementation2C) implementation ++ "\n" ++ enumImpl
+toCFiles' _ = undefined -- just pleasing compiler to not warn us
 initialState = emptyState ns
 render2C :: RenderState -> State RenderState Doc -> String
 render2C st p =
-let (a, s) = runState p st in
+let (a, _) = runState p st in
 render a
 renderEnum2Strs :: [(String, [String])] -> Bool -> String
-renderEnum2Strs enums implement =
+renderEnum2Strs enums' implement =
-render $ foldl ($+$) empty $ map (\en -> let d = decl (fst en) in if implement then d $+$ enum2strBlock (snd en) else d <> semi) enums
+render $ foldl ($+$) empty $ map (\en -> let d = decl (fst en) in if implement then d $+$ enum2strBlock (snd en) else d <> semi) enums'
 where
-decl id = text "string255 __attribute__((overloadable)) fpcrtl_GetEnumName" <> parens (text "int dummy, const" <+> text id <+> text "enumvar")
+decl id' = text "string255 __attribute__((overloadable)) fpcrtl_GetEnumName" <> parens (text "int dummy, const" <+> text id' <+> text "enumvar")
 enum2strBlock en =
 text "{"
 $+$
 (nest 4 $
 text "switch(enumvar){"
 usesFiles (Unit _ (Interface uses1 _) (Implementation uses2 _) _ _) = ["pas2cSystem", "pas2cRedo"] ++ uses2List uses1 ++ uses2List uses2
 usesFiles (System {}) = []
 usesFiles (Redo {}) = []
 pascal2C :: PascalUnit -> State RenderState Doc
-pascal2C (Unit _ interface implementation init fin) =
+pascal2C (Unit _ interface implementation _ _) =
 liftM2 ($+$) (interface2C interface True) (implementation2C implementation)
 pascal2C (Program _ implementation mainFunction) = do
 impl <- implementation2C implementation
 [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)))
 return $ impl $+$ main
+pascal2C _ = error "pascal2C: pattern not matched"
 -- the second bool indicates whether do normal interface translation or generate variable declarations
 -- that will be inserted into implementation files
 interface2C :: Interface -> Bool -> State RenderState Doc
 interface2C (Interface uses tvars) True = do
 u <- uses2C uses
 tv <- typesAndVars2C True True True tvars
 r <- renderStringConsts
 return (u $+$ r $+$ tv)
 interface2C (Interface uses tvars) False = do
-u <- uses2C uses
+void $ uses2C uses
 tv <- typesAndVars2C True False False tvars
-r <- renderStringConsts
+void $ renderStringConsts
 return tv
 implementation2C :: Implementation -> State RenderState Doc
 implementation2C (Implementation uses tvars) = do
 u <- uses2C uses
 checkDuplicateFunDecls :: [TypeVarDeclaration] -> State RenderState ()
 checkDuplicateFunDecls tvs =
 modify $ \s -> s{toMangle = Map.keysSet . Map.filter (> 1) . foldr ins initMap $ tvs}
 where
+initMap :: Map.Map String Int
 initMap = Map.empty
 --initMap = Map.fromList [("reset", 2)]
 ins (FunctionDeclaration (Identifier i _) _ _ _ _ _) m = Map.insertWith (+) (map toLower i) 1 m
 ins _ m = m
 uses2List :: Uses -> [String]
 uses2List (Uses ids) = map (\(Identifier i _) -> i) ids
+setLastIdValues :: Record -> RenderState -> RenderState
 setLastIdValues vv = (\s -> s{lastType = baseType vv, lastIdentifier = lcaseId vv, lastIdTypeDecl = typeDecl vv})
 id2C :: InsertOption -> Identifier -> State RenderState Doc
 id2C IOInsert i = id2C (IOInsertWithType empty) i
 id2C (IOInsertWithType d) (Identifier i t) = do
-ns <- gets currentScope
 tom <- gets (Set.member n . toMangle)
 cu <- gets currentUnit
 let (i', t') = case (t, tom) of
 (BTFunction _ p _, True) -> (cu ++ i ++ ('_' : show (length p)), t)
 (BTFunction _ _ _, _) -> (cu ++ i, t)
-(BTVarParam t', _) -> ('(' : '*' : i ++ ")" , t')
+(BTVarParam t'', _) -> ('(' : '*' : i ++ ")" , t'')
 _ -> (i, t)
 modify (\s -> s{currentScope = Map.insertWith (++) n [Record i' t' d] (currentScope s), lastIdentifier = n})
 return $ text i'
 where
 n = map toLower i
 id2C IOLookup i = id2CLookup head i
 id2C IOLookupLast i = id2CLookup last i
-id2C (IOLookupFunction params) (Identifier i t) = do
+id2C (IOLookupFunction params) (Identifier i _) = do
 let i' = map toLower i
 v <- gets $ Map.lookup i' . currentScope
 lt <- gets lastType
 if isNothing v then
 error $ "Not defined: '" ++ i' ++ "'\n" ++ show lt ++ "\nwith num of params = " ++ show params ++ "\n" ++ show v
 let vv = fromMaybe (head $ fromJust v) . find checkParam $ fromJust v in
 modify (setLastIdValues vv) >> (return . text . lcaseId $ vv)
 where
 checkParam (Record _ (BTFunction _ p _) _) = (length p) == params
 checkParam _ = False
-id2C IODeferred (Identifier i t) = do
+id2C IODeferred (Identifier i _) = do
 let i' = map toLower i
 v <- gets $ Map.lookup i' . currentScope
 if (isNothing v) then
 modify (\s -> s{lastType = BTUnknown, lastIdentifier = i}) >> return (text i)
 else
 let vv = head $ fromJust v in modify (setLastIdValues vv) >> (return . text . lcaseId $ vv)
 id2CLookup :: ([Record] -> Record) -> Identifier -> State RenderState Doc
-id2CLookup f (Identifier i t) = do
+id2CLookup f (Identifier i _) = do
 let i' = map toLower i
 v <- gets $ Map.lookup i' . currentScope
 lt <- gets lastType
 if isNothing v then
 error $ "Not defined: '" ++ i' ++ "'\n" ++ show lt
 tvs <- mapM f (concat $ tv : fromMaybe [] mtvs)
 return . BTRecord "" . concat $ tvs
 where
 f :: TypeVarDeclaration -> State RenderState [(String, BaseType)]
 f (VarDeclaration _ _ (ids, td) _) = mapM (\(Identifier i _) -> liftM ((,) i) $ resolveType td) ids
+f _ = error "resolveType f: pattern not matched"
 resolveType (ArrayDecl (Just i) t) = do
 t' <- resolveType t
 return $ BTArray i (BTInt True) t'
 resolveType (ArrayDecl Nothing t) = liftM (BTArray RangeInfinite (BTInt True)) $ resolveType t
 resolveType (FunctionType t a) = do
 fromPointer s (BTPointerTo t) = resolve s t
 fromPointer s t = do
 error $ "Dereferencing from non-pointer type " ++ show t ++ "\n" ++ s
+functionParams2C :: [TypeVarDeclaration] -> State RenderState Doc
 functionParams2C params = liftM (hcat . punctuate comma . concat) $ mapM (tvar2C False False True True) params
 numberOfDeclarations :: [TypeVarDeclaration] -> Int
 numberOfDeclarations = sum . map cnt
 where
 abc = hcat . punctuate comma . map (char . fst) $ ps
 cparams = hcat . punctuate comma . map (\(c, v) -> if v then char '&' <> parens (char c) else char c) $ ps
 ps = zip ['a'..] (toIsVarList params)
 fun2C :: Bool -> String -> TypeVarDeclaration -> State RenderState [Doc]
-fun2C _ _ (FunctionDeclaration name inline overload returnType params Nothing) = do
+fun2C _ _ (FunctionDeclaration name _ overload returnType params Nothing) = do
 t <- type2C returnType
 t'<- gets lastType
 bts <- typeVarDecl2BaseType params
 p <- withState' id $ functionParams2C params
 n <- liftM render . id2C IOInsert $ setBaseType (BTFunction False bts t') name
 let decor = if overload then text "__attribute__((overloadable))" else empty
 return [t empty <+> decor <+> text n <> parens p]
-fun2C True rv (FunctionDeclaration name@(Identifier i bt) inline overload returnType params (Just (tvars, phrase))) = do
+fun2C True rv (FunctionDeclaration name@(Identifier i _) inline overload returnType params (Just (tvars, phrase))) = do
 let isVoid = case returnType of
 VoidType -> True
 _ -> False
 let res = docToLower $ text rv <> if isVoid then empty else text "_result"
 t <- type2C returnType
 t' <- gets lastType
 bts <- typeVarDecl2BaseType params
-cu <- gets currentUnit
+--cu <- gets currentUnit
 notDeclared <- liftM isNothing . gets $ Map.lookup (map toLower i) . currentScope
 n <- liftM render . id2C IOInsert $ setBaseType (BTFunction hasVars bts t') name
 let resultId = if isVoid
 then n -- void type doesn't have result, solving recursive procedure calls
 p <- functionParams2C params
 ph <- liftM2 ($+$) (typesAndVars2C False False True tvars) (phrase2C' phrase)
 return (p, ph)
 let phrasesBlock = if isVoid then ph else t empty <+> res <> semi $+$ ph $+$ text "return" <+> res <> semi
-let define = if hasVars then text "#ifndef" <+> text n $+$ funWithVarsToDefine n params $+$ text "#endif" else empty
+--let define = if hasVars then text "#ifndef" <+> text n $+$ funWithVarsToDefine n params $+$ text "#endif" else empty
 let inlineDecor = if inline then case notDeclared of
 True -> text "static inline"
 False -> text "inline"
 else empty
 overloadDecor = if overload then text "__attribute__((overloadable))" else empty
 text "}"]
 where
 phrase2C' (Phrases p) = liftM vcat $ mapM phrase2C p
 phrase2C' p = phrase2C p
 un [a] b = a : b
+un _ _ = error "fun2C u: pattern not matched"
 hasVars = hasPassByReference params
 fun2C False _ (FunctionDeclaration (Identifier name _) _ _ _ _ _) = error $ "nested functions not allowed: " ++ name
 fun2C _ tv _ = error $ "fun2C: I don't render " ++ show tv
 -- the fourth bool indicates whether ignore initialization or not (basically for dynamic arrays since we cannot do initialization in function params)
 tvar2C :: Bool -> Bool -> Bool -> Bool -> TypeVarDeclaration -> State RenderState [Doc]
 tvar2C b _ includeType _ f@(FunctionDeclaration (Identifier name _) _ _ _ _ _) = do
 t <- fun2C b name f
 if includeType then return t else return []
-tvar2C _ _ includeType _ td@(TypeDeclaration i' t) = do
+tvar2C _ _ includeType _ (TypeDeclaration i' t) = do
 i <- id2CTyped t i'
 tp <- type2C t
 let res = if includeType then [text "typedef" <+> tp i] else []
 case t of
 (Sequence ids) -> do
-modify(\s -> s{enums = (render i, map (\(Identifier i _) -> i) ids) : enums s})
+modify(\s -> s{enums = (render i, map (\(Identifier id' _) -> id') ids) : enums s})
 return res
 _ -> return res
 tvar2C _ _ _ _ (VarDeclaration True _ (ids, t) Nothing) = do
 t' <- liftM ((empty <+>) . ) $ type2C t
 (True, BTInt _, [i], Just _) -> do
 i' <- id2CTyped t i
 return $ if includeType then [text "enum" <> braces (i' <+> ie)] else []
 (True, BTFloat, [i], Just e) -> do
 i' <- id2CTyped t i
-ie <- initExpr2C e
+ie' <- initExpr2C e
-return $ if includeType then [text "#define" <+> i' <+> parens ie <> text "\n"] else []
+return $ if includeType then [text "#define" <+> i' <+> parens ie' <> text "\n"] else []
 (_, BTFunction{}, _, Nothing) -> liftM (map(\i -> t' i)) $ mapM (id2CTyped t) ids
 (_, BTArray r _ _, [i], _) -> do
 i' <- id2CTyped t i
 ie' <- return $ case (r, mInitExpr, ignoreInit) of
 (RangeInfinite, Nothing, False) -> text "= NULL" -- force dynamic array to be initialized as NULL if not initialized at all
 (_, _, _) -> ie
-result <- liftM (map(\i -> varDeclDecision isConst includeType (t' i) ie')) $ mapM (id2CTyped t) ids
+result <- liftM (map(\id' -> varDeclDecision isConst includeType (t' id') ie')) $ mapM (id2CTyped t) ids
 case (r, ignoreInit) of
 (RangeInfinite, False) ->
 -- if the array is dynamic, add dimension info to it
 return $ [dimDecl] ++ result
 where
 initExpr Nothing = return $ empty
 initExpr (Just e) = liftM (text "=" <+>) (initExpr2C e)
 varDeclDecision True True varStr expStr = varStr <+> expStr
 varDeclDecision False True varStr expStr = if externVar then varStr else varStr <+> expStr
 varDeclDecision False False varStr expStr = varStr <+> expStr
-varDeclDecision True False varStr expStr = empty
+varDeclDecision True False _ _ = empty
 arrayDimension a = case a of
-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
+ArrayDecl Nothing t' -> let a' = arrayDimension t' in
+if a' > 3 then error "Dynamic array with dimension > 4 is not supported." else 1 + a'
 ArrayDecl _ _ -> error "Mixed dynamic array and static array are not supported."
 _ -> 0
 tvar2C f _ _ _ (OperatorDeclaration op (Identifier i _) inline ret params body) = do
 r <- op2CTyped op (extractTypes params)
 fun2C f i (FunctionDeclaration r inline False ret params body)
 op2CTyped :: String -> [TypeDecl] -> State RenderState Identifier
 op2CTyped op t = do
-t' <- liftM (render . hcat . punctuate (char '_') . map (\t -> t empty)) $ mapM type2C t
+t' <- liftM (render . hcat . punctuate (char '_') . map (\txt -> txt empty)) $ mapM type2C t
 bt <- gets lastType
 return $ Identifier (t' ++ "_op_" ++ opStr) bt
 where
 opStr = case op of
 "+" -> "add"
 initExpr2C' (InitBinOp op expr1 expr2) = do
 e1 <- initExpr2C' expr1
 e2 <- initExpr2C' expr2
 return $ parens $ e1 <+> text (op2C op) <+> e2
 initExpr2C' (InitNumber s) = do
-modify(\s -> s{lastType = (BTInt True)})
+modify(\st -> st{lastType = (BTInt True)})
 return $ text s
 initExpr2C' (InitFloat s) = return $ text s
 initExpr2C' (InitHexNumber s) = return $ text "0x" <> (text . map toLower $ s)
 initExpr2C' (InitString [a]) = return . quotes $ text [a]
 initExpr2C' (InitString s) = return $ strInit s
 return $ lbrace $+$ (nest 4 . vcat . punctuate comma $ fs) $+$ rbrace
 --initExpr2C' (InitArray [InitRecord fields]) = do
 --    e <- initExpr2C $ InitRecord fields
 --    return $ braces $ e
 initExpr2C' r@(InitRange (Range i@(Identifier i' _))) = do
-id2C IOLookup i
+void $ id2C IOLookup i
 t <- gets lastType
 case t of
 BTEnum s -> return . int $ length s
 BTInt _ -> case i' of
 "byte" -> return $ int 256
 _ -> error $ "InitRange: " ++ show r
 initExpr2C' (InitRange (RangeFromTo (InitNumber "0") r)) = initExpr2C $ BuiltInFunction "succ" [r]
 initExpr2C' (InitRange (RangeFromTo (InitChar "0") (InitChar r))) = initExpr2C $ BuiltInFunction "succ" [InitNumber r]
 initExpr2C' (InitRange a) = error $ show a --return $ text "<<range>>"
 initExpr2C' (InitSet []) = return $ text "0"
-initExpr2C' (InitSet a) = return $ text "<<set>>"
+initExpr2C' (InitSet _) = return $ text "<<set>>"
 initExpr2C' (BuiltInFunction "low" [InitReference e]) = return $
 case e of
 (Identifier "LongInt" _) -> int (-2^31)
 (Identifier "SmallInt" _) -> int (-2^15)
 _ -> error $ "BuiltInFunction 'low': " ++ show e
 initExpr2C' (BuiltInFunction "high" [e]) = do
-initExpr2C e
+void $ initExpr2C e
 t <- gets lastType
 case t of
 (BTArray i _ _) -> initExpr2C' $ BuiltInFunction "pred" [InitRange i]
 a -> error $ "BuiltInFunction 'high': " ++ show a
 initExpr2C' (BuiltInFunction "succ" [BuiltInFunction "pred" [e]]) = initExpr2C' e
 baseType2C _ BTBool = text "bool"
 baseType2C _ BTString = text "string255"
 baseType2C s a = error $ "baseType2C: " ++ show a ++ "\n" ++ s
 type2C :: TypeDecl -> State RenderState (Doc -> Doc)
-type2C (SimpleType i) = liftM (\i a -> i <+> a) $ id2C IOLookup i
+type2C (SimpleType i) = liftM (\i' a -> i' <+> a) $ id2C IOLookup i
 type2C t = do
 r <- type2C' t
 rt <- resolveType t
 modify (\st -> st{lastType = rt})
 return r
 lt <- gets lastType
 case lt of
 BTRecord _ _ -> return $ \a -> text "struct __" <> i' <+> text "*" <+> a
 BTUnknown -> return $ \a -> text "struct __" <> i' <+> text "*" <+> a
 _ -> return $ \a -> i' <+> text "*" <+> a
-type2C' (PointerTo t) = liftM (\t a -> t (parens $ text "*" <> a)) $ type2C t
+type2C' (PointerTo t) = liftM (\tx a -> tx (parens $ text "*" <> a)) $ type2C t
 type2C' (RecordType tvs union) = do
-t <- withState' f $ mapM (tvar2C False False True False) tvs
+t' <- withState' f $ mapM (tvar2C False False True False) tvs
 u <- unions
-return $ \i -> text "struct __" <> i <+> lbrace $+$ nest 4 ((vcat . map (<> semi) . concat $ t) $$ u) $+$ rbrace <+> i
+return $ \i -> text "struct __" <> i <+> lbrace $+$ nest 4 ((vcat . map (<> semi) . concat $ t') $$ u) $+$ rbrace <+> i
 where
 f s = s{currentUnit = ""}
 unions = case union of
 Nothing -> return empty
 Just a -> do
 structs <- mapM struct2C a
 return $ text "union" $+$ braces (nest 4 $ vcat structs) <> semi
-struct2C tvs = do
+struct2C stvs = do
-t <- withState' f $ mapM (tvar2C False False True False) tvs
+txts <- withState' f $ mapM (tvar2C False False True False) stvs
-return $ text "struct" $+$ braces (nest 4 (vcat . map (<> semi) . concat $ t)) <> semi
+return $ text "struct" $+$ braces (nest 4 (vcat . map (<> semi) . concat $ txts)) <> semi
 type2C' (RangeType r) = return (text "int" <+>)
 type2C' (Sequence ids) = do
 is <- mapM (id2C IOInsert . setBaseType bt) ids
 return (text "enum" <+> (braces . vcat . punctuate comma . map (\(a, b) -> a <+> equals <+> text "0x" <> text (showHex b "")) $ zip is [0..]) <+>)
 where
 type2C' (DeriveType r@(InitReference {})) = do
 initExpr2C r
 t <- gets lastType
 return (baseType2C (show r) t <+>)
 type2C' (DeriveType a) = error $ "Can't derive type from " ++ show a
+type2C' a = error $ "type2C: unknown type " ++ show a
 phrase2C :: Phrase -> State RenderState Doc
 phrase2C (Phrases p) = do
 ps <- mapM phrase2C p
 return $ text "{" $+$ (nest 4 . vcat $ ps) $+$ text "}"
 phrase2C (ProcCall f@(FunCall {}) []) = liftM (<> semi) $ ref2C f
 phrase2C (ProcCall ref []) = liftM (<> semi) $ ref2CF ref True
-phrase2C (ProcCall ref params) = error $ "ProcCall"{-do
+phrase2C (ProcCall _ _) = error $ "ProcCall"{-do
 r <- ref2C ref
 ps <- mapM expr2C params
 return $ r <> parens (hsep . punctuate (char ',') $ ps) <> semi -}
 phrase2C (IfThenElse (expr) phrase1 mphrase2) = do
 e <- expr2C expr
 case (t, expr) of
 (BTFunction {}, (Reference r')) -> do
 e <- ref2C r'
 return $ r <+> text "=" <+> e <> semi
 (BTString, _) -> do
-e <- expr2C expr
+void $ expr2C expr
 lt <- gets lastType
 case lt of
 -- assume pointer to char for simplicity
 BTPointerTo _ -> do
 e <- expr2C $ Reference $ FunCall [Reference $ RefExpression expr] (SimpleReference (Identifier "pchar2str" BTUnknown))
 return $ r <+> text "=" <+> e <> semi
 _ -> error $ "Assignment to string from " ++ show asgn
 (BTArray _ _ _, _) -> do
 case expr of
 Reference er -> do
-exprRef <- ref2C er
+void $ ref2C er
 exprT <- gets lastType
 case exprT of
 BTArray RangeInfinite _ _ ->
 return $ text "FIXME: assign a dynamic array to an array"
 BTArray _ _ _ -> phrase2C $
 wrapPhrase p@(Phrases _) = p
 wrapPhrase p = Phrases [p]
 expr2C :: Expression -> State RenderState Doc
 expr2C (Expression s) = return $ text s
-expr2C b@(BinOp op expr1 expr2) = do
+expr2C (BinOp op expr1 expr2) = do
 e1 <- expr2C expr1
 t1 <- gets lastType
 e2 <- expr2C expr2
 t2 <- gets lastType
 case (op2C op, t1, t2) of
 expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "low" _))) = do
 e' <- liftM (map toLower . render) $ expr2C e
 lt <- gets lastType
 case lt of
-BTEnum a -> return $ int 0
+BTEnum _-> return $ int 0
 BTInt _ -> case e' of
 "longint" -> return $ int (-2147483648)
 BTArray {} -> return $ int 0
 _ -> error $ "BuiltInFunCall 'low' from " ++ show e ++ "\ntype: " ++ show lt
 expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "high" _))) = do

changeset 10113	b26c2772e754
parent 10111	459bc720cea1
child 10120	b7f632c12784