diff -r 2dc43ce68721 -r c2fa29fe2a58 tools/pas2c.hs --- a/tools/pas2c.hs Sun Feb 05 22:22:46 2012 -0500 +++ b/tools/pas2c.hs Mon Feb 06 23:17:45 2012 +0400 @@ -64,28 +64,21 @@ renderCFiles :: Map.Map String PascalUnit -> IO () renderCFiles units = do let u = Map.toList units - let ns = Map.map toNamespace units - mapM_ (toCFiles ns) u + let nss = Map.map (toNamespace nss) units + mapM_ (toCFiles nss) u where - toNamespace :: PascalUnit -> [Record] - toNamespace = concatMap tv2id . extractTVs - - extractTVs (System tv) = tv - extractTVs (Program {}) = [] - extractTVs (Unit _ (Interface _ (TypesAndVars tv)) _ _ _) = tv - - tv2id :: TypeVarDeclaration -> [Record] - tv2id (TypeDeclaration i t@(Sequence ids)) = map (\(Identifier i _) -> fi i BTUnknown) $ i : ids - tv2id (TypeDeclaration (Identifier i _) t) = [(map toLower i, (i, BTUnknown))] - tv2id (VarDeclaration _ (ids, t) _) = map (\(Identifier i _) -> fi i BTUnknown) ids - tv2id (FunctionDeclaration (Identifier i _) _ _ _) = [fi i BTUnknown] - tv2id (OperatorDeclaration i _ _ _ _) = [fi i BTUnknown] - fi i t = (map toLower i, (i, t)) - + toNamespace :: Map.Map String [Record] -> PascalUnit -> [Record] + toNamespace nss (System tvs) = + currentScope $ execState (mapM_ (tvar2C True) tvs) (RenderState [] BTUnknown nss) + toNamespace _ (Program {}) = [] + toNamespace nss (Unit _ interface _ _ _) = + currentScope $ execState (interface2C interface) (RenderState [] BTUnknown nss) + toCFiles :: Map.Map String [Record] -> (String, PascalUnit) -> IO () toCFiles _ (_, System _) = return () toCFiles ns p@(fn, pu) = do + hPutStrLn stdout $ show $ Map.lookup "pas2cSystem" ns hPutStrLn stderr $ "Rendering '" ++ fn ++ "'..." toCFiles' p where @@ -149,10 +142,10 @@ id2C False (Identifier i t) = do let i' = map toLower i v <- gets $ find (\(a, _) -> a == i') . currentScope - --ns <- gets currentScope + ns <- gets currentScope modify (\s -> s{lastType = t}) if isNothing v then - error $ "Not defined: '" ++ i' ++ "'"-- ++ show ns + error $ "Not defined: '" ++ i' ++ "'\n" ++ show ns else return . text . fst . snd . fromJust $ v @@ -171,7 +164,8 @@ where f "integer" = BTInt f "pointer" = BTPointerTo BTVoid - f _ = error $ show st + f "boolean" = BTBool + f _ = error $ "Unknown system type: " ++ show st resolveType (PointerTo t) = liftM BTPointerTo $ resolveType t resolveType (RecordType tv mtvs) = do tvs <- mapM f (concat $ tv : fromMaybe [] mtvs) @@ -183,6 +177,7 @@ resolveType (ArrayDecl Nothing t) = liftM (BTArray BTInt) $ resolveType t resolveType (FunctionType _ _) = return BTFunction resolveType (DeriveType _) = return BTInt +resolveType (String _) = return BTString --resolveType UnknownType = return BTUnknown resolveType a = error $ "resolveType: " ++ show a @@ -216,6 +211,7 @@ tvar2C _ td@(TypeDeclaration i' t) = do tp <- type2C t tb <- resolveType t + error $ show (td, tb) i <- id2CTyped tb i' return $ text "type" <+> i <+> tp <> text ";"