[MLton-commit] r5573

[Vesa Karvonen]

Handle exceptions when forcing a lazy thunk.

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

U   mltonlib/trunk/com/ssh/extended-basis/unstable/detail/lazy/lazy.sml
U   mltonlib/trunk/com/ssh/misc-util/unstable/lazy-test.sml

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

Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/detail/lazy/lazy.sml
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/detail/lazy/lazy.sml	2007-05-28 12:14:08 UTC (rev 5572)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/detail/lazy/lazy.sml	2007-05-28 12:38:06 UTC (rev 5573)
@@ -8,37 +8,31 @@
    datatype 'a status = LAZY of 'a t Thunk.t
                       | EAGER of (Exn.t, 'a) Sum.t
    withtype 'a t = 'a status ref ref
-
    fun lazy th = ref (ref (LAZY th))
-
    fun eager x = ref (ref (EAGER (Sum.INR x)))
-
    fun delay th = lazy (ref o ref o EAGER o (fn () => Exn.eval th))
-
    fun replay s = Sum.sum (Exn.throw, Fn.id) s
-
    fun force promise =
        case !(!promise) of
           EAGER x => replay x
-        | LAZY th => let
-          val promise' = th ()
-       in
-          case !(!promise) of
-             LAZY _ => (!promise := !(!promise')
-                      ; promise := !promise'
-                      ; force promise)
-           | EAGER x => replay x
-       end
+        | LAZY th =>
+          Exn.try (th,
+                   fn promise' =>
+                      case !(!promise) of
+                         LAZY _ => (!promise := !(!promise')
+                                  ; promise := !promise'
+                                  ; force promise)
+                       | EAGER x => replay x,
+                   fn e =>
+                      (!promise := EAGER (Sum.INL e) (* XXX *)
+                     ; raise e))
 
    fun toThunk promise = fn () => force promise
-
    fun memo th = toThunk (delay th)
-
    fun tie s k =
        case !(!s) of
           EAGER _ => raise Fix.Fix
         | LAZY _ => s := !k
-
    fun Y ? =
        Tie.tier (fn () => Pair.map (Fn.id, tie)
                                    (Sq.mk (lazy (Basic.raising Fix.Fix)))) ?

Modified: mltonlib/trunk/com/ssh/misc-util/unstable/lazy-test.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/lazy-test.sml	2007-05-28 12:14:08 UTC (rev 5572)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/lazy-test.sml	2007-05-28 12:38:06 UTC (rev 5573)
@@ -172,5 +172,25 @@
                   actual = [!count, F p, !count]}
               end))
 
+      (title "Lazy - exceptions")
+
+      (test (fn () => let
+                   val e = ref Empty
+                   val p = D (fn () => raise !e before e := Subscript)
+                   val chk = verifyFailsWith (fn Empty => true | _ => false)
+                in
+                   chk (fn () => F p)
+                 ; chk (fn () => F p)
+                end))
+
+      (test (fn () => let
+                   val e = ref Empty
+                   val p = L (fn () => raise !e before e := Subscript)
+                   val chk = verifyFailsWith (fn Empty => true | _ => false)
+                in
+                   chk (fn () => F p)
+                 ; chk (fn () => F p)
+                end))
+
       $
 end