[MLton-commit] r5352

[Vesa Karvonen]

Added SkipCh (skip channels) and a non-exhaustive ad hoc test.
----------------------------------------------------------------------

U   mltonlib/trunk/com/ssh/async/unstable/detail/async.sml
U   mltonlib/trunk/com/ssh/async/unstable/public/async.sig
U   mltonlib/trunk/com/ssh/async/unstable/test/async.sml

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

Modified: mltonlib/trunk/com/ssh/async/unstable/detail/async.sml
===================================================================
--- mltonlib/trunk/com/ssh/async/unstable/detail/async.sml	2007-02-27 14:13:59 UTC (rev 5351)
+++ mltonlib/trunk/com/ssh/async/unstable/detail/async.sml	2007-02-27 15:44:27 UTC (rev 5352)
@@ -116,8 +116,17 @@
              case Queue.dequeWhile Handler.scheduled ts of
                 NONE => st := SOME v
               | SOME h => Handler.schedule v h
+      fun send (T {ts, st}) v =
+          case !st of
+             SOME _ => st := SOME v
+           | NONE =>
+             case Queue.dequeWhile Handler.scheduled ts of
+                NONE => st := SOME v
+              | SOME h => Handler.schedule v h
    end
 
+   structure SkipCh = MVar
+
    structure Multicast = struct
       datatype 'a n = N of 'a * 'a n IVar.t
       datatype 'a t = T of 'a n IVar.t Ref.t

Modified: mltonlib/trunk/com/ssh/async/unstable/public/async.sig
===================================================================
--- mltonlib/trunk/com/ssh/async/unstable/public/async.sig	2007-02-27 14:13:59 UTC (rev 5351)
+++ mltonlib/trunk/com/ssh/async/unstable/public/async.sig	2007-02-27 15:44:27 UTC (rev 5352)
@@ -94,6 +94,13 @@
       val give : 'a t -> 'a -> Unit.t Event.t
    end
 
+   structure SkipCh : sig
+      type 'a t
+      val new : 'a t Thunk.t
+      val take : 'a t -> 'a Event.t
+      val send : 'a t -> 'a Effect.t
+   end
+
    structure IVar : sig
       type 'a t
       val new : 'a t Thunk.t

Modified: mltonlib/trunk/com/ssh/async/unstable/test/async.sml
===================================================================
--- mltonlib/trunk/com/ssh/async/unstable/test/async.sml	2007-02-27 14:13:59 UTC (rev 5351)
+++ mltonlib/trunk/com/ssh/async/unstable/test/async.sml	2007-02-27 15:44:27 UTC (rev 5352)
@@ -96,5 +96,18 @@
                  ; eql (!s3, [4])
                 end))
 
+      (title "Async.SkipCh")
+
+      (test (fn () => let
+                   open SkipCh
+                   val c = new ()
+                in
+                   send c 1
+                 ; when (take c, eq /> 1) ; runAll ()
+                 ; send c 2
+                 ; send c 3
+                 ; when (take c, eq /> 3) ; runAll ()
+                end))
+
       $
 end