hedgewars: comparison tools/pas2c.hs

equal deleted inserted replaced

-:162bc562335b
+:59b5b19e6604
 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)],
 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
 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
 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
 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"
 --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
 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
 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
 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
 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 (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
 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
 (_, 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' (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
 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]]
 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
 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))
 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'
 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"
 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
 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})
 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
 (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

changeset 7315	59b5b19e6604
parent 7265	3f96073156e1
child 7317	3534a264b27a