diff -r c61a4f68e6e9 -r 2d3232069c4b tools/pas2c.hs --- a/tools/pas2c.hs Tue Jan 31 22:04:41 2012 -0500 +++ b/tools/pas2c.hs Fri Feb 03 14:21:07 2012 +0400 @@ -17,10 +17,13 @@ import PascalParser import PascalUnitSyntaxTree + +type Record = (String, (String, BaseType)) data RenderState = RenderState { - currentScope :: [(String, String)], - namespaces :: Map.Map String [(String, String)] + currentScope :: [Record], + lastType :: BaseType, + namespaces :: Map.Map String [Record] } pas2C :: String -> IO () @@ -64,33 +67,34 @@ let ns = Map.map toNamespace units mapM_ (toCFiles ns) u where - toNamespace :: PascalUnit -> [(String, String)] + toNamespace :: PascalUnit -> [Record] toNamespace = concatMap tv2id . extractTVs extractTVs (System tv) = tv extractTVs (Program {}) = [] extractTVs (Unit _ (Interface _ (TypesAndVars tv)) _ _ _) = tv - tv2id :: TypeVarDeclaration -> [(String, String)] - tv2id (TypeDeclaration i (Sequence ids)) = map (\(Identifier i _) -> fi i) $ i : ids - tv2id (TypeDeclaration (Identifier i _) _) = [(map toLower i, i)] - tv2id (VarDeclaration _ (ids, _) _) = map (\(Identifier i _) -> fi i) ids - tv2id (FunctionDeclaration (Identifier i _) _ _ _) = [fi i] - tv2id (OperatorDeclaration i _ _ _ _) = [fi i] - fi i = (map toLower i, i) + tv2id :: TypeVarDeclaration -> [Record] + tv2id (TypeDeclaration i t@(Sequence ids)) = map (\(Identifier i _) -> fi i (type2BaseType t)) $ i : ids + tv2id (TypeDeclaration (Identifier i _) t) = [(map toLower i, (i, type2BaseType t))] + tv2id (VarDeclaration _ (ids, t) _) = map (\(Identifier i _) -> fi i (type2BaseType t)) ids + tv2id (FunctionDeclaration (Identifier i _) _ _ _) = [fi i BTUnknown] + tv2id (OperatorDeclaration i _ _ _ _) = [fi i BTUnknown] + fi i t = (map toLower i, (i, t)) - -toCFiles :: Map.Map String [(String, String)] -> (String, PascalUnit) -> IO () + +toCFiles :: Map.Map String [Record] -> (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 (RenderState [] ns) . pascal2C) p + toCFiles' (fn, p@(Program {})) = writeFile (fn ++ ".c") $ (render2C initialState . pascal2C) p toCFiles' (fn, (Unit _ interface implementation _ _)) = do - let (a, s) = runState (interface2C interface) (RenderState [] ns) + let (a, s) = runState (interface2C interface) initialState writeFile (fn ++ ".h") $ "#pragma once\n" ++ (render a) writeFile (fn ++ ".c") $ (render2C s . implementation2C) implementation + initialState = RenderState [] BTUnknown ns render2C :: RenderState -> State RenderState Doc -> String render2C a = render . flip evalState a @@ -139,18 +143,22 @@ id2C :: Bool -> Identifier -> State RenderState Doc -id2C True (Identifier i _) = do - modify (\s -> s{currentScope = (map toLower i, i) : currentScope s}) +id2C True (Identifier i t) = do + modify (\s -> s{currentScope = (map toLower i, (i, t)) : currentScope s}) return $ text i -id2C False (Identifier i _) = do +id2C False (Identifier i t) = do let i' = map toLower i v <- gets $ find (\(a, _) -> a == i') . currentScope --ns <- gets currentScope + modify (\s -> s{lastType = t}) if isNothing v then error $ "Not defined: '" ++ i' ++ "'"-- ++ show ns else - return . text . snd . fromJust $ v + return . text . fst . snd . fromJust $ v +id2CTyped :: BaseType -> Identifier -> State RenderState Doc +id2CTyped BTUnknown i = error $ show i +id2CTyped bt (Identifier i _) = id2C True (Identifier i bt) tvar2C :: Bool -> TypeVarDeclaration -> State RenderState Doc tvar2C _ (FunctionDeclaration name returnType params Nothing) = do @@ -177,14 +185,15 @@ phrase2C' p = phrase2C p tvar2C False (FunctionDeclaration (Identifier name _) _ _ _) = error $ "nested functions not allowed: " ++ name -tvar2C _ (TypeDeclaration i' t) = do + +tvar2C _ td@(TypeDeclaration i' t) = do tp <- type2C t - i <- id2C True i' + i <- id2CTyped (type2BaseType t) i' return $ text "type" <+> i <+> tp <> text ";" tvar2C _ (VarDeclaration isConst (ids, t) mInitExpr) = do t' <- type2C t - i <- mapM (id2C True) ids + i <- mapM (id2CTyped (type2BaseType t)) ids ie <- initExpr mInitExpr return $ if isConst then text "const" else empty <+> t' @@ -196,7 +205,7 @@ initExpr (Just e) = liftM (text "=" <+>) (initExpr2C e) tvar2C f (OperatorDeclaration op _ ret params body) = - tvar2C f (FunctionDeclaration (Identifier ("") Unknown) ret params body) + tvar2C f (FunctionDeclaration (Identifier ("") BTUnknown) ret params body) initExpr2C :: InitExpression -> State RenderState Doc @@ -326,8 +335,12 @@ r2 <- ref2C ref2 return $ r1 <> text "->" <> r2 -ref2C (RecordField ref1 ref2) = do - r1 <- ref2C ref1 +ref2C rf@(RecordField ref1 ref2) = do + r1 <- ref2C ref1 + t <- gets lastType + case t of + r@(BTRecord _) -> error $ show r + a -> error $ "dereferencing from " ++ show a ++ " - " ++ show rf r2 <- ref2C ref2 return $ r1 <> text "." <> r2