[MLton-commit] r5202

[Vesa Karvonen]

Bug revealing test and fix.
----------------------------------------------------------------------

U   mltonlib/trunk/com/ssh/misc-util/unstable/ptr-cache-test.sml
U   mltonlib/trunk/com/ssh/misc-util/unstable/ptr-cache.sml

----------------------------------------------------------------------

Modified: mltonlib/trunk/com/ssh/misc-util/unstable/ptr-cache-test.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/ptr-cache-test.sml	2007-02-15 13:44:38 UTC (rev 5201)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/ptr-cache-test.sml	2007-02-15 14:17:03 UTC (rev 5202)
@@ -30,6 +30,14 @@
                            ; eq (3, use c k3)
                            ; notFound (fn () => get c k3)
                            ; eq (0, size c))
+                   val k1 = put c 1
+                   val k0 = put c 0
+                   val () = (eq (2, size c)
+                           ; eq (1, get c k1)
+                           ; eq (0, get c k0)
+                           ; rem c k0
+                           ; rem c k1
+                           ; eq (0, size c))
                 in
                    ()
                 end))

Modified: mltonlib/trunk/com/ssh/misc-util/unstable/ptr-cache.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/ptr-cache.sml	2007-02-15 13:44:38 UTC (rev 5201)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/ptr-cache.sml	2007-02-15 14:17:03 UTC (rev 5202)
@@ -4,21 +4,32 @@
  * See the LICENSE file or http://mlton.org/License for details.
  *)
 
-structure PtrCache =
-   MkIntObjCache
-      (type t = C.voidptr
-       local
-          val unused = ref [] (* XXX free these at some point *)
-       in
-          fun set k = C.Ptr.|*! (C.Ptr.cast' k) <\ C.Set.sint'
-          fun new value =
-              case List.pop unused of
-                 SOME v => v
-               | NONE => let
-                    val k = C.Ptr.inject' (C.Ptr.|&! (C.new' C.S.sint))
-                 in
-                    set k value ; k
-                 end
-          val discard = unused <\ List.push
-          val get = C.Get.sint' o C.Ptr.|*! o C.Ptr.cast'
-       end)
+local
+   structure PtrIntObj = struct
+      type t = C.voidptr
+      local
+         val nUsed = ref 0
+         val nUnused = ref 0
+         val unused = ref []
+      in
+         fun set k = C.Ptr.|*! (C.Ptr.cast' k) <\ C.Set.sint'
+         fun new v = let
+            val k = case List.pop unused of
+                       SOME k => (nUnused -= 1 ; k)
+                     | NONE => C.Ptr.inject' (C.Ptr.|&! (C.new' C.S.sint))
+         in
+            nUsed += 1 ; set k v ; k
+         end
+         fun discard k =
+             (List.push (unused, k) ; nUnused += 1 ; nUsed -= 1
+            ; while !nUsed < !nUnused do
+                 case List.pop unused of
+                    NONE => raise Fail "bug"
+                  | SOME k => (nUnused -= 1 ; C.free' k))
+         val get = C.Get.sint' o C.Ptr.|*! o C.Ptr.cast'
+      end
+   end
+in
+   (** A cache whose keys are C pointers. *)
+   structure PtrCache = MkIntObjCache (PtrIntObj)
+end