# HG changeset patch
# User unc0rr
# Date 1332791652 -14400
# Node ID a0e152e683374ab0873d05a6bc4c919f92e1716d
# Parent  8fadeefdd352263365a8d96e6dfab5a2406f2099
Dig into namespaces even more

diff -r 8fadeefdd352 -r a0e152e68337 tools/PascalUnitSyntaxTree.hs
--- a/tools/PascalUnitSyntaxTree.hs	Mon Mar 26 17:56:15 2012 +0400
+++ b/tools/PascalUnitSyntaxTree.hs	Mon Mar 26 23:54:12 2012 +0400
@@ -102,10 +102,11 @@
     | BTInt
     | BTBool
     | BTFloat
-    | BTRecord
+    | BTRecord [(String, BaseType)]
     | BTArray BaseType BaseType
     | BTFunction BaseType
     | BTPointerTo BaseType
+    | BTUnresolved String
     | BTSet BaseType
     | BTEnum [String]
     | BTVoid
diff -r 8fadeefdd352 -r a0e152e68337 tools/pas2c.hs
--- a/tools/pas2c.hs	Mon Mar 26 17:56:15 2012 +0400
+++ b/tools/pas2c.hs	Mon Mar 26 23:54:12 2012 +0400
@@ -80,14 +80,23 @@
     toNamespace nss (Unit _ interface _ _ _) = 
         currentScope $ execState (interface2C interface) (RenderState [] "" BTUnknown nss)
 
-   
+
+withState' :: (a -> a) -> State a b -> State a b
+withState' f s = do
+    st <- gets id
+    return $ evalState s (f st)
+
 withLastIdNamespace :: State RenderState Doc -> State RenderState Doc
 withLastIdNamespace f = do
     li <- gets lastIdentifier
     nss <- gets namespaces
-    st <- gets id
-    error $ show $ Map.keys nss
-    return $ evalState f st{currentScope = fromMaybe [] $ Map.lookup li (namespaces st)}
+    withState' (\st -> st{currentScope = fromMaybe [] $ Map.lookup li (namespaces st)}) f
+
+withRecordNamespace :: [(String, BaseType)] -> State RenderState Doc -> State RenderState Doc
+withRecordNamespace recs = withState' f
+    where
+        f st = st{currentScope = records ++ currentScope st}
+        records = map (\(a, b) -> (map toLower a, (a, b))) recs
 
 toCFiles :: Map.Map String [Record] -> (String, PascalUnit) -> IO ()
 toCFiles _ (_, System _) = return ()
@@ -196,15 +205,14 @@
     f "char" = BTChar
     f "string" = BTString
     f _ = error $ "Unknown system type: " ++ show st
-resolveType (PointerTo t) = return $ BTPointerTo BTUnknown  -- can't resolveType for t here
+resolveType (PointerTo (SimpleType (Identifier i _))) = return . BTPointerTo $ BTUnresolved (map toLower i)
+resolveType (PointerTo t) = liftM BTPointerTo $ resolveType t
 resolveType (RecordType tv mtvs) = do
-    li <- gets lastIdentifier
-    tvs <- liftM concat $ mapM f (concat $ tv : fromMaybe [] mtvs)
-    modify (\s -> s{namespaces = Map.insert li tvs (namespaces s)})
-    return BTRecord
+    tvs <- mapM f (concat $ tv : fromMaybe [] mtvs)
+    return . BTRecord . concat $ tvs
     where
-        f :: TypeVarDeclaration -> State RenderState [Record]
-        f (VarDeclaration _ (ids, td) _) = mapM (\(Identifier i _) -> liftM (\t -> (map toLower i, (i, t))) $ resolveType td) ids
+        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 t _) = liftM BTFunction $ resolveType t
@@ -227,8 +235,10 @@
     
 tvar2C True (FunctionDeclaration name returnType params (Just (tvars, phrase))) = do
     t <- type2C returnType 
-    p <- liftM hcat $ mapM (tvar2C False) params
-    ph <- liftM2 ($+$) (typesAndVars2C False tvars) (phrase2C' phrase)
+    (p, ph) <- withState' id $ do
+        p <- liftM hcat $ mapM (tvar2C False) params
+        ph <- liftM2 ($+$) (typesAndVars2C False tvars) (phrase2C' phrase)
+        return (p, ph)
     n <- id2C IOInsert name
     return $ 
         t <+> n <> parens p
@@ -384,8 +394,12 @@
 
 
 ref2C :: Reference -> State RenderState Doc
-ref2C (ArrayElement exprs ref) = do
+ref2C ae@(ArrayElement exprs ref) = do
     r <- ref2C ref 
+    t <- gets lastType
+    case t of
+         (BTArray _ t') -> modify (\st -> st{lastType = t'})
+         a -> error $ show a ++ "\n" ++ show ae
     es <- mapM expr2C exprs
     return $ r <> (brackets . hcat) (punctuate comma es)
 ref2C (SimpleReference name) = id2C IOLookup name
@@ -398,12 +412,18 @@
     r1 <- ref2C ref1
     t <- gets lastType
     r2 <- case t of
-        BTRecord -> withLastIdNamespace $ ref2C ref2
+        BTRecord rs -> withRecordNamespace rs $ ref2C ref2
         BTUnit -> withLastIdNamespace $ ref2C ref2
         a -> error $ "dereferencing from " ++ show a ++ " - " ++ show rf
     return $ 
         r1 <> text "." <> r2
-ref2C (Dereference ref) = liftM ((parens $ text "*") <>) $ ref2C ref
+ref2C (Dereference ref) = do
+    r <- ref2C ref
+    t <- gets lastType
+    case t of
+         (BTPointerTo t') -> modify (\st -> st{lastType = t'})
+         a -> error $ "Dereferencing from non-pointer type " ++ show a
+    return $ (parens $ text "*") <> r
 ref2C (FunCall params ref) = do
     ps <- liftM (parens . hsep . punctuate (char ',')) $ mapM expr2C params
     r <- ref2C ref