tools/pas2c.hs
changeset 6626 a447993f2ad7
parent 6618 2d3232069c4b
child 6635 c2fa29fe2a58
--- 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 "<<array type>>"
 type2C (Set t) = return $ text "<<set>>"
 type2C (FunctionType returnType params) = return $ text "<<function>>"
+type2C (DeriveType _) = return $ text "<<type derived from constant literal>>"
 
 phrase2C :: Phrase -> State RenderState Doc
 phrase2C (Phrases p) = do