[MLton-commit] r5464

[Vesa Karvonen]

Added Wait.one (which corresponds to WaitForSingleObject).
----------------------------------------------------------------------

U   mltonlib/trunk/com/ssh/windows/unstable/detail/ffi/windows.h
U   mltonlib/trunk/com/ssh/windows/unstable/detail/windows.sml
U   mltonlib/trunk/com/ssh/windows/unstable/public/windows-ex.sig

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

Modified: mltonlib/trunk/com/ssh/windows/unstable/detail/ffi/windows.h
===================================================================
--- mltonlib/trunk/com/ssh/windows/unstable/detail/ffi/windows.h	2007-03-23 13:05:42 UTC (rev 5463)
+++ mltonlib/trunk/com/ssh/windows/unstable/detail/ffi/windows.h	2007-03-23 15:50:27 UTC (rev 5464)
@@ -170,6 +170,8 @@
              (DWORD, const HANDLE *, BOOL, DWORD, BOOL))
 WIN_FUNCTION(WaitForMultipleObjects, DWORD, 4,
              (DWORD, const HANDLE *, BOOL, DWORD))
+WIN_FUNCTION(WaitForSingleObject, DWORD, 2, (HANDLE, DWORD))
+WIN_FUNCTION(WaitForSingleObjectEx, DWORD, 3, (HANDLE, DWORD, BOOL))
 
 /************************************************************************/
 

Modified: mltonlib/trunk/com/ssh/windows/unstable/detail/windows.sml
===================================================================
--- mltonlib/trunk/com/ssh/windows/unstable/detail/windows.sml	2007-03-23 13:05:42 UTC (rev 5463)
+++ mltonlib/trunk/com/ssh/windows/unstable/detail/windows.sml	2007-03-23 15:50:27 UTC (rev 5464)
@@ -410,6 +410,10 @@
       val failed    = wc_WAIT_FAILED
       val infinite  = wc_INFINITE
 
+      val toMillis =
+       fn NONE => infinite
+        | SOME t => Word.fromLargeInt (Time.toMilliseconds t)
+
       fun wait name all ws t = let
          val n = Word.fromInt (length ws)
          val s = C.S.voidptr
@@ -420,11 +424,7 @@
                                 C.Set.voidptr' (C.Ptr.sub' s (hs, i), w)) ws
                 ; let val res =
                           F_win_WaitForMultipleObjects.f'
-                             (n, C.Ptr.ro' hs, toCBool all,
-                              case t of
-                                 NONE => infinite
-                               | SOME t =>
-                                 Word.fromLargeInt (Time.toMilliseconds t))
+                             (n, C.Ptr.ro' hs, toCBool all, toMillis t)
                       fun get off = #2 (List.sub (ws, Word.toIntX (res - off)))
                   in
                      if res = timeout then
@@ -444,6 +444,21 @@
 
       fun any ? = wait "Wait.any" false ?
       fun all ? = wait "Wait.all" true ?
+
+      fun one (w, v) t = let
+         val res = F_win_WaitForSingleObject.f' (w, toMillis t)
+      in
+         if res = timeout then
+            TIMEOUT
+         else if res = object then
+            OBJECT v
+         else if res = abandoned then
+            ABANDONED v
+         else if res = failed then
+            raiseLastError (fn () => F "Wait.one" [A ptr w, A (opt time) t])
+         else
+            fail "Unsupported WaitForSingleObject functionality"
+      end
    end
 
    structure Semaphore = struct

Modified: mltonlib/trunk/com/ssh/windows/unstable/public/windows-ex.sig
===================================================================
--- mltonlib/trunk/com/ssh/windows/unstable/public/windows-ex.sig	2007-03-23 13:05:42 UTC (rev 5463)
+++ mltonlib/trunk/com/ssh/windows/unstable/public/windows-ex.sig	2007-03-23 15:50:27 UTC (rev 5464)
@@ -65,6 +65,8 @@
 
       val any : (t * 'a) List.t -> Time.time Option.t -> 'a result
       val all : (t * 'a) List.t -> Time.time Option.t -> 'a result
+
+      val one : t * 'a -> Time.time Option.t -> 'a result
    end
 
    structure Semaphore : sig