[MLton-commit] r5455

[Vesa Karvonen]

Refinement.
----------------------------------------------------------------------

U   mltonlib/trunk/com/ssh/misc-util/unstable/unlinkable-list.sml

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

Modified: mltonlib/trunk/com/ssh/misc-util/unstable/unlinkable-list.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/unlinkable-list.sml	2007-03-21 00:34:32 UTC (rev 5454)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/unlinkable-list.sml	2007-03-21 00:51:48 UTC (rev 5455)
@@ -5,17 +5,17 @@
  *)
 
 structure UnlinkableList :> sig
-   type 'a t and 'a l
+   type 'a t and l
 
    val new : 'a t Thunk.t
 
-   val pushFront : 'a t -> 'a -> 'a l
-   val pushBack : 'a t -> 'a -> 'a l
+   val pushFront : 'a t -> 'a -> l
+   val pushBack : 'a t -> 'a -> l
 
    val popFront : 'a t -> 'a Option.t
    val popBack : 'a t -> 'a Option.t
 
-   val unlink : 'a l Effect.t
+   val unlink : l Effect.t
 end = struct
    type 'a p = 'a Option.t Ref.t
    val ! = fn p => case !p of SOME it => it | _ => fail "bug"
@@ -24,6 +24,8 @@
    datatype 'a t = RING of 'a l | NODE of {link : 'a l, value : 'a}
    withtype 'a l = {pred : 'a t p, succ : 'a t p}
 
+   type l = Unit.t Effect.t
+
    val link = fn RING link => link | NODE {link, ...} => link
    fun pred n = #pred (link n)
    fun succ n = #succ (link n)
@@ -36,16 +38,19 @@
       #pred l := r ; #succ l := r ; r
    end
 
-   fun unlink {pred = lp, succ = ls} = let
+   fun mkUnlink {pred = lp, succ = ls} () = let
       val p = !lp val s = !ls val n = ! (succ p)
    in
       ls := n ; lp := n ; succ p := s ; pred s := p
    end
 
+   fun unlink ef = ef ()
+
    fun push (p, s, v) = let
       val l = newLink () val n = NODE {link = l, value = v}
    in
-      #pred l := p ; #succ l := s ; pred s := n ; succ p := n ; l
+      #pred l := p ; #succ l := s ; pred s := n ; succ p := n
+    ; mkUnlink l
    end
    fun pushFront r v = push (r, ! (succ r), v)
    fun pushBack r v = push (! (pred r), r, v)
@@ -53,7 +58,7 @@
    fun pop which r =
        case ! (which r) of
           RING _ => NONE
-        | NODE {link, value} => (unlink link ; SOME value)
+        | NODE {link, value} => (mkUnlink link () ; SOME value)
    fun popFront r = pop succ r
    fun popBack r = pop pred r
 end