[Gtk2hs-commit] gtk2hs/tools/c2hs/base/syms Attributes.hs,1.1.1.1,1.2 Idents.hs,1.1.1.1,1.2 NameSpaces.hs,1.1.1.1,1.2

[Duncan C. <dun...@us...>]

Update of /cvsroot/gtk2hs/gtk2hs/tools/c2hs/base/syms
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv15642/base/syms

Modified Files:
	Attributes.hs Idents.hs NameSpaces.hs 
Log Message:
add Axel's --precomp patches with a binary serialisation framework derived from
the one used in ghc. This required makeing Position a proper data type.
Also converted to using Data.FiniteMap rather than the CTK FiniteMaps module.


Index: Attributes.hs
===================================================================
RCS file: /cvsroot/gtk2hs/gtk2hs/tools/c2hs/base/syms/Attributes.hs,v
retrieving revision 1.1.1.1
retrieving revision 1.2
diff -u -d -r1.1.1.1 -r1.2
--- Attributes.hs	13 Nov 2004 16:42:44 -0000	1.1.1.1
+++ Attributes.hs	13 Nov 2004 17:26:50 -0000	1.2
@@ -94,7 +94,9 @@
 import Errors     (interr)
 import UNames	  (NameSupply, Name,
 		   rootSupply, splitSupply, names)
-import FiniteMaps (FiniteMap, listToFM, toListFM, addToFM, lookupDftFM, zeroFM)
+import Data.FiniteMap (FiniteMap, listToFM, fmToList, addToFM,
+		       lookupWithDefaultFM, emptyFM)
+import Binary     (Binary(..), putByte, getByte)
 
 
 -- attribute management data structures and operations
@@ -221,7 +223,7 @@
 -- (internal errors); a	table is initially soft
 --
 newAttrTable      :: Attr a => String -> AttrTable a
-newAttrTable desc  = SoftTable zeroFM desc
+newAttrTable desc  = SoftTable emptyFM desc
 
 -- get the value of an attribute from the given attribute table (EXPORTED)
 --
@@ -229,7 +231,7 @@
 getAttr at (OnlyPos pos    )  = onlyPosErr "getAttr" at pos
 getAttr at (Attrs   _   aid)  = 
   case at of
-    (SoftTable   fm  _) -> lookupDftFM fm undef aid
+    (SoftTable   fm  _) -> lookupWithDefaultFM fm undef aid
     (FrozenTable arr _) -> let (lbd, ubd) = bounds arr
 			   in
 			   if (aid < lbd || aid > ubd) then undef else arr!aid
@@ -241,9 +243,9 @@
 setAttr at (OnlyPos pos    ) av = onlyPosErr "setAttr" at pos
 setAttr at (Attrs   pos aid) av = 
   case at of
-    (SoftTable fm desc) -> assert (isUndef (lookupDftFM fm undef aid)) 
+    (SoftTable fm desc) -> assert (isUndef (lookupWithDefaultFM fm undef aid)) 
 				  alreadySetErr $  
-			     SoftTable (addToFM aid av fm) desc
+			     SoftTable (addToFM fm aid av) desc
     (FrozenTable arr _) -> interr frozenErr 
   where
     alreadySetErr = "Attributes.setAttr: Attempt to set *already* set \
@@ -257,7 +259,7 @@
 updAttr at (OnlyPos pos    ) av = onlyPosErr "updAttr" at pos
 updAttr at (Attrs   pos aid) av = 
   case at of
-    (SoftTable   fm  desc) -> SoftTable (addToFM aid av fm) desc
+    (SoftTable   fm  desc) -> SoftTable (addToFM fm aid av) desc
     (FrozenTable arr _)    -> interr $ "Attributes.updAttr: Tried to\
 				       \ update frozen attribute in\n"
 				       ++ errLoc at pos
@@ -296,7 +298,7 @@
 --
 freezeAttrTable			       :: Attr a => AttrTable a -> AttrTable a
 freezeAttrTable (SoftTable   fm  desc)  = 
-  let contents = toListFM fm
+  let contents = fmToList fm
       keys     = map fst contents
       lbd      = minimum keys
       ubd      = maximum keys
@@ -398,3 +400,47 @@
 updGenAttr            :: (Attr a, Attributed obj) 
 		      => AttrTable a -> obj -> a -> AttrTable a
 updGenAttr atab at av  = updAttr atab (attrsOf at) av
+
+
+{-! for Attrs derive : GhcBinary !-}
+{-! for AttrTable derive : GhcBinary !-}
+{-* Generated by DrIFT : Look, but Don't Touch. *-}
+instance Binary Attrs where
+    put_ bh (OnlyPos aa) = do
+            putByte bh 0
+            put_ bh aa
+    put_ bh (Attrs ab ac) = do
+            putByte bh 1
+            put_ bh ab
+            put_ bh ac
+    get bh = do
+            h <- getByte bh
+            case h of
+              0 -> do
+                    aa <- get bh
+                    return (OnlyPos aa)
+              1 -> do
+                    ab <- get bh
+                    ac <- get bh
+                    return (Attrs ab ac)
+
+instance (Binary a, Attr a) => Binary (AttrTable a) where
+    put_ bh (SoftTable aa ab) = do
+            putByte bh 0
+            put_ bh aa
+            put_ bh ab
+    put_ bh (FrozenTable ac ad) = do
+            putByte bh 1
+            put_ bh ac
+            put_ bh ad
+    get bh = do
+            h <- getByte bh
+            case h of
+              0 -> do
+                    aa <- get bh
+                    ab <- get bh
+                    return (SoftTable aa ab)
+              1 -> do
+                    ac <- get bh
+                    ad <- get bh
+                    return (FrozenTable ac ad)

Index: NameSpaces.hs
===================================================================
RCS file: /cvsroot/gtk2hs/gtk2hs/tools/c2hs/base/syms/NameSpaces.hs,v
retrieving revision 1.1.1.1
retrieving revision 1.2
diff -u -d -r1.1.1.1 -r1.2
--- NameSpaces.hs	13 Nov 2004 16:42:44 -0000	1.1.1.1
+++ NameSpaces.hs	13 Nov 2004 17:26:50 -0000	1.2
@@ -42,9 +42,10 @@
 where
 
 import Common	  (Position, Pos(posOf))	      -- for importing `Idents'
-import FiniteMaps (FiniteMap, zeroFM, addToFM, lookupFM, toListFM)
+import Data.FiniteMap (FiniteMap, emptyFM, addToFM, lookupFM, fmToList, listToFM)
 import Idents     (Ident)
 import Errors     (interr)
+import Binary     (Binary(..))
 
 
 -- name space (EXPORTED ABSTRACT)
@@ -71,7 +72,7 @@
 -- create a name space (EXPORTED)
 --
 nameSpace :: NameSpace a
-nameSpace  = NameSpace zeroFM []
+nameSpace  = NameSpace emptyFM []
 
 -- add global definition (EXPORTED)
 --
@@ -83,7 +84,7 @@
 --   name space anymore)
 --
 defGlobal :: NameSpace a -> Ident -> a -> (NameSpace a, Maybe a)
-defGlobal (NameSpace gs lss) id def  = (NameSpace (addToFM id def gs) lss, 
+defGlobal (NameSpace gs lss) id def  = (NameSpace (addToFM gs id def) lss, 
 				        lookupFM gs id)
 
 -- add new range (EXPORTED)
@@ -143,4 +144,16 @@
 -- * local ranges are concatenated
 --
 nameSpaceToList                    :: NameSpace a -> [(Ident, a)]
-nameSpaceToList (NameSpace gs lss)  = toListFM gs ++ concat lss
+nameSpaceToList (NameSpace gs lss)  = fmToList gs ++ concat lss
+
+
+{-! for NameSpace derive : GhcBinary !-}
+{-* Generated by DrIFT : Look, but Don't Touch. *-}
+instance (Binary a) => Binary (NameSpace a) where
+    put_ bh (NameSpace aa ab) = do
+            put_ bh aa
+            put_ bh ab
+    get bh = do
+    aa <- get bh
+    ab <- get bh
+    return (NameSpace aa ab)

Index: Idents.hs
===================================================================
RCS file: /cvsroot/gtk2hs/gtk2hs/tools/c2hs/base/syms/Idents.hs,v
retrieving revision 1.1.1.1
retrieving revision 1.2
diff -u -d -r1.1.1.1 -r1.2
--- Idents.hs	13 Nov 2004 16:42:44 -0000	1.1.1.1
+++ Idents.hs	13 Nov 2004 17:26:50 -0000	1.2
@@ -69,6 +69,7 @@
 import Errors     (interr)
 import Attributes (Attrs, newAttrsOnlyPos, newAttrs,
 		   Attributed(attrsOf), posOfAttrsOf)
+import Binary     (Binary(..), putSharedString, getSharedString)
 
 
 -- simple identifier representation (EXPORTED)
@@ -77,9 +78,9 @@
 -- number
 --
 data Ident = Ident String	-- lexeme
-		   Int		-- ambiguousness resolving number
-		   Int		-- id. number to speed up equality check
-		   Attrs    	-- attributes of this ident. incl. position
+		   !Int		-- ambiguousness resolving number
+		   !Int		-- id. number to speed up equality check
+		   !Attrs    	-- attributes of this ident. incl. position
 
 -- the definition of the equality allows identifiers to be equal that are
 -- defined at different source text positions, and aims at speeding up the
@@ -373,3 +374,21 @@
 --
 dumpIdent     :: Ident -> String
 dumpIdent ide  = identToLexeme ide ++ " at " ++ show (posOf ide) 
+
+
+{-! for Ident derive : GhcBinary !-}
+{-* Generated by DrIFT : Look, but Don't Touch. *-}
+instance Binary Ident where
+    put_ bh (Ident aa ab ac ad) = do
+            putSharedString bh aa
+--            put_ bh aa
+            put_ bh ab
+            put_ bh ac
+            put_ bh ad
+    get bh = do
+    aa <- getSharedString bh
+--    aa <- get bh
+    ab <- get bh
+    ac <- get bh
+    ad <- get bh
+    return (Ident aa ab ac ad)