Debug, tests

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@1701 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

otherlibs/win32unix/Makefile.nt

@@ -10,8 +10,9 @@ CAMLOPT=..\..\boot\ocamlrun ..\..\ocamlopt -I ..\..\stdlib
 # Files in this directory
 WIN_OBJS = accept.obj bind.obj channels.obj close.obj \
   close_on.obj connect.obj createprocess.obj dup.obj dup2.obj \
-  getpeername.obj getpid.obj getsockname.obj listen.obj lseek.obj \
-  mkdir.obj open.obj pipe.obj read.obj sendrecv.obj \
+  getpeername.obj getpid.obj getsockname.obj gettimeofday.obj \
+  listen.obj lseek.obj \
+  mkdir.obj open.obj pipe.obj read.obj select.obj sendrecv.obj \
   shutdown.obj sleep.obj socket.obj sockopt.obj startup.obj system.obj \
   unixsupport.obj windir.obj winwait.obj write.obj
 

otherlibs/win32unix/accept.c

@@ -34,10 +34,8 @@ value unix_accept(sock)          /* ML */
   enter_blocking_section();
   snew = accept(sconn, &sock_addr.s_gen, &sock_addr_len);
   leave_blocking_section();
-  if (snew == INVALID_SOCKET) {
-    _dosmaperr(WSAGetLastError());
-    uerror("accept", Nothing);
-  }
+  if (snew == INVALID_SOCKET)
+    unix_error(WSAGetLastError(), "accept", Nothing);
   Begin_roots2 (fd, adr)
     fd = win_alloc_handle((HANDLE) snew);
     adr = alloc_sockaddr();

otherlibs/win32unix/bind.c

@@ -21,9 +21,6 @@ value unix_bind(socket, address)      /* ML */
   int ret;
   get_sockaddr(address);
   ret = bind((SOCKET) Handle_val(socket), &sock_addr.s_gen, sock_addr_len);
-  if (ret == -1) {
-    _dosmaperr(WSAGetLastError());
-    uerror("bind", Nothing);
-  }
+  if (ret == -1) unix_error(WSAGetLastError(), "bind", Nothing);
   return Val_unit;
 }

otherlibs/win32unix/channels.c

@@ -21,8 +21,10 @@ static int open_descr_flags[10] = {
 
 value win_fd_handle(value handle, value flags) /* ML */
 {
-  return Val_int(_open_osfhandle(Handle_val(handle),
-                                 convert_flag_list(open_descr_flags, flags)));
+  int fd = _open_osfhandle((long) Handle_val(handle),
+			   convert_flag_list(open_descr_flags, flags));
+  if (fd == -1) uerror("channel_of_descr", Nothing);
+  return Val_int(fd);
 }
 
 value win_handle_fd(value fd)   /* ML */

otherlibs/win32unix/connect.c

@@ -25,9 +25,6 @@ value unix_connect(socket, address)   /* ML */
   enter_blocking_section();
   retcode = connect(s, &sock_addr.s_gen, sock_addr_len);
   leave_blocking_section();
-  if (retcode == -1) {
-    _dosmaperr(WSAGetLastError());
-    uerror("connect", Nothing);
-  }
+  if (retcode == -1) unix_error(WSAGetLastError(), "connect", Nothing);
   return Val_unit;
 }

otherlibs/win32unix/dup.c

@@ -19,7 +19,7 @@ value unix_dup(value fd)               /* ML */
   HANDLE newh;
   if (! DuplicateHandle(GetCurrentProcess(), Handle_val(fd),
                         GetCurrentProcess(), &newh,
-                        0L, inherit, DUPLICATE_SAME_ACCESS)) {
+                        0L, TRUE, DUPLICATE_SAME_ACCESS)) {
     _dosmaperr(GetLastError());
     return -1;
   }

otherlibs/win32unix/dup2.c

@@ -21,7 +21,7 @@ value unix_dup2(value fd1, value fd2)        /* ML */
   oldh = Handle_val(fd2);
   if (! DuplicateHandle(GetCurrentProcess(), Handle_val(fd1),
                         GetCurrentProcess(), &newh,
-                        0L, inherit, DUPLICATE_SAME_ACCESS)) {
+                        0L, TRUE, DUPLICATE_SAME_ACCESS)) {
     _dosmaperr(GetLastError());
     return -1;
   }

otherlibs/win32unix/getpeername.c

@@ -23,9 +23,6 @@ value unix_getpeername(sock)          /* ML */
   sock_addr_len = sizeof(sock_addr);
   retcode = getpeername((SOCKET) Handle_val(sock),
                         &sock_addr.s_gen, &sock_addr_len);
-  if (retcode == -1) {
-    _dosmaperr(WSAGetLastError());
-    uerror("getpeername", Nothing);
-  }
+  if (retcode == -1) unix_error(WSAGetLastError(), "getpeername", Nothing);
   return alloc_sockaddr();
 }

otherlibs/win32unix/gettimeofday.c

@@ -0,0 +1,20 @@
+#include <mlvalues.h>
+#include <alloc.h>
+#include <time.h>
+
+#include "unixsupport.h"
+
+static time_t initial_time = 0;	/* 0 means uninitialized */
+static DWORD initial_tickcount;
+
+value unix_gettimeofday(value unit)                /* ML */
+{
+  if (initial_time == 0) {
+    initial_tickcount = GetTickCount();
+    initial_time = time(NULL);
+    return copy_double((double) initial_time);
+  } else {
+    return copy_double(initial_time +
+		       (GetTickCount() - initial_tickcount) * 1e-3);
+  }
+}

otherlibs/win32unix/listen.c

@@ -18,9 +18,7 @@
 value unix_listen(sock, backlog) /* ML */
      value sock, backlog;
 {
-  if (listen((SOCKET) Handle_val(sock), Int_val(backlog)) == -1) {
-    _dosmaperr(WSAGetLastError());
-    uerror("listen", Nothing);
-  }
+  if (listen((SOCKET) Handle_val(sock), Int_val(backlog)) == -1)
+    unix_error(WSAGetLastError(), "listen", Nothing);
   return Val_unit;
 }

otherlibs/win32unix/open.c

@@ -26,10 +26,12 @@ static int open_create_flags[10] = {
 
 value unix_open(value path, value flags, value perm) /* ML */
 {
-  int fileaccess, createflags, fileattrib;
+  int fileaccess, createflags, fileattrib, filecreate;
+  SECURITY_ATTRIBUTES attr;
   HANDLE h;
 
   fileaccess = convert_flag_list(flags, open_access_flags);
+
   createflags = convert_flag_list(flags, open_create_flags);
   if ((createflags & (O_CREAT | O_EXCL)) == (O_CREAT | O_EXCL))
     filecreate = CREATE_NEW;
@@ -41,12 +43,21 @@ value unix_open(value path, value flags, value perm) /* ML */
     filecreate = OPEN_ALWAYS;
   else
     filecreate = OPEN_EXISTING;
+
   if ((createflags & O_CREAT) && (Int_val(perm) & 0200) == 0)
     fileattrib = FILE_ATTRIBUTE_READONLY;
   else
     fileattrib = FILE_ATTRIBUTE_NORMAL;
-  h = CreateFile(String_val(path), fileaccess, 0, NULL,
+
+  attr.nLength = sizeof(attr);
+  attr.lpSecurityDescriptor = NULL;
+  attr.bInheritHandle = TRUE;
+
+  h = CreateFile(String_val(path), fileaccess, 0, &attr,
                  filecreate, fileattrib, NULL);
-  if (h == INVALID_HANDLE_VALUE) uerror("open", path);
+  if (h == INVALID_HANDLE_VALUE) {
+    _dosmaperr(GetLastError());
+    uerror("open", path);
+  }
   return win_alloc_handle(h);
 }

otherlibs/win32unix/pipe.c

@@ -12,6 +12,7 @@
 /* $Id$ */
 
 #include <mlvalues.h>
+#include <memory.h>
 #include <alloc.h>
 #include "unixsupport.h"
 #include <fcntl.h>
@@ -20,10 +21,14 @@
 
 value unix_pipe(value unit)                /* ML */
 {
+  SECURITY_ATTRIBUTES attr;
   HANDLE readh, writeh;
   value readfd = Val_unit, writefd = Val_unit, res;
 
-  if (! CreatePipe(&readh, &writeh, NULL, SIZEBUF)) {
+  attr.nLength = sizeof(attr);
+  attr.lpSecurityDescriptor = NULL;
+  attr.bInheritHandle = TRUE;
+  if (! CreatePipe(&readh, &writeh, &attr, SIZEBUF)) {
     _dosmaperr(GetLastError());
     uerror("pipe", Nothing);
   }

otherlibs/win32unix/select.c

@@ -0,0 +1,84 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 1996 Institut National de Recherche en Informatique et   */
+/*  Automatique.  Distributed only by permission.                      */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+#include <mlvalues.h>
+#include <alloc.h>
+#include <memory.h>
+#include <signals.h>
+#include "unixsupport.h"
+#include <winsock.h>
+
+static void fdlist_to_fdset(value fdlist, fd_set *fdset)
+{
+  value l;
+  FD_ZERO(fdset);
+  for (l = fdlist; l != Val_int(0); l = Field(l, 1)) {
+    FD_SET((SOCKET) Handle_val(Field(l, 0)), fdset);
+  }
+}
+
+static value fdset_to_fdlist(value fdlist, fd_set *fdset)
+{
+  value res = Val_int(0);
+  Begin_roots2(fdlist, res)
+    for (/*nothing*/; fdlist != Val_int(0); fdlist = Field(fdlist, 1)) {
+      value s = Field(fdlist, 0);
+      if (FD_ISSET((SOCKET) Handle_val(s), fdset)) {
+	value newres = alloc(2, 0);
+	Field(newres, 0) = s;
+	Field(newres, 1) = res;
+	res = newres;
+      }
+    }
+  End_roots();
+  return res;
+}
+
+value unix_select(value readfds, value writefds, value exceptfds, value timeout) /* ML */
+{
+  fd_set read, write, except;
+  double tm;
+  struct timeval tv;
+  struct timeval * tvp;
+  int retcode;
+  value res;
+  value read_list = Val_unit, write_list = Val_unit, except_list = Val_unit;
+
+  Begin_roots3 (readfds, writefds, exceptfds)
+  Begin_roots3 (read_list, write_list, except_list)
+    fdlist_to_fdset(readfds, &read);
+    fdlist_to_fdset(writefds, &write);
+    fdlist_to_fdset(exceptfds, &except);
+    tm = Double_val(timeout);
+    if (tm < 0.0)
+      tvp = (struct timeval *) NULL;
+    else {
+      tv.tv_sec = (int) tm;
+      tv.tv_usec = (int) (1e6 * (tm - (int) tm));
+      tvp = &tv;
+    }
+    enter_blocking_section();
+    retcode = select(FD_SETSIZE, &read, &write, &except, tvp);
+    leave_blocking_section();
+    if (retcode == -1) unix_error(WSAGetLastError(), "select", Nothing);
+    read_list = fdset_to_fdlist(readfds, &read);
+    write_list = fdset_to_fdlist(writefds, &write);
+    except_list = fdset_to_fdlist(exceptfds, &except);
+    res = alloc_tuple(3);
+    Field(res, 0) = read_list;
+    Field(res, 1) = write_list;
+    Field(res, 2) = except_list;
+  End_roots();
+  End_roots();
+  return res;
+}

otherlibs/win32unix/sendrecv.c

@@ -34,10 +34,7 @@ value unix_recv(value sock, value buff, value ofs, value len, value flags)
     ret = recv((SOCKET) Handle_val(sock), iobuf, (int) numbytes,
 	       convert_flag_list(flags, msg_flag_table));
     leave_blocking_section();
-    if (ret == -1) {
-      _dosmaperr(WSAGetLastError());
-      uerror("recv", Nothing);
-    }
+    if (ret == -1) unix_error(WSAGetLastError(), "recv", Nothing);
     bcopy(iobuf, &Byte(buff, Long_val(ofs)), ret);
   End_roots();
   return Val_int(ret);
@@ -61,10 +58,7 @@ value unix_recvfrom(value sock, value buff, value ofs, value len, value flags) /
 		   convert_flag_list(flags, msg_flag_table),
 		   &sock_addr.s_gen, &sock_addr_len);
     leave_blocking_section();
-    if (ret == -1) {
-      _dosmaperr(WSAGetLastError());
-      uerror("recvfrom", Nothing);
-    }
+    if (ret == -1) unix_error(WSAGetLastError(), "recvfrom", Nothing);
     bcopy(iobuf, &Byte(buff, Long_val(ofs)), ret);
     adr = alloc_sockaddr();
     res = alloc_tuple(2);
@@ -87,10 +81,7 @@ value unix_send(value sock, value buff, value ofs, value len, value flags) /* ML
   ret = send((SOCKET) Handle_val(sock), iobuf, (int) numbytes,
              convert_flag_list(flags, msg_flag_table));
   leave_blocking_section();
-  if (ret == -1) {
-    _dosmaperr(WSAGetLastError());
-    uerror("send", Nothing);
-  }
+  if (ret == -1) unix_error(WSAGetLastError(), "send", Nothing);
   return Val_int(ret);
 }
 
@@ -110,10 +101,7 @@ value unix_sendto_native(value sock, value buff, value ofs, value len, value fla
                convert_flag_list(flags, msg_flag_table),
                &sock_addr.s_gen, sock_addr_len);
   leave_blocking_section();
-  if (ret == -1) {
-    _dosmaperr(WSAGetLastError());
-    uerror("sendto", Nothing);
-  }
+  if (ret == -1) unix_error(WSAGetLastError(), "sendto", Nothing);
   return Val_int(ret);
 }
 

otherlibs/win32unix/shutdown.c

@@ -23,9 +23,7 @@ value unix_shutdown(sock, cmd)   /* ML */
      value sock, cmd;
 {
   if (shutdown((SOCKET) Handle_val(sock),
-               shutdown_command_table[Int_val(cmd)]) == -1) {
-    _dosmaperr(WSAGetLastError());
-    uerror("shutdown", Nothing);
-  }
+               shutdown_command_table[Int_val(cmd)]) == -1)
+    unix_error(WSAGetLastError(), "shutdown", Nothing);
   return Val_unit;
 }

otherlibs/win32unix/socket.c

@@ -38,9 +38,6 @@ value unix_socket(domain, type, proto) /* ML */
   s = socket(socket_domain_table[Int_val(domain)],
                    socket_type_table[Int_val(type)],
                    Int_val(proto));
-  if (s == INVALID_SOCKET) {
-    _dosmaperr(WSAGetLastError());
-    uerror("socket", Nothing);
-  }
+  if (s == INVALID_SOCKET) unix_error(WSAGetLastError(), "socket", Nothing);
   return win_alloc_handle((HANDLE) s);
 }

otherlibs/win32unix/sockopt.c

@@ -26,10 +26,8 @@ value unix_getsockopt(socket, option) /* ML */
   int optval, optsize;
   optsize = sizeof(optval);
   if (getsockopt((SOCKET) Handle_val(socket), SOL_SOCKET, 
-                 sockopt[Int_val(option)], (char *) &optval, &optsize) == -1) {
-    _dosmaperr(WSAGetLastError());
-    uerror("getsockopt", Nothing);
-  }
+                 sockopt[Int_val(option)], (char *) &optval, &optsize) == -1)
+    unix_error(WSAGetLastError(), "getsockopt", Nothing);
   return Val_int(optval);
 }
 
@@ -39,9 +37,7 @@ value unix_setsockopt(socket, option, status) /* ML */
   int optval = Int_val(status);
   if (setsockopt((SOCKET) Handle_val(socket), SOL_SOCKET,
                  sockopt[Int_val(option)],
-                 (char *) &optval, sizeof(optval)) == -1) {
-    _dosmaperr(WSAGetLastError());
-    uerror("setsockopt", Nothing);
-  }
+                 (char *) &optval, sizeof(optval)) == -1)
+    unix_error(WSAGetLastError(), "setsockopt", Nothing);
   return Val_unit;
 }

otherlibs/win32unix/startup.c

@@ -40,7 +40,11 @@ value win_cleanup(unit)         /* ML */
   return Val_unit;
 }
 
+static int std_handles[3] = {
+  STD_INPUT_HANDLE, STD_OUTPUT_HANDLE, STD_ERROR_HANDLE
+};
+
 value win_stdhandle(value nhandle) /* ML */
 {
-  return win_alloc_handle(GetStdHandle(Int_val(nhandle)));
+  return win_alloc_handle(GetStdHandle(std_handles[Int_val(nhandle)]));
 }

otherlibs/win32unix/unix.ml

@@ -135,11 +135,13 @@ external waitpid : wait_flag list -> int -> int * process_status
                  = "win_waitpid"
 external getpid : unit -> int = "unix_getpid"
 
-external stdhandle : int -> file_descr = "win_stdhandle"
+type standard_handle = STD_INPUT | STD_OUTPUT | STD_ERROR
 
-let stdin = stdhandle 0
-let stdout = stdhandle 1
-let stderr = stdhandle 2
+external stdhandle : standard_handle -> file_descr = "win_stdhandle"
+
+let stdin = stdhandle STD_INPUT
+let stdout = stdhandle STD_OUTPUT
+let stderr = stdhandle STD_ERROR
 
 type open_flag =
     O_RDONLY
@@ -174,19 +176,21 @@ let write fd buf ofs len =
 
 external open_read_descriptor : int -> in_channel = "caml_open_descriptor"
 external open_write_descriptor : int -> out_channel = "caml_open_descriptor"
-external fd_of_in_channel : in_channel -> file_descr = "channel_descriptor"
-external fd_of_out_channel : out_channel -> file_descr = "channel_descriptor"
+external fd_of_in_channel : in_channel -> int = "channel_descriptor"
+external fd_of_out_channel : out_channel -> int = "channel_descriptor"
 
-external open_handle : file_descr -> open_flags list -> int = "win_fd_handle"
+external open_handle : file_descr -> open_flag list -> int = "win_fd_handle"
 external filedescr_of_fd : int -> file_descr = "win_handle_fd"
 
 let in_channel_of_descr_gen flags handle =
   open_read_descriptor(open_handle handle flags)
-let in_channel_of_descr handle = in_channel_of_descr_gen [O_TEXT]
+let in_channel_of_descr handle =
+  in_channel_of_descr_gen [O_TEXT] handle
 
 let out_channel_of_descr_gen flags handle =
   open_write_descriptor(open_handle handle flags)
-let out_channel_of_descr handle = out_channel_of_descr_gen [O_TEXT]
+let out_channel_of_descr handle =
+  out_channel_of_descr_gen [O_TEXT] handle
 
 let descr_of_in_channel inchan =
   filedescr_of_fd(fd_of_in_channel inchan)
@@ -292,6 +296,7 @@ type tm =
     tm_isdst : bool }
 
 external time : unit -> int = "unix_time"
+external gettimeofday : unit -> float = "unix_gettimeofday"
 external gmtime : int -> tm = "unix_gmtime"
 external localtime : int -> tm = "unix_localtime"
 external mktime : tm -> int * tm = "unix_mktime"
@@ -499,6 +504,12 @@ let close_process (inchan, outchan) =
   close_in inchan; close_out outchan;
   snd(waitpid [] pid)
 
+(* Polling *)
+
+external select :
+  file_descr list -> file_descr list -> file_descr list -> float ->
+        file_descr list * file_descr list * file_descr list = "unix_select"
+
 (* High-level network functions *)
 
 let open_connection sockaddr =

otherlibs/win32unix/unix.mli

@@ -209,14 +209,14 @@ val write : file_descr -> string -> int -> int -> int
 
 (*** Interfacing with the standard input/output library. *)
 
-value in_channel_of_descr : file_descr -> in_channel 
+val in_channel_of_descr : file_descr -> in_channel 
         (* Create an input channel reading from the given descriptor.
            The input channel is opened in text mode. *)
-value out_channel_of_descr : file_descr -> out_channel
+val out_channel_of_descr : file_descr -> out_channel
         (* Create an output channel writing on the given descriptor.
            The output channel is opened in text mode. *)
-value in_channel_of_descr_gen : open_flags list -> file_descr -> in_channel 
-value out_channel_of_descr_gen : open_flags list -> file_descr -> out_channel
+val in_channel_of_descr_gen : open_flag list -> file_descr -> in_channel 
+val out_channel_of_descr_gen : open_flag list -> file_descr -> out_channel
         (* Same as [in_channel_of_descr] and [out_channel_of_descr],
            except that the first argument (a list of flags) specifies
            the opening mode.  The following flags are recognized:
@@ -224,9 +224,9 @@ value out_channel_of_descr_gen : open_flags list -> file_descr -> out_channel
            and [O_APPEND] (all writes go at the end of the file).
            Other flags are ignored. *)
 
-value descr_of_in_channel : in_channel -> file_descr
+val descr_of_in_channel : in_channel -> file_descr
         (* Return the descriptor corresponding to an input channel. *)
-value descr_of_out_channel : out_channel -> file_descr
+val descr_of_out_channel : out_channel -> file_descr
         (* Return the descriptor corresponding to an output channel. *)
 
 (*** Seeking and truncating *)
@@ -394,6 +394,24 @@ val close_process: in_channel * out_channel -> process_status
            and [open_process], respectively, wait for the associated
            command to terminate, and return its termination status. *)
 
+(*** Polling *)
+
+external select :
+  file_descr list -> file_descr list -> file_descr list -> float ->
+        file_descr list * file_descr list * file_descr list = "unix_select"
+
+        (* Wait until some input/output operations become possible on
+           some sockets. The three list arguments are, respectively, a set
+           of descriptors to check for reading (first argument), for writing
+           (second argument), or for exceptional conditions (third argument).
+           The fourth argument is the maximal timeout, in seconds; a
+           negative fourth argument means no timeout (unbounded wait).
+           The result is composed of three sets of descriptors: those ready
+           for reading (first component), ready for writing (second component),
+           and over which an exceptional condition is pending (third
+           component). Unlike under Unix, the Win32 [select] works only
+	   for descriptors opened on sockets, but not on pipes or files. *)
+
 (*** Time functions *)
 
 type tm =
@@ -412,6 +430,8 @@ type tm =
 external time : unit -> int = "unix_time"
         (* Return the current time since 00:00:00 GMT, Jan. 1, 1970,
            in seconds. *)
+external gettimeofday : unit -> float = "unix_gettimeofday"
+        (* Same as [time], but with resolution better than 1 second. *)
 external gmtime : int -> tm = "unix_gmtime"
         (* Convert a time in seconds, as returned by [time], into a date and
            a time. Assumes Greenwich meridian time zone. *)

otherlibs/win32unix/unixsupport.h

@@ -11,6 +11,7 @@
 
 /* $Id$ */
 
+#include <wtypes.h>
 #include <winbase.h>
 #include <stdlib.h>
 /* Include io.h in current dir, which is a copy of the system's io.h,

otherlibs/win32unix/winwait.c

@@ -2,7 +2,7 @@
 /*                                                                     */
 /*                           Objective Caml                            */
 /*                                                                     */
-/*              Pascal Cuoq, projet Cristal, INRIA Rocquencourt        */
+/*   Pascal Cuoq and Xavier Leroy, projet Cristal, INRIA Rocquencourt  */
 /*                                                                     */
 /*  Copyright 1996 Institut National de Recherche en Informatique et   */
 /*  Automatique.  Distributed only by permission.                      */
@@ -15,38 +15,33 @@
 #include <mlvalues.h>
 #include <alloc.h>
 #include <memory.h>
-#include <process.h>
 #include "unixsupport.h"
 #include <sys/types.h>
 
-static value alloc_process_status(pid, status)
-     int pid, status;
+static value alloc_process_status(HANDLE pid, int status)
 {
   value res, st;
 
-  if ((status & 0xFF) == 0) {
-    /* Normal termination: lo-byte = 0, hi-byte = child exit code */
-    st = alloc(1, 0);
-    Field(st, 0) = Val_int(status >> 8);
-  } else {
-    /* Abnormal termination: lo-byte = term status, hi-byte = 0 */
-    st = alloc(1, 1);
-    Field(st, 0) = Val_int(status & 0xFF);
-  }
+  st = alloc(1, 0);
+  Field(st, 0) = Val_int(status);
   Begin_root (st);
     res = alloc_tuple(2);
-    Field(res, 0) = Val_int(pid);
+    Field(res, 0) = Val_long((long) pid);
     Field(res, 1) = st;
   End_roots();
   return res;
 }
 
-value win_waitpid(flags, vpid_req) /* ML */
-     value flags, vpid_req;
+value win_waitpid(value flags, value vpid_req) /* ML */
 {
-  int status, pid_req;
-  pid_req = Int_val(vpid_req);
-  if (_cwait(&status, pid_req, 0/* ignored by win32 */) == -1)
-    uerror("waitpid", Nothing);  
-  return alloc_process_status(pid_req, status);
+  int status;
+  HANDLE pid_req = (HANDLE) Long_val(vpid_req);
+
+  if (WaitForSingleObject(pid_req, INFINITE) != WAIT_FAILED
+      && GetExitCodeProcess(pid_req, &status)) {
+    return alloc_process_status(pid_req, status);
+  } else {
+    _dosmaperr(GetLastError());
+    uerror("waitpid", Nothing);
+  }
 }