author | belphegorr <szabibibi@gmail.com> |
Mon, 23 Jul 2012 19:15:59 +0300 | |
changeset 7263 | 644eabbc9218 |
parent 7151 | ec15d9e1a7e3 |
child 7265 | 3f96073156e1 |
permissions | -rw-r--r-- |
{-# LANGUAGE ScopedTypeVariables #-} module Pas2C where import Text.PrettyPrint.HughesPJ 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 import Data.List (find) import Numeric import PascalParser import PascalUnitSyntaxTree data InsertOption = IOInsert | IOLookup | IOLookupLast | IOLookupFunction Int | IODeferred type Record = (String, BaseType) type Records = Map.Map String [Record] data RenderState = RenderState { currentScope :: Records, lastIdentifier :: String, lastType :: BaseType, stringConsts :: [(String, String)], uniqCounter :: Int, toMangle :: Set.Set String, currentUnit :: String, currentFunctionResult :: String, namespaces :: Map.Map String Records } emptyState = RenderState Map.empty "" BTUnknown [] 0 Set.empty "" "" getUniq :: State RenderState Int getUniq = do i <- gets uniqCounter modify(\s -> s{uniqCounter = uniqCounter s + 1}) return i addStringConst :: String -> State RenderState Doc addStringConst str = do strs <- gets stringConsts let a = find ((==) str . snd) strs if isJust a then do modify (\s -> s{lastType = BTString}) return . text . fst . fromJust $ a else do i <- getUniq let sn = "__str" ++ show i modify (\s -> s{lastType = BTString, stringConsts = (sn, str) : strs}) return $ text sn escapeStr :: String -> String escapeStr = foldr escapeChar [] escapeChar :: Char -> ShowS escapeChar '"' s = "\\\"" ++ s escapeChar a s = a : s strInit :: String -> Doc strInit a = text "STRINIT" <> parens (doubleQuotes (text $ escapeStr a)) renderStringConsts :: State RenderState Doc renderStringConsts = liftM (vcat . map (\(a, b) -> text "const string255" <+> (text a) <+> text "=" <+> strInit b <> semi)) $ gets stringConsts docToLower :: Doc -> Doc docToLower = text . map toLower . render pas2C :: String -> IO () pas2C fn = do setCurrentDirectory "../hedgewars/" s <- flip execStateT initState $ f fn renderCFiles s where printLn = liftIO . hPutStrLn stderr print = liftIO . hPutStr stderr 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'... ") fc' <- liftIO $ tryJust (guard . isDoesNotExistError) $ preprocess (fileName ++ ".pas") case fc' of (Left a) -> do modify (Map.insert fileName (System [])) printLn "doesn't exist" (Right fc) -> do print "ok, parsing... " let ptree = parse pascalUnit fileName fc case ptree of (Left a) -> do liftIO $ writeFile "preprocess.out" fc printLn $ show a ++ "\nsee preprocess.out for preprocessed source" fail "stop" (Right a) -> do printLn "ok" modify (Map.insert fileName a) mapM_ f (usesFiles a) renderCFiles :: Map.Map String PascalUnit -> IO () renderCFiles units = do let u = Map.toList units let nss = Map.map (toNamespace nss) units hPutStrLn stderr $ "Units: " ++ (show . Map.keys . Map.filter (not . Map.null) $ nss) --writeFile "pas2c.log" $ unlines . map (\t -> show (fst t) ++ "\n" ++ (unlines . map ((:) '\t' . show) . snd $ t)) . Map.toList $ nss mapM_ (toCFiles nss) u where toNamespace :: Map.Map String Records -> PascalUnit -> Records toNamespace nss (System tvs) = currentScope $ execState f (emptyState nss) where f = do checkDuplicateFunDecls tvs mapM_ (tvar2C True) tvs toNamespace _ (Program {}) = Map.empty toNamespace nss (Unit (Identifier i _) interface _ _ _) = currentScope $ execState (interface2C interface) (emptyState nss){currentUnit = map toLower i ++ "_"} 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{ 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 -> [(String, BaseType)] -> 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 (\(a, b) -> (map toLower a, [(prefix ++ a, b)])) recs un [a] b = a : b toCFiles :: Map.Map String Records -> (String, PascalUnit) -> IO () toCFiles _ (_, System _) = return () toCFiles ns p@(fn, pu) = do hPutStrLn stderr $ "Rendering '" ++ fn ++ "'..." toCFiles' p where toCFiles' (fn, p@(Program {})) = writeFile (fn ++ ".c") $ (render2C initialState . pascal2C) p toCFiles' (fn, (Unit unitId@(Identifier i _) interface implementation _ _)) = do let (a, s) = runState (id2C IOInsert (setBaseType BTUnit unitId) >> interface2C interface) initialState{currentUnit = map toLower i ++ "_"} writeFile (fn ++ ".h") $ "#pragma once\n\n#include \"pas2c.h\"\n\n" ++ (render (a $+$ text "")) writeFile (fn ++ ".c") $ "#include \"" ++ fn ++ ".h\"\n" ++ (render2C s . implementation2C) implementation initialState = emptyState ns render2C :: RenderState -> State RenderState Doc -> String render2C a = render . ($+$ empty) . flip evalState a usesFiles :: PascalUnit -> [String] usesFiles (Program _ (Implementation uses _) _) = "pas2cSystem" : uses2List uses usesFiles (Unit _ (Interface uses1 _) (Implementation uses2 _) _ _) = "pas2cSystem" : uses2List uses1 ++ uses2List uses2 usesFiles (System {}) = [] pascal2C :: PascalUnit -> State RenderState Doc pascal2C (Unit _ interface implementation init fin) = liftM2 ($+$) (interface2C interface) (implementation2C implementation) pascal2C (Program _ implementation mainFunction) = do impl <- implementation2C implementation [main] <- tvar2C True (FunctionDeclaration (Identifier "main" BTInt) (SimpleType $ Identifier "int" BTInt) [] (Just (TypesAndVars [], mainFunction))) return $ impl $+$ main interface2C :: Interface -> State RenderState Doc interface2C (Interface uses tvars) = do u <- uses2C uses tv <- typesAndVars2C True tvars r <- renderStringConsts return (u $+$ r $+$ tv) implementation2C :: Implementation -> State RenderState Doc implementation2C (Implementation uses tvars) = do u <- uses2C uses tv <- typesAndVars2C True tvars r <- renderStringConsts return (u $+$ r $+$ tv) checkDuplicateFunDecls :: [TypeVarDeclaration] -> State RenderState () checkDuplicateFunDecls tvs = modify $ \s -> s{toMangle = Map.keysSet . Map.filter (> 1) . foldr ins initMap $ tvs} where initMap = Map.empty --initMap = Map.fromList [("reset", 2)] ins (FunctionDeclaration (Identifier i _) _ _ _) m = Map.insertWith (+) (map toLower i) 1 m ins _ m = m typesAndVars2C :: Bool -> TypesAndVars -> State RenderState Doc typesAndVars2C b (TypesAndVars ts) = do checkDuplicateFunDecls ts liftM (vcat . map (<> semi) . concat) $ mapM (tvar2C b) ts setBaseType :: BaseType -> Identifier -> Identifier setBaseType bt (Identifier i _) = Identifier i bt uses2C :: Uses -> State RenderState Doc uses2C uses@(Uses unitIds) = do mapM_ injectNamespace (Identifier "pas2cSystem" undefined : unitIds) mapM_ (id2C IOInsert . setBaseType BTUnit) unitIds return $ vcat . map (\i -> text $ "#include \"" ++ i ++ ".h\"") $ uses2List uses where injectNamespace (Identifier i _) = do getNS <- gets (flip Map.lookup . namespaces) modify (\s -> s{currentScope = Map.unionWith (++) (fromMaybe Map.empty (getNS i)) $ currentScope s}) uses2List :: Uses -> [String] uses2List (Uses ids) = map (\(Identifier i _) -> i) ids id2C :: InsertOption -> Identifier -> State RenderState Doc id2C IOInsert (Identifier i t) = do ns <- gets currentScope tom <- gets (Set.member n . toMangle) cu <- gets currentUnit let i' = case (t, tom) of (BTFunction p _, True) -> cu ++ i ++ ('_' : show p) (BTFunction _ _, _) -> cu ++ i _ -> i modify (\s -> s{currentScope = Map.insertWith (++) n [(i', t)] (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 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 else let vv = fromMaybe (head $ fromJust v) . find checkParam $ fromJust v in modify (\s -> s{lastType = snd vv, lastIdentifier = fst vv}) >> (return . text . fst $ vv) where checkParam (_, BTFunction p _) = p == params checkParam _ = False id2C IODeferred (Identifier i t) = 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 (\s -> s{lastType = snd vv, lastIdentifier = fst vv}) >> (return . text . fst $ vv) id2CLookup :: ([Record] -> Record) -> Identifier -> State RenderState Doc 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 else let vv = f $ fromJust v in modify (\s -> s{lastType = snd vv, lastIdentifier = fst vv}) >> (return . text . fst $ vv) id2CTyped :: TypeDecl -> Identifier -> State RenderState Doc id2CTyped t (Identifier i _) = do tb <- resolveType t case (t, tb) of (_, BTUnknown) -> do error $ "id2CTyped: type BTUnknown for " ++ show i ++ "\ntype: " ++ show t (SimpleType {}, BTRecord _ r) -> do ts <- type2C t id2C IOInsert (Identifier i (BTRecord (render $ ts empty) r)) (_, BTRecord _ r) -> do ts <- type2C t id2C IOInsert (Identifier i (BTRecord i r)) _ -> id2C IOInsert (Identifier i tb) resolveType :: TypeDecl -> State RenderState BaseType resolveType st@(SimpleType (Identifier i _)) = do let i' = map toLower i v <- gets $ Map.lookup i' . currentScope if isJust v then return . snd . head $ fromJust v else return $ f i' where f "integer" = BTInt f "pointer" = BTPointerTo BTVoid f "boolean" = BTBool f "float" = BTFloat f "char" = BTChar f "string" = BTString f _ = error $ "Unknown system type: " ++ show st resolveType (PointerTo (SimpleType (Identifier i _))) = return . BTPointerTo $ BTUnresolved (map toLower i) resolveType (PointerTo t) = liftM BTPointerTo $ resolveType t resolveType (RecordType tv mtvs) = do 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 resolveType (ArrayDecl (Just i) t) = do t' <- resolveType t return $ BTArray i BTInt t' resolveType (ArrayDecl Nothing t) = liftM (BTArray RangeInfinite BTInt) $ resolveType t resolveType (FunctionType t a) = liftM (BTFunction (length a)) $ resolveType t resolveType (DeriveType (InitHexNumber _)) = return BTInt resolveType (DeriveType (InitNumber _)) = return BTInt resolveType (DeriveType (InitFloat _)) = return BTFloat resolveType (DeriveType (InitString _)) = return BTString resolveType (DeriveType (InitBinOp {})) = return BTInt resolveType (DeriveType (InitPrefixOp _ e)) = initExpr2C e >> gets lastType resolveType (DeriveType (BuiltInFunction{})) = return BTInt resolveType (DeriveType (InitReference (Identifier{}))) = return BTBool -- TODO: derive from actual type resolveType (DeriveType _) = return BTUnknown resolveType (String _) = return BTString resolveType VoidType = return BTVoid resolveType (Sequence ids) = return $ BTEnum $ map (\(Identifier i _) -> map toLower i) ids resolveType (RangeType _) = return $ BTVoid resolveType (Set t) = liftM BTSet $ resolveType t resolve :: String -> BaseType -> State RenderState BaseType resolve s (BTUnresolved t) = do v <- gets $ Map.lookup t . currentScope if isJust v then resolve s . snd . head . fromJust $ v else error $ "Unknown type " ++ show t ++ "\n" ++ s resolve _ t = return t fromPointer :: String -> BaseType -> State RenderState BaseType fromPointer s (BTPointerTo t) = resolve s t fromPointer s t = do error $ "Dereferencing from non-pointer type " ++ show t ++ "\n" ++ s functionParams2C params = liftM (hcat . punctuate comma . concat) $ mapM (tvar2C False) params numberOfDeclarations :: [TypeVarDeclaration] -> Int numberOfDeclarations = sum . map cnt where cnt (VarDeclaration _ (ids, _) _) = length ids cnt _ = 1 fun2C :: Bool -> String -> TypeVarDeclaration -> State RenderState [Doc] fun2C _ _ (FunctionDeclaration name returnType params Nothing) = do t <- type2C returnType t'<- gets lastType p <- withState' id $ functionParams2C params n <- id2C IOInsert $ setBaseType (BTFunction (numberOfDeclarations params) t') name return [t empty <+> n <> parens p] fun2C True rv (FunctionDeclaration name returnType params (Just (tvars, phrase))) = do let res = docToLower $ text rv <> text "_result" t <- type2C returnType t'<- gets lastType n <- id2C IOInsert $ setBaseType (BTFunction (numberOfDeclarations params) t') name let isVoid = case returnType of VoidType -> True _ -> False (p, ph) <- withState' (\st -> st{currentScope = Map.insertWith un (map toLower rv) [(render res, t')] $ currentScope st , currentFunctionResult = if isVoid then [] else render res}) $ do p <- functionParams2C params ph <- liftM2 ($+$) (typesAndVars2C False tvars) (phrase2C' phrase) return (p, ph) let phrasesBlock = if isVoid then ph else t empty <+> res <> semi $+$ ph $+$ text "return" <+> res <> semi return [ t empty <+> n <> parens p $+$ text "{" $+$ nest 4 phrasesBlock $+$ text "}"] where phrase2C' (Phrases p) = liftM vcat $ mapM phrase2C p phrase2C' p = phrase2C p un [a] b = a : b fun2C False _ (FunctionDeclaration (Identifier name _) _ _ _) = error $ "nested functions not allowed: " ++ name fun2C _ tv _ = error $ "fun2C: I don't render " ++ show tv tvar2C :: Bool -> TypeVarDeclaration -> State RenderState [Doc] tvar2C b f@(FunctionDeclaration (Identifier name _) _ _ _) = fun2C b name f tvar2C _ td@(TypeDeclaration i' t) = do i <- id2CTyped t i' tp <- type2C t return [text "typedef" <+> tp i] tvar2C _ (VarDeclaration isConst (ids, t) mInitExpr) = do t' <- liftM (((if isConst then text "const" else empty) <+>) . ) $ type2C t ie <- initExpr mInitExpr lt <- gets lastType case (isConst, lt, ids, mInitExpr) of (True, BTInt, [i], Just _) -> do i' <- id2CTyped t i return [text "enum" <> braces (i' <+> ie)] (True, BTFloat, [i], Just e) -> do i' <- id2CTyped t i ie <- initExpr2C e return [text "#define" <+> i' <+> parens ie <> text "\n"] (_, BTFunction{}, _, Nothing) -> liftM (map(\i -> t' $ text "*" <+> i)) $ mapM (id2CTyped t) ids _ -> liftM (map(\i -> t' i <+> ie)) $ mapM (id2CTyped t) ids where initExpr Nothing = return $ empty initExpr (Just e) = liftM (text "=" <+>) (initExpr2C e) tvar2C f (OperatorDeclaration op (Identifier i _) ret params body) = do r <- op2CTyped op (extractTypes params) fun2C f i (FunctionDeclaration r 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 bt <- gets lastType return $ Identifier (t' ++ "_op_" ++ opStr) bt where opStr = case op of "+" -> "add" "-" -> "sub" "*" -> "mul" "/" -> "div" "=" -> "eq" "<" -> "lt" ">" -> "gt" "<>" -> "neq" _ -> error $ "op2CTyped: unknown op '" ++ op ++ "'" extractTypes :: [TypeVarDeclaration] -> [TypeDecl] extractTypes = concatMap f where f (VarDeclaration _ (ids, t) _) = replicate (length ids) t f a = error $ "extractTypes: can't extract from " ++ show a initExpr2C, initExpr2C' :: InitExpression -> State RenderState Doc initExpr2C (InitArray values) = liftM (braces . vcat . punctuate comma) $ mapM initExpr2C values initExpr2C a = initExpr2C' a initExpr2C' InitNull = return $ text "NULL" initExpr2C' (InitAddress expr) = liftM ((<>) (text "&")) (initExpr2C' expr) initExpr2C' (InitPrefixOp op expr) = liftM (text (op2C op) <>) (initExpr2C' expr) initExpr2C' (InitBinOp op expr1 expr2) = do e1 <- initExpr2C' expr1 e2 <- initExpr2C' expr2 return $ parens $ e1 <+> text (op2C op) <+> e2 initExpr2C' (InitNumber s) = 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 initExpr2C' (InitChar a) = return $ quotes $ text "\\x" <> text (showHex (read a) "") initExpr2C' (InitReference i) = id2C IOLookup i initExpr2C' (InitRecord fields) = do (fs :: [Doc]) <- mapM (\(Identifier a _, b) -> liftM (text "." <> text a <+> equals <+>) $ initExpr2C b) fields return $ lbrace $+$ (nest 4 . vcat . punctuate comma $ fs) $+$ rbrace initExpr2C' (InitArray [value]) = initExpr2C value initExpr2C' r@(InitRange (Range i@(Identifier i' _))) = do 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 identifier: " ++ i' _ -> 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' (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 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 initExpr2C' (BuiltInFunction "pred" [BuiltInFunction "succ" [e]]) = initExpr2C' e initExpr2C' (BuiltInFunction "succ" [e]) = liftM (<> text " + 1") $ initExpr2C' e initExpr2C' (BuiltInFunction "pred" [e]) = liftM (<> text " - 1") $ initExpr2C' e initExpr2C' b@(BuiltInFunction _ _) = error $ show b initExpr2C' a = error $ "initExpr2C: don't know how to render " ++ show a range2C :: InitExpression -> State RenderState [Doc] range2C (InitString [a]) = return [quotes $ text [a]] range2C (InitRange (Range i)) = liftM (flip (:) []) $ id2C IOLookup i range2C (InitRange (RangeFromTo (InitString [a]) (InitString [b]))) = return $ map (\i -> quotes $ text [i]) [a..b] range2C a = liftM (flip (:) []) $ initExpr2C a baseType2C :: String -> BaseType -> Doc baseType2C _ BTFloat = text "float" 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 t = do r <- type2C' t rt <- resolveType t modify (\st -> st{lastType = rt}) return r where type2C' VoidType = return (text "void" <+>) type2C' (String l) = return (text "string255" <+>)--return (text ("string" ++ show l) <+>) type2C' (PointerTo (SimpleType i)) = do i' <- id2C IODeferred i 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' (RecordType tvs union) = do t <- withState' f $ mapM (tvar2C False) tvs u <- unions 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 t <- withState' f $ mapM (tvar2C False) tvs return $ text "struct" $+$ braces (nest 4 (vcat . map (<> semi) . concat $ t)) <> 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 bt = BTEnum $ map (\(Identifier i _) -> map toLower i) ids type2C' (ArrayDecl Nothing t) = type2C (PointerTo t) type2C' (ArrayDecl (Just r) t) = do t' <- type2C t lt <- gets lastType ft <- case lt of BTFunction {} -> type2C (PointerTo t) _ -> return t' r' <- initExpr2C (InitRange r) return $ \i -> ft i <> brackets r' type2C' (Set t) = return (text "<<set>>" <+>) type2C' (FunctionType returnType params) = do t <- type2C returnType p <- withState' id $ functionParams2C params return (\i -> t empty <+> i <> parens p) type2C' (DeriveType (InitBinOp _ _ i)) = type2C' (DeriveType i) type2C' (DeriveType (InitPrefixOp _ i)) = type2C' (DeriveType i) type2C' (DeriveType (InitNumber _)) = return (text "int" <+>) type2C' (DeriveType (InitHexNumber _)) = return (text "int" <+>) type2C' (DeriveType (InitFloat _)) = return (text "float" <+>) type2C' (DeriveType (BuiltInFunction {})) = return (text "int" <+>) type2C' (DeriveType (InitString {})) = return (text "string255" <+>) 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 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 phrase2C (ProcCall ref params) = 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 p1 <- (phrase2C . wrapPhrase) phrase1 el <- elsePart return $ text "if" <> parens e $+$ p1 $+$ el where elsePart | isNothing mphrase2 = return $ empty | otherwise = liftM (text "else" $$) $ (phrase2C . wrapPhrase) (fromJust mphrase2) phrase2C (Assignment ref expr) = do r <- ref2C ref t <- gets lastType case (t, expr) of (BTFunction {}, (Reference r')) -> do e <- ref2C r' return $ r <+> text "=" <+> e <> semi (BTString, _) -> do e <- 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 BTString -> do e <- expr2C expr return $ r <+> text "=" <+> e <> semi _ -> error $ "Assignment to string from " ++ show lt (BTArray _ _ _, _) -> phrase2C $ ProcCall (FunCall [ Reference $ Address ref , Reference $ Address $ RefExpression expr , Reference $ FunCall [expr] (SimpleReference (Identifier "sizeof" BTUnknown)) ] (SimpleReference (Identifier "memcpy" BTUnknown)) ) [] _ -> do e <- expr2C expr return $ r <+> text "=" <+> e <> semi phrase2C (WhileCycle expr phrase) = do e <- expr2C expr p <- phrase2C $ wrapPhrase phrase return $ text "while" <> parens e $$ p phrase2C (SwitchCase expr cases mphrase) = do e <- expr2C expr cs <- mapM case2C cases d <- dflt return $ text "switch" <> parens e $+$ braces (nest 4 . vcat $ cs ++ d) where case2C :: ([InitExpression], Phrase) -> State RenderState Doc case2C (e, p) = do ies <- mapM range2C e ph <- phrase2C p return $ vcat (map (\i -> text "case" <+> i <> colon) . concat $ ies) <> nest 4 (ph $+$ text "break;") dflt | isNothing mphrase = return [] | otherwise = do ph <- mapM phrase2C $ fromJust mphrase return [text "default:" <+> nest 4 (vcat ph)] phrase2C wb@(WithBlock ref p) = do r <- ref2C ref t <- gets lastType case t of (BTRecord _ rs) -> withRecordNamespace (render r ++ ".") rs $ phrase2C $ wrapPhrase p a -> do error $ "'with' block referencing non-record type " ++ show a ++ "\n" ++ show wb phrase2C (ForCycle i' e1' e2' p) = do i <- id2C IOLookup i' e1 <- expr2C e1' e2 <- expr2C e2' ph <- phrase2C (wrapPhrase p) return $ text "for" <> (parens . hsep . punctuate (char ';') $ [i <+> text "=" <+> e1, i <+> text "<=" <+> e2, text "++" <> i]) $$ ph phrase2C (RepeatCycle e' p') = do e <- expr2C e' p <- phrase2C (Phrases p') return $ text "do" <+> p <+> text "while" <> parens (text "!" <> parens e) <> semi phrase2C NOP = return $ text ";" phrase2C (BuiltInFunctionCall [] (SimpleReference (Identifier "exit" BTUnknown))) = do f <- gets currentFunctionResult if null f then return $ text "return" <> semi else return $ text "return" <+> text f <> semi phrase2C (BuiltInFunctionCall [] (SimpleReference (Identifier "break" BTUnknown))) = return $ text "break" <> semi phrase2C (BuiltInFunctionCall [] (SimpleReference (Identifier "continue" BTUnknown))) = return $ text "continue" <> semi phrase2C (BuiltInFunctionCall [e] (SimpleReference (Identifier "exit" BTUnknown))) = liftM (\e -> text "return" <+> e <> semi) $ expr2C e phrase2C (BuiltInFunctionCall [e] (SimpleReference (Identifier "dec" BTUnknown))) = liftM (\e -> text "--" <> e <> semi) $ expr2C e phrase2C (BuiltInFunctionCall [e1, e2] (SimpleReference (Identifier "dec" BTUnknown))) = liftM2 (\a b -> a <> text " -= " <> b <> semi) (expr2C e1) (expr2C e2) phrase2C (BuiltInFunctionCall [e] (SimpleReference (Identifier "inc" BTUnknown))) = liftM (\e -> text "++" <> e <> semi) $ expr2C e phrase2C (BuiltInFunctionCall [e1, e2] (SimpleReference (Identifier "inc" BTUnknown))) = liftM2 (\a b -> a <+> text "+=" <+> b <> semi) (expr2C e1) (expr2C e2) phrase2C a = error $ "phrase2C: " ++ show a 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 e1 <- expr2C expr1 t1 <- gets lastType e2 <- expr2C expr2 t2 <- gets lastType case (op2C op, t1, t2) of ("+", BTString, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strconcat" (BTFunction 2 BTString)) ("+", BTString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strappend" (BTFunction 2 BTString)) ("+", BTChar, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strprepend" (BTFunction 2 BTString)) ("+", BTChar, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_chrconcat" (BTFunction 2 BTString)) ("==", BTString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcomparec" (BTFunction 2 BTBool)) ("==", BTString, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcompare" (BTFunction 2 BTBool)) ("!=", BTString, _) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strncompare" (BTFunction 2 BTBool)) ("&", BTBool, _) -> return $ parens e1 <+> text "&&" <+> parens e2 ("|", BTBool, _) -> return $ parens e1 <+> text "||" <+> parens e2 (_, BTRecord t1 _, BTRecord t2 _) -> do i <- op2CTyped op [SimpleType (Identifier t1 undefined), SimpleType (Identifier t2 undefined)] ref2C $ FunCall [expr1, expr2] (SimpleReference i) (_, BTRecord t1 _, BTInt) -> do -- aw, "LongInt" here is hwengine-specific hack i <- op2CTyped op [SimpleType (Identifier t1 undefined), SimpleType (Identifier "LongInt" undefined)] ref2C $ FunCall [expr1, expr2] (SimpleReference i) ("in", _, _) -> case expr2 of SetExpression set -> do ids <- mapM (id2C IOLookup) set return . parens . hcat . punctuate (text " || ") . map (\i -> parens $ e1 <+> text "==" <+> i) $ ids _ -> error "'in' against not set expression" (o, _, _) | o `elem` boolOps -> do modify(\s -> s{lastType = BTBool}) return $ parens e1 <+> text o <+> parens e2 | otherwise -> return $ parens e1 <+> text o <+> parens e2 where boolOps = ["==", "!=", "<", ">", "<=", ">="] expr2C (NumberLiteral s) = do modify(\s -> s{lastType = BTInt}) return $ text s expr2C (FloatLiteral s) = return $ text s expr2C (HexNumber s) = return $ text "0x" <> (text . map toLower $ s) {-expr2C (StringLiteral [a]) = do modify(\s -> s{lastType = BTChar}) return . quotes . text $ escape a where escape '\'' = "\\\'" escape a = [a]-} expr2C (StringLiteral s) = addStringConst s expr2C (PCharLiteral s) = return . doubleQuotes $ text s expr2C (Reference ref) = ref2CF ref expr2C (PrefixOp op expr) = do e <- expr2C expr lt <- gets lastType case lt of BTRecord t _ -> do i <- op2CTyped op [SimpleType (Identifier t undefined)] ref2C $ FunCall [expr] (SimpleReference i) _ -> return $ text (op2C op) <> e expr2C Null = return $ text "NULL" expr2C (CharCode a) = do modify(\s -> s{lastType = BTChar}) return $ quotes $ text "\\x" <> text (showHex (read a) "") expr2C (HexCharCode a) = if length a <= 2 then return $ quotes $ text "\\x" <> text (map toLower a) else expr2C $ HexNumber a expr2C (SetExpression ids) = mapM (id2C IOLookup) ids >>= return . parens . hcat . punctuate (text " | ") 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 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 e' <- liftM (map toLower . render) $ expr2C e lt <- gets lastType case lt of BTEnum a -> return . int $ length a - 1 BTInt -> case e' of "longint" -> return $ int (2147483647) BTString -> return $ int 255 BTArray (RangeFromTo _ n) _ _ -> initExpr2C n _ -> error $ "BuiltInFunCall 'high' from " ++ show e ++ "\ntype: " ++ show lt expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "ord" _))) = liftM parens $ expr2C e expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "succ" _))) = liftM (<> text " + 1") $ expr2C e expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "pred" _))) = liftM (<> text " - 1") $ expr2C e expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "length" _))) = do e' <- expr2C e lt <- gets lastType modify (\s -> s{lastType = BTInt}) case lt of BTString -> return $ text "Length" <> parens e' BTArray {} -> return $ text "length_ar" <> parens e' _ -> error $ "length() called on " ++ show lt expr2C (BuiltInFunCall params ref) = do r <- ref2C ref t <- gets lastType ps <- mapM expr2C params case t of BTFunction _ t' -> do modify (\s -> s{lastType = t'}) _ -> error $ "BuiltInFunCall lastType: " ++ show t return $ r <> parens (hsep . punctuate (char ',') $ ps) expr2C a = error $ "Don't know how to render " ++ show a ref2CF :: Reference -> State RenderState Doc ref2CF (SimpleReference name) = do i <- id2C IOLookup name t <- gets lastType case t of BTFunction _ rt -> do modify(\s -> s{lastType = rt}) return $ i <> parens empty _ -> return $ i ref2CF r@(RecordField (SimpleReference _) (SimpleReference _)) = do i <- ref2C r t <- gets lastType case t of BTFunction _ rt -> do modify(\s -> s{lastType = rt}) return $ i <> parens empty _ -> return $ i ref2CF r = ref2C r ref2C :: Reference -> State RenderState Doc -- rewrite into proper form ref2C (RecordField ref1 (ArrayElement exprs ref2)) = ref2C $ ArrayElement exprs (RecordField ref1 ref2) ref2C (RecordField ref1 (Dereference ref2)) = ref2C $ Dereference (RecordField ref1 ref2) ref2C (RecordField ref1 (RecordField ref2 ref3)) = ref2C $ RecordField (RecordField ref1 ref2) ref3 ref2C (RecordField ref1 (FunCall params ref2)) = ref2C $ FunCall params (RecordField ref1 ref2) ref2C (ArrayElement (a:b:xs) ref) = ref2C $ ArrayElement (b:xs) (ArrayElement [a] ref) -- conversion routines ref2C ae@(ArrayElement [expr] ref) = do e <- expr2C expr r <- ref2C ref t <- gets lastType case t of (BTArray _ _ t') -> modify (\st -> st{lastType = t'}) -- (BTFunctionReturn _ (BTArray _ _ t')) -> modify (\st -> st{lastType = t'}) -- (BTFunctionReturn _ (BTString)) -> modify (\st -> st{lastType = BTChar}) (BTString) -> modify (\st -> st{lastType = BTChar}) (BTPointerTo t) -> do t'' <- fromPointer (show t) =<< gets lastType case t'' of BTChar -> modify (\st -> st{lastType = BTChar}) a -> error $ "Getting element of " ++ show a ++ "\nReference: " ++ show ae a -> error $ "Getting element of " ++ show a ++ "\nReference: " ++ show ae case t of BTString -> return $ r <> text ".s" <> brackets e _ -> return $ r <> brackets e ref2C (SimpleReference name) = id2C IOLookup name ref2C rf@(RecordField (Dereference ref1) ref2) = do r1 <- ref2C ref1 t <- fromPointer (show ref1) =<< gets lastType r2 <- case t of BTRecord _ rs -> withRecordNamespace "" rs $ ref2C ref2 BTUnit -> error "What??" a -> error $ "dereferencing from " ++ show a ++ "\n" ++ show rf return $ r1 <> text "->" <> r2 ref2C rf@(RecordField ref1 ref2) = do r1 <- ref2C ref1 t <- gets lastType case t of BTRecord _ rs -> do r2 <- withRecordNamespace "" rs $ ref2C ref2 return $ r1 <> text "." <> r2 BTUnit -> withLastIdNamespace $ ref2C ref2 a -> error $ "dereferencing from " ++ show a ++ "\n" ++ show rf ref2C d@(Dereference ref) = do r <- ref2C ref t <- fromPointer (show d) =<< gets lastType modify (\st -> st{lastType = t}) return $ (parens $ text "*" <> r) ref2C f@(FunCall params ref) = do r <- fref2C ref t <- gets lastType case t of BTFunction _ t' -> do ps <- liftM (parens . hsep . punctuate (char ',')) $ mapM expr2C params modify (\s -> s{lastType = t'}) return $ r <> ps _ -> case (ref, params) of (SimpleReference i, [p]) -> ref2C $ TypeCast i p _ -> error $ "ref2C FunCall erroneous type cast detected: " ++ show f ++ "\nType detected: " ++ show t where fref2C (SimpleReference name) = id2C (IOLookupFunction $ length params) name fref2C a = ref2C a ref2C (Address ref) = do r <- ref2C ref return $ text "&" <> parens r ref2C (TypeCast t'@(Identifier i _) expr) = do lt <- expr2C expr >> gets lastType case (map toLower i, lt) of ("pchar", BTString) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "_pchar" $ BTPointerTo BTChar)) ("shortstring", BTPointerTo _) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "pchar2str" $ BTString)) (a, _) -> do e <- expr2C expr t <- id2C IOLookup t' return . parens $ parens t <> e ref2C (RefExpression expr) = expr2C expr op2C :: String -> String op2C "or" = "|" op2C "and" = "&" op2C "not" = "!" op2C "xor" = "^" op2C "div" = "/" op2C "mod" = "%" op2C "shl" = "<<" op2C "shr" = ">>" op2C "<>" = "!=" op2C "=" = "==" op2C a = a