diff -r a3b428e74410 -r 1ef4192aa80d tools/pas2c.hs --- a/tools/pas2c.hs Fri Nov 25 05:15:38 2011 +0100 +++ b/tools/pas2c.hs Fri Nov 25 18:36:12 2011 +0300 @@ -12,30 +12,44 @@ import PascalPreprocessor import Control.Exception import System.IO.Error -import qualified Data.Set as Set +import qualified Data.Map as Map -pas2C :: String -> IO String -pas2C = flip evalStateT initState . f +pas2C :: String -> IO () +pas2C fn = do + setCurrentDirectory "../hedgewars/" + flip evalStateT initState $ f fn where printLn = liftIO . hPutStrLn stderr - initState = Set.empty - f :: String -> StateT (Set.Set String) IO String + initState = Map.empty + f :: String -> StateT (Map.Map String PascalUnit) IO () f fileName = do - liftIO $ setCurrentDirectory "../hedgewars/" - - fc' <- liftIO $ tryJust (guard . isDoesNotExistError) $ preprocess fileName - case fc' of - (Left a) -> return "" - (Right fc) -> do - modify $ Set.insert fileName - printLn $ "Preprocessed " ++ fileName - liftIO $ writeFile "debug.txt" fc - let ptree = parse pascalUnit fileName fc - case ptree of - (Left a) -> return (show a) - (Right a) -> (return . render . pascal2C) a + processed <- gets $ Map.member fileName + unless processed $ do + fc' <- liftIO + $ tryJust (guard . isDoesNotExistError) + $ hPutStr stderr ("Preprocessing '" ++ fileName ++ ".pas'... ") >> preprocess (fileName ++ ".pas") + case fc' of + (Left a) -> printLn "doesn't exist" + (Right fc) -> do + printLn "ok" + 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 + modify (Map.insert fileName a) + mapM_ f (usesFiles a) + +usesFiles :: PascalUnit -> [String] +usesFiles (Program _ (Implementation uses _) _) = uses2List uses +usesFiles (Unit _ (Interface uses1 _) (Implementation uses2 _) _ _) = uses2List uses1 ++ uses2List uses2 + + + pascal2C :: PascalUnit -> Doc pascal2C (Unit unitName interface implementation init fin) = interface2C interface @@ -44,29 +58,40 @@ pascal2C (Program _ implementation mainFunction) = implementation2C implementation $+$ - tvar2C (FunctionDeclaration (Identifier "main") (SimpleType $ Identifier "int") (Just (TypesAndVars [], mainFunction))) + tvar2C (FunctionDeclaration (Identifier "main") (SimpleType $ Identifier "int") [] (Just (TypesAndVars [], mainFunction))) interface2C :: Interface -> Doc -interface2C (Interface uses tvars) = typesAndVars2C tvars +interface2C (Interface uses tvars) = uses2C uses $+$ typesAndVars2C tvars implementation2C :: Implementation -> Doc -implementation2C (Implementation uses tvars) = typesAndVars2C tvars +implementation2C (Implementation uses tvars) = uses2C uses $+$ typesAndVars2C tvars typesAndVars2C :: TypesAndVars -> Doc typesAndVars2C (TypesAndVars ts) = vcat $ map tvar2C ts +uses2C :: Uses -> Doc +uses2C uses = vcat $ map (\i -> text $ "#include \"" ++ i ++ ".h\"") $ uses2List uses + +uses2List :: Uses -> [String] +uses2List (Uses ids) = map (\(Identifier i) -> i) ids tvar2C :: TypeVarDeclaration -> Doc -tvar2C (FunctionDeclaration (Identifier name) returnType Nothing) = +tvar2C (FunctionDeclaration (Identifier name) returnType params Nothing) = type2C returnType <+> text (name ++ "();") -tvar2C (FunctionDeclaration (Identifier name) returnType (Just (tvars, phrase))) = +tvar2C (FunctionDeclaration (Identifier name) returnType params (Just (tvars, phrase))) = type2C returnType <+> text (name ++ "()") - $$ - text "{" $+$ (nest 4 $ typesAndVars2C tvars) $+$ - phrase2C phrase - $+$ + text "{" + $+$ nest 4 ( + typesAndVars2C tvars + $+$ + phrase2C' phrase + ) + $+$ text "}" + where + phrase2C' (Phrases p) = vcat $ map phrase2C p + phrase2C' p = phrase2C p tvar2C (TypeDeclaration (Identifier i) t) = text "type" <+> text i <+> type2C t <> text ";" tvar2C (VarDeclaration isConst (ids, t) mInitExpr) = if isConst then text "const" else empty @@ -98,7 +123,7 @@ type2C (String l) = text $ "string" ++ show l type2C (SimpleType (Identifier i)) = text i type2C (PointerTo t) = type2C t <> text "*" -type2C (RecordType tvs) = text "{" $+$ (nest 4 . vcat . map tvar2C $ tvs) $+$ text "}" +type2C (RecordType tvs union) = text "{" $+$ (nest 4 . vcat . map tvar2C $ tvs) $+$ text "}" type2C (RangeType r) = text "<>" type2C (Sequence ids) = text "<>" type2C (ArrayDecl r t) = text "<>"