diff -r 2d8c5815292f -r a447993f2ad7 tools/pas2c.hs --- a/tools/pas2c.hs Sun Feb 05 15:55:15 2012 +0100 +++ b/tools/pas2c.hs Sun Feb 05 23:24:43 2012 +0400 @@ -75,9 +75,9 @@ extractTVs (Unit _ (Interface _ (TypesAndVars tv)) _ _ _) = tv 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 (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)) @@ -157,8 +157,35 @@ return . text . fst . snd . fromJust $ v id2CTyped :: BaseType -> Identifier -> State RenderState Doc -id2CTyped BTUnknown i = error $ show i +id2CTyped BTUnknown i = do + ns <- gets currentScope + error $ show i ++ "\n" ++ show ns id2CTyped bt (Identifier i _) = id2C True (Identifier i bt) + + +resolveType :: TypeDecl -> State RenderState BaseType +resolveType st@(SimpleType (Identifier i _)) = do + let i' = map toLower i + v <- gets $ find (\(a, _) -> a == i') . currentScope + if isJust v then return . snd . snd $ fromJust v else return $ f i' + where + f "integer" = BTInt + f "pointer" = BTPointerTo BTVoid + f _ = error $ show st +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 _) t) = liftM (BTArray BTInt) $ resolveType t +resolveType (ArrayDecl Nothing t) = liftM (BTArray BTInt) $ resolveType t +resolveType (FunctionType _ _) = return BTFunction +resolveType (DeriveType _) = return BTInt +--resolveType UnknownType = return BTUnknown +resolveType a = error $ "resolveType: " ++ show a + tvar2C :: Bool -> TypeVarDeclaration -> State RenderState Doc tvar2C _ (FunctionDeclaration name returnType params Nothing) = do @@ -188,12 +215,14 @@ tvar2C _ td@(TypeDeclaration i' t) = do tp <- type2C t - i <- id2CTyped (type2BaseType t) i' + tb <- resolveType t + i <- id2CTyped tb i' return $ text "type" <+> i <+> tp <> text ";" tvar2C _ (VarDeclaration isConst (ids, t) mInitExpr) = do t' <- type2C t - i <- mapM (id2CTyped (type2BaseType t)) ids + tb <- resolveType t + i <- mapM (id2CTyped tb) ids ie <- initExpr mInitExpr return $ if isConst then text "const" else empty <+> t' @@ -238,6 +267,7 @@ type2C (ArrayDecl r t) = return $ text "<>" type2C (Set t) = return $ text "<>" type2C (FunctionType returnType params) = return $ text "<>" +type2C (DeriveType _) = return $ text "<>" phrase2C :: Phrase -> State RenderState Doc phrase2C (Phrases p) = do