[MLton-commit] r5341

[Vesa Karvonen]

Fix too early execution of handler.  Added test code.
----------------------------------------------------------------------

U   mltonlib/trunk/com/ssh/async/unstable/detail/async.sml
A   mltonlib/trunk/com/ssh/async/unstable/test/
A   mltonlib/trunk/com/ssh/async/unstable/test/async.sml
A   mltonlib/trunk/com/ssh/async/unstable/test.mlb

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

Modified: mltonlib/trunk/com/ssh/async/unstable/detail/async.sml
===================================================================
--- mltonlib/trunk/com/ssh/async/unstable/detail/async.sml	2007-02-26 22:14:53 UTC (rev 5340)
+++ mltonlib/trunk/com/ssh/async/unstable/detail/async.sml	2007-02-26 22:58:54 UTC (rev 5341)
@@ -20,14 +20,11 @@
       fun new () = T {scheduled = ref false, effect = id}
       fun scheduled (T t) = !(#scheduled t)
       fun prepend f (T t) = T {scheduled = #scheduled t, effect = #effect t o f}
-      local
-         val handlers = Queue.new ()
-      in
-         fun schedule a (T {scheduled, effect}) =
-             if !scheduled then ()
-             else (scheduled := true ; Queue.enque handlers (fn () => effect a))
-         fun runAll () = Queue.appClear (pass ()) handlers
-      end
+      val handlers = Queue.new ()
+      fun schedule a (T {scheduled, effect}) =
+          if !scheduled then ()
+          else (scheduled := true ; Queue.enque handlers (fn () => effect a))
+      fun runAll () = Queue.appClear (pass ()) handlers
    end
 
    structure Event = struct
@@ -48,7 +45,8 @@
                       case e () of
                          INL ef => lp (es & ef::efs)
                        | result => result))
-      fun once (T t) = Sum.app (fn ef => ef (Handler.new ()), pass ()) (t ())
+      fun once (T t) = Sum.app (fn ef => ef (Handler.new ()),
+                                Queue.enque Handler.handlers) (t ())
       fun when ? = once (on ?)
       fun each e = when (e, fn () => each e)
       fun every ? = each (on ?)

Added: mltonlib/trunk/com/ssh/async/unstable/test/async.sml
===================================================================
--- mltonlib/trunk/com/ssh/async/unstable/test/async.sml	2007-02-26 22:14:53 UTC (rev 5340)
+++ mltonlib/trunk/com/ssh/async/unstable/test/async.sml	2007-02-26 22:58:54 UTC (rev 5341)
@@ -0,0 +1,36 @@
+(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+val () = let
+   open UnitTest Async Async.Event
+   fun eq (ac, ex) = verifyEq Type.int {actual = ac, expect = ex}
+   val full = verifyFailsWith (fn Full => true | _ => false)
+   fun inc v _ = v += 1
+in
+   unitTests
+      (title "Async.IVar")
+
+      (test (fn () => let
+                   val v = IVar.new ()
+                   val n = ref 0
+                in
+                   IVar.fill v ()
+                 ; full (IVar.fill v)
+                 ; when (IVar.read v, inc n)
+                 ; eq (!n, 0)
+                 ; Handler.runAll ()
+                 ; eq (!n, 1)
+                 ; full (IVar.fill v)
+                 ; when (IVar.read v, inc n)
+                 ; eq (!n, 1)
+                 ; Handler.runAll ()
+                 ; eq (!n, 2)
+                 ; Handler.runAll ()
+                 ; eq (!n, 2)
+                end))
+
+      $
+end


Property changes on: mltonlib/trunk/com/ssh/async/unstable/test/async.sml
___________________________________________________________________
Name: svn:eol-style
   + native

Added: mltonlib/trunk/com/ssh/async/unstable/test.mlb
===================================================================
--- mltonlib/trunk/com/ssh/async/unstable/test.mlb	2007-02-26 22:14:53 UTC (rev 5340)
+++ mltonlib/trunk/com/ssh/async/unstable/test.mlb	2007-02-26 22:58:54 UTC (rev 5341)
@@ -0,0 +1,17 @@
+(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+local
+   $(MLTON_LIB)/com/ssh/misc-util/unstable/unit-test.mlb
+
+   $(MLTON_LIB)/com/ssh/extended-basis/unstable/basis.mlb
+   $(MLTON_LIB)/com/ssh/misc-util/unstable/lib.mlb
+
+   lib.mlb
+
+   test/async.sml
+in
+end


Property changes on: mltonlib/trunk/com/ssh/async/unstable/test.mlb
___________________________________________________________________
Name: svn:eol-style
   + native