diff -r 6a1f46c026bf -r 333afe233886 tools/pas2c.hs
--- a/tools/pas2c.hs	Thu May 03 19:00:17 2012 +0200
+++ b/tools/pas2c.hs	Sat May 05 00:01:12 2012 +0400
@@ -25,18 +25,18 @@
     | IOLookup
     | IODeferred
 
-type Record = (String, (String, BaseType))
+type Records = Map.Map String [(String, BaseType)]
 data RenderState = RenderState 
     {
-        currentScope :: [Record],
+        currentScope :: Records,
         lastIdentifier :: String,
         lastType :: BaseType,
         stringConsts :: [(String, String)],
         uniqCounter :: Int,
-        namespaces :: Map.Map String [Record]
+        namespaces :: Map.Map String Records
     }
     
-emptyState = RenderState [] "" BTUnknown [] 0
+emptyState = RenderState Map.empty "" BTUnknown [] 0
 
 getUniq :: State RenderState Int
 getUniq = do
@@ -115,14 +115,14 @@
 renderCFiles units = do
     let u = Map.toList units
     let nss = Map.map (toNamespace nss) units
-    hPutStrLn stderr $ "Units: " ++ (show . Map.keys . Map.filter (not . null) $ nss)
+    hPutStrLn stderr $ "Units: " ++ (show . Map.keys . Map.filter (not . Map.null) $ nss)
     --writeFile "pas2c.log" $ unlines . map (\t -> show (fst t) ++ "\n" ++ (unlines . map ((:) '\t' . show) . snd $ t)) . Map.toList $ nss
     mapM_ (toCFiles nss) u
     where
-    toNamespace :: Map.Map String [Record] -> PascalUnit -> [Record]
+    toNamespace :: Map.Map String Records -> PascalUnit -> Records
     toNamespace nss (System tvs) = 
         currentScope $ execState (mapM_ (tvar2C True) tvs) (emptyState nss)
-    toNamespace _ (Program {}) = []
+    toNamespace _ (Program {}) = Map.empty
     toNamespace nss (Unit _ interface _ _ _) = 
         currentScope $ execState (interface2C interface) (emptyState nss)
 
@@ -142,16 +142,17 @@
 withLastIdNamespace f = do
     li <- gets lastIdentifier
     nss <- gets namespaces
-    withState' (\st -> st{currentScope = fromMaybe [] $ Map.lookup li (namespaces st)}) f
+    withState' (\st -> st{currentScope = fromMaybe Map.empty $ Map.lookup li (namespaces st)}) f
 
 withRecordNamespace :: String -> [(String, BaseType)] -> State RenderState Doc -> State RenderState Doc
 withRecordNamespace _ [] = error "withRecordNamespace: empty record"
 withRecordNamespace prefix recs = withState' f
     where
-        f st = st{currentScope = records ++ currentScope st}
-        records = map (\(a, b) -> (map toLower a, (prefix ++ a, b))) recs
+        f st = st{currentScope = Map.unionWith un records (currentScope st)}
+        records = Map.fromList $ map (\(a, b) -> (map toLower a, [(prefix ++ a, b)])) recs
+        un [a] b = a : b
 
-toCFiles :: Map.Map String [Record] -> (String, PascalUnit) -> IO ()
+toCFiles :: Map.Map String Records -> (String, PascalUnit) -> IO ()
 toCFiles _ (_, System _) = return ()
 toCFiles ns p@(fn, pu) = do
     hPutStrLn stderr $ "Rendering '" ++ fn ++ "'..."
@@ -214,8 +215,7 @@
     where
     injectNamespace (Identifier i _) = do
         getNS <- gets (flip Map.lookup . namespaces)
-        let f = flip (foldl (flip (:))) (fromMaybe [] (getNS i))
-        modify (\s -> s{currentScope = f $ currentScope s})
+        modify (\s -> s{currentScope = Map.unionWith (++) (fromMaybe Map.empty (getNS i)) $ currentScope s})
 
 uses2List :: Uses -> [String]
 uses2List (Uses ids) = map (\(Identifier i _) -> i) ids
@@ -229,35 +229,32 @@
             ns <- gets currentScope
             error $ "id2C IOInsert: type BTUnknown for " ++ show i ++ "\nnamespace: " ++ show (take 100 ns)
         _ -> do --}
-    modify (\s -> s{currentScope = (n, (i, t)) : currentScope s, lastIdentifier = n})
+    modify (\s -> s{currentScope = Map.insertWith (++) n [(i, t)] (currentScope s), lastIdentifier = n})
     return $ text i
     where
         n = map toLower i
 id2C IOLookup (Identifier i t) = do
     let i' = map toLower i
-    v <- gets $ find (\(a, _) -> a == i') . currentScope
-    ns <- gets currentScope
+    v <- gets $ Map.lookup i' . currentScope
     lt <- gets lastType
     if isNothing v then 
-        error $ "Not defined: '" ++ i' ++ "'\n" ++ show lt ++ "\n" ++ show (take 100 ns)
+        error $ "Not defined: '" ++ i' ++ "'\n" ++ show lt
         else 
-        let vv = snd $ fromJust v in modify (\s -> s{lastType = snd vv, lastIdentifier = fst vv}) >> (return . text . fst $ vv)
+        let vv = head $ fromJust v in modify (\s -> s{lastType = snd vv, lastIdentifier = fst vv}) >> (return . text . fst $ vv)
 id2C IODeferred (Identifier i t) = do
     let i' = map toLower i
-    v <- gets $ find (\(a, _) -> a == i') . currentScope
+    v <- gets $ Map.lookup i' . currentScope
     if (isNothing v) then
         return $ text i
         else
-        return . text . fst . snd . fromJust $ v
+        return . text . fst . head . fromJust $ v
 
 id2CTyped :: TypeDecl -> Identifier -> State RenderState Doc
 id2CTyped t (Identifier i _) = do
     tb <- resolveType t
-    ns <- gets currentScope
     case tb of 
         BTUnknown -> do
-            ns <- gets currentScope
-            error $ "id2CTyped: type BTUnknown for " ++ show i ++ "\ntype: " ++ show t ++ "\nnamespace: " ++ show (take 100 ns)
+            error $ "id2CTyped: type BTUnknown for " ++ show i ++ "\ntype: " ++ show t
         _ -> return ()
     id2C IOInsert (Identifier i tb)
 
@@ -265,8 +262,8 @@
 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'
+    v <- gets $ Map.lookup i' . currentScope
+    if isJust v then return . snd . head $ fromJust v else return $ f i'
     where
     f "integer" = BTInt
     f "pointer" = BTPointerTo BTVoid
@@ -287,7 +284,7 @@
     t' <- resolveType t
     return $ BTArray i BTInt t' 
 resolveType (ArrayDecl Nothing t) = liftM (BTArray RangeInfinite BTInt) $ resolveType t
-resolveType (FunctionType t _) = liftM BTFunction $ resolveType t
+resolveType (FunctionType t a) = liftM (BTFunction (length a)) $ resolveType t
 resolveType (DeriveType (InitHexNumber _)) = return BTInt
 resolveType (DeriveType (InitNumber _)) = return BTInt
 resolveType (DeriveType (InitFloat _)) = return BTFloat
@@ -306,9 +303,9 @@
 
 resolve :: String -> BaseType -> State RenderState BaseType
 resolve s (BTUnresolved t) = do
-    v <- gets $ find (\(a, _) -> a == t) . currentScope
+    v <- gets $ Map.lookup t . currentScope
     if isJust v then
-        resolve s . snd . snd . fromJust $ v
+        resolve s . snd . head . fromJust $ v
         else
         error $ "Unknown type " ++ show t ++ "\n" ++ s
 resolve _ t = return t
@@ -317,8 +314,7 @@
 fromPointer s (BTPointerTo t) = resolve s t
 fromPointer s (BTFunctionReturn _ (BTPointerTo t)) = resolve s t
 fromPointer s t = do
-    ns <- gets currentScope
-    error $ "Dereferencing from non-pointer type " ++ show t ++ "\n" ++ s ++ "\n\n" ++ show (take 100 ns)
+    error $ "Dereferencing from non-pointer type " ++ show t ++ "\n" ++ s
 
     
 functionParams2C params = liftM (hcat . punctuate comma . concat) $ mapM (tvar2C False) params
@@ -328,15 +324,15 @@
     t <- type2C returnType 
     t'<- gets lastType
     p <- withState' id $ functionParams2C params
-    n <- id2C IOInsert $ setBaseType (BTFunction t') name
+    n <- id2C IOInsert $ setBaseType (BTFunction (length params) t') name
     return [t empty <+> n <> parens p]
     
 fun2C True rv (FunctionDeclaration name returnType params (Just (tvars, phrase))) = do
     let res = docToLower $ text rv <> text "_result"
     t <- type2C returnType
     t'<- gets lastType
-    n <- id2C IOInsert $ setBaseType (BTFunction t') name
-    (p, ph) <- withState' (\st -> st{currentScope = (map toLower rv, (render res, BTFunctionReturn (render n) t')) : currentScope st}) $ do
+    n <- id2C IOInsert $ setBaseType (BTFunction (length params) t') name
+    (p, ph) <- withState' (\st -> st{currentScope = Map.insertWith un (map toLower rv) [(render res, BTFunctionReturn (render n) t')] $ currentScope st}) $ do
         p <- functionParams2C params
         ph <- liftM2 ($+$) (typesAndVars2C False tvars) (phrase2C' phrase)
         return (p, ph)
@@ -354,6 +350,7 @@
     where
     phrase2C' (Phrases p) = liftM vcat $ mapM phrase2C p
     phrase2C' p = phrase2C p
+    un [a] b = a : b
     
 fun2C False _ (FunctionDeclaration (Identifier name _) _ _ _) = error $ "nested functions not allowed: " ++ name
 fun2C _ tv _ = error $ "fun2C: I don't render " ++ show tv
@@ -556,7 +553,7 @@
     r <- ref2C ref
     t <- gets lastType
     e <- case (t, expr) of
-         (BTFunction _, (Reference r')) -> ref2C r'
+         (BTFunction {}, (Reference r')) -> ref2C r'
          _ -> expr2C expr
     return $ r <+> text "=" <+> e <> semi
 phrase2C (WhileCycle expr phrase) = do
@@ -587,8 +584,7 @@
     case t of
         (BTRecord rs) -> withRecordNamespace (render r ++ ".") rs $ phrase2C $ wrapPhrase p
         a -> do
-            ns <- gets currentScope
-            error $ "'with' block referencing non-record type " ++ show a ++ "\n" ++ show wb ++ "\nnamespace: " ++ show (take 100 ns)
+            error $ "'with' block referencing non-record type " ++ show a ++ "\n" ++ show wb
 phrase2C (ForCycle i' e1' e2' p) = do
     i <- id2C IOLookup i'
     e1 <- expr2C e1'
@@ -623,11 +619,11 @@
     e2 <- expr2C expr2
     t2 <- gets lastType
     case (op2C op, t1, t2) of
-        ("+", BTString, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strconcat" (BTFunction BTString))
-        ("+", BTString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strappend" (BTFunction BTString))
-        ("+", BTChar, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strprepend" (BTFunction BTString))
-        ("==", BTString, _) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcompare" (BTFunction BTBool))
-        ("!=", BTString, _) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strncompare" (BTFunction BTBool))
+        ("+", BTString, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strconcat" (BTFunction 2 BTString))
+        ("+", BTString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strappend" (BTFunction 2 BTString))
+        ("+", BTChar, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strprepend" (BTFunction 2 BTString))
+        ("==", BTString, _) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcompare" (BTFunction 2 BTBool))
+        ("!=", BTString, _) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strncompare" (BTFunction 2 BTBool))
         ("&", BTBool, _) -> return $ parens e1 <+> text "&&" <+> parens e2
         ("|", BTBool, _) -> return $ parens e1 <+> text "||" <+> parens e2
         (o, _, _) | o `elem` boolOps -> do
@@ -660,7 +656,7 @@
     t <- gets lastType
     ps <- mapM expr2C params
     case t of
-        BTFunction t' -> do
+        BTFunction _ t' -> do
             modify (\s -> s{lastType = t'})
         _ -> error $ "BuiltInFunCall lastType: " ++ show t
     return $ 
@@ -672,7 +668,7 @@
     i <- id2C IOLookup name
     t <- gets lastType
     case t of
-         BTFunction _ -> return $ i <> parens empty
+         BTFunction {} -> return $ i <> parens empty
          _ -> return $ i
 ref2CF r = ref2C r
 
@@ -688,7 +684,6 @@
     e <- expr2C expr
     r <- ref2C ref 
     t <- gets lastType
-    ns <- gets currentScope
     case t of
          (BTArray _ _ t') -> modify (\st -> st{lastType = t'})
          (BTFunctionReturn _ (BTArray _ _ t')) -> modify (\st -> st{lastType = t'})
@@ -698,8 +693,8 @@
                 t'' <- fromPointer (show t) =<< gets lastType
                 case t'' of
                      BTChar -> modify (\st -> st{lastType = BTChar})
-                     a -> error $ "Getting element of " ++ show a ++ "\nReference: " ++ show ae ++ "\n" ++ show (take 100 ns)
-         a -> error $ "Getting element of " ++ show a ++ "\nReference: " ++ show ae ++ "\n" ++ show (take 100 ns)
+                     a -> error $ "Getting element of " ++ show a ++ "\nReference: " ++ show ae
+         a -> error $ "Getting element of " ++ show a ++ "\nReference: " ++ show ae
     case t of
          BTString ->  return $ r <> text ".s" <> brackets e
          _ -> return $ r <> brackets e
@@ -707,22 +702,20 @@
 ref2C rf@(RecordField (Dereference ref1) ref2) = do
     r1 <- ref2C ref1 
     t <- fromPointer (show ref1) =<< gets lastType
-    ns <- gets currentScope
     r2 <- case t of
         BTRecord rs -> withRecordNamespace "" rs $ ref2C ref2
         BTUnit -> withLastIdNamespace $ ref2C ref2
-        a -> error $ "dereferencing from " ++ show a ++ "\n" ++ show rf ++ "\n" ++ show (take 100 ns)
+        a -> error $ "dereferencing from " ++ show a ++ "\n" ++ show rf
     return $ 
         r1 <> text "->" <> r2
 ref2C rf@(RecordField ref1 ref2) = do
     r1 <- ref2C ref1
     t <- gets lastType
-    ns <- gets currentScope
     r2 <- case t of
         BTFunctionReturn s (BTRecord rs) -> withRecordNamespace "" rs $ ref2C ref2       
         BTRecord rs -> withRecordNamespace "" rs $ ref2C ref2
         BTUnit -> withLastIdNamespace $ ref2C ref2        
-        a -> error $ "dereferencing from " ++ show a ++ "\n" ++ show rf ++ "\n" ++ show (take 100 ns)
+        a -> error $ "dereferencing from " ++ show a ++ "\n" ++ show rf
     return $ 
         r1 <> text "." <> r2
 ref2C d@(Dereference ref) = do
@@ -734,7 +727,7 @@
     r <- ref2C ref
     t <- gets lastType
     case t of
-        BTFunction t' -> do
+        BTFunction _ t' -> do
             ps <- liftM (parens . hsep . punctuate (char ',')) $ mapM expr2C params
             modify (\s -> s{lastType = t'})
             return $ r <> ps