clucumber 0.1.1 → 0.2.0

data/lib/clucumber/vendor/usocket/backend/lispworks.lisp

@@ -0,0 +1,741 @@
+;;;; $Id: lispworks.lisp 521 2010-02-21 03:38:51Z ctian $
+;;;; $URL: svn://common-lisp.net/project/usocket/svn/usocket/trunk/backend/lispworks.lisp $
+
+;;;; See LICENSE for licensing information.
+
+(in-package :usocket)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (require "comm")
+
+  #+lispworks3
+  (error "LispWorks 3 is not supported by USOCKET."))
+
+;;; ---------------------------------------------------------------------------
+;;;  Warn if multiprocessing is not running on Lispworks
+
+(defun check-for-multiprocessing-started (&optional errorp)
+  (unless mp:*current-process*
+    (funcall (if errorp 'error 'warn)
+             "You must start multiprocessing on Lispworks by calling~
+              ~%~3t(~s)~
+              ~%for ~s function properly."
+             'mp:initialize-multiprocessing
+             'wait-for-input)))
+
+(eval-when (:load-toplevel :execute)
+  (check-for-multiprocessing-started))
+
+#+win32
+(eval-when (:load-toplevel :execute)
+  (fli:register-module "ws2_32")
+  (comm::ensure-sockets))
+
+(fli:define-foreign-function (get-host-name-internal "gethostname" :source)
+      ((return-string (:reference-return (:ef-mb-string :limit 257)))
+       (namelen :int))
+      :lambda-list (&aux (namelen 256) return-string)
+      :result-type :int
+      #+win32 :module
+      #+win32 "ws2_32")
+
+(defun get-host-name ()
+  (multiple-value-bind (retcode name)
+      (get-host-name-internal)
+    (when (= 0 retcode)
+      name)))
+
+#+win32
+(defun remap-maybe-for-win32 (z)
+  (mapcar #'(lambda (x)
+              (cons (mapcar #'(lambda (y)
+                                (+ 10000 y))
+                            (car x))
+                    (cdr x)))
+          z))
+
+(defparameter +lispworks-error-map+
+  #+win32
+  (append (remap-maybe-for-win32 +unix-errno-condition-map+)
+          (remap-maybe-for-win32 +unix-errno-error-map+))
+  #-win32
+  (append +unix-errno-condition-map+
+          +unix-errno-error-map+))
+
+(defun raise-or-signal-socket-error (errno socket)
+  (let ((usock-err
+         (cdr (assoc errno +lispworks-error-map+ :test #'member))))
+    (if usock-err
+        (if (subtypep usock-err 'error)
+            (error usock-err :socket socket)
+          (signal usock-err :socket))
+      (error 'unknown-error
+             :socket socket
+             :real-condition nil))))
+
+(defun raise-usock-err (errno socket &optional condition)
+  (let* ((usock-err
+          (cdr (assoc errno +lispworks-error-map+
+                      :test #'member))))
+    (if usock-err
+        (if (subtypep usock-err 'error)
+            (error usock-err :socket socket)
+          (signal usock-err :socket))
+      (error 'unknown-error
+             :socket socket
+             :real-error condition))))
+
+(defun handle-condition (condition &optional (socket nil))
+  "Dispatch correct usocket condition."
+  (typecase condition
+    (simple-error (destructuring-bind (&optional host port err-msg errno)
+                      (simple-condition-format-arguments condition)
+                    (declare (ignore host port err-msg))
+                    (raise-usock-err errno socket condition)))))
+
+(defconstant *socket_sock_dgram* 2
+  "Connectionless, unreliable datagrams of fixed maximum length.")
+
+(defconstant *sockopt_so_rcvtimeo*
+  #+(not linux) #x1006
+  #+linux 20
+  "Socket receive timeout")
+
+(fli:define-c-struct timeval
+  (tv-sec :long)
+  (tv-usec :long))
+
+;;; ssize_t
+;;; recvfrom(int socket, void *restrict buffer, size_t length, int flags,
+;;;          struct sockaddr *restrict address, socklen_t *restrict address_len);
+(fli:define-foreign-function (%recvfrom "recvfrom" :source)
+    ((socket :int)
+     (buffer (:pointer (:unsigned :byte)))
+     (length :int)
+     (flags :int)
+     (address (:pointer (:struct comm::sockaddr)))
+     (address-len (:pointer :int)))
+  :result-type :int
+  #+win32 :module
+  #+win32 "ws2_32")
+
+;;; ssize_t
+;;; sendto(int socket, const void *buffer, size_t length, int flags,
+;;;        const struct sockaddr *dest_addr, socklen_t dest_len);
+(fli:define-foreign-function (%sendto "sendto" :source)
+    ((socket :int)
+     (buffer (:pointer (:unsigned :byte)))
+     (length :int)
+     (flags :int)
+     (address (:pointer (:struct comm::sockaddr)))
+     (address-len :int))
+  :result-type :int
+  #+win32 :module
+  #+win32 "ws2_32")
+
+#-win32
+(defun set-socket-receive-timeout (socket-fd seconds)
+  "Set socket option: RCVTIMEO, argument seconds can be a float number"
+  (declare (type integer socket-fd)
+           (type number seconds))
+  (multiple-value-bind (sec usec) (truncate seconds)
+    (fli:with-dynamic-foreign-objects ((timeout (:struct timeval)))
+      (fli:with-foreign-slots (tv-sec tv-usec) timeout
+        (setf tv-sec sec
+              tv-usec (truncate (* 1000000 usec)))
+        (if (zerop (comm::setsockopt socket-fd
+                               comm::*sockopt_sol_socket*
+                               *sockopt_so_rcvtimeo*
+                               (fli:copy-pointer timeout
+                                                 :type '(:pointer :void))
+                               (fli:size-of '(:struct timeval))))
+            seconds)))))
+
+#+win32
+(defun set-socket-receive-timeout (socket-fd seconds)
+  "Set socket option: RCVTIMEO, argument seconds can be a float number.
+   On win32, you must bind the socket before use this function."
+  (declare (type integer socket-fd)
+           (type number seconds))
+  (fli:with-dynamic-foreign-objects ((timeout :int))
+    (setf (fli:dereference timeout)
+          (truncate (* 1000 seconds)))
+    (if (zerop (comm::setsockopt socket-fd
+                           comm::*sockopt_sol_socket*
+                           *sockopt_so_rcvtimeo*
+                           (fli:copy-pointer timeout
+                                             :type '(:pointer :char))
+                           (fli:size-of :int)))
+        seconds)))
+
+#-win32
+(defmethod get-socket-receive-timeout (socket-fd)
+  "Get socket option: RCVTIMEO, return value is a float number"
+  (declare (type integer socket-fd))
+  (fli:with-dynamic-foreign-objects ((timeout (:struct timeval))
+                                     (len :int))
+    (comm::getsockopt socket-fd
+                comm::*sockopt_sol_socket*
+                *sockopt_so_rcvtimeo*
+                (fli:copy-pointer timeout
+                                  :type '(:pointer :void))
+                len)
+    (fli:with-foreign-slots (tv-sec tv-usec) timeout
+      (float (+ tv-sec (/ tv-usec 1000000))))))
+
+#+win32
+(defmethod get-socket-receive-timeout (socket-fd)
+  "Get socket option: RCVTIMEO, return value is a float number"
+  (declare (type integer socket-fd))
+  (fli:with-dynamic-foreign-objects ((timeout :int)
+                                     (len :int))
+    (comm::getsockopt socket-fd
+                comm::*sockopt_sol_socket*
+                *sockopt_so_rcvtimeo*
+                (fli:copy-pointer timeout
+                                  :type '(:pointer :void))
+                len)
+    (float (/ (fli:dereference timeout) 1000))))
+
+(defun open-udp-socket (&key local-address local-port read-timeout)
+  "Open a unconnected UDP socket.
+   For binding on address ANY(*), just not set LOCAL-ADDRESS (NIL),
+   for binding on random free unused port, set LOCAL-PORT to 0."
+  (let ((socket-fd (comm::socket comm::*socket_af_inet* *socket_sock_dgram* comm::*socket_pf_unspec*)))
+    (if socket-fd
+      (progn
+        (when read-timeout (set-socket-receive-timeout socket-fd read-timeout))
+        (if local-port
+            (fli:with-dynamic-foreign-objects ((client-addr (:struct comm::sockaddr_in)))
+              (comm::initialize-sockaddr_in client-addr comm::*socket_af_inet*
+                                      local-address local-port "udp")
+              (if (comm::bind socket-fd
+                        (fli:copy-pointer client-addr :type '(:struct comm::sockaddr))
+                        (fli:pointer-element-size client-addr))
+		  ;; success, return socket fd
+		  socket-fd
+		  (progn
+		    (comm::close-socket socket-fd)
+		    (error "cannot bind"))))
+	    socket-fd))
+      (error "cannot create socket"))))
+
+(defun connect-to-udp-server (hostname service
+			      &key local-address local-port read-timeout)
+  "Something like CONNECT-TO-TCP-SERVER"
+  (let ((socket-fd (open-udp-socket :local-address local-address
+				    :local-port local-port
+				    :read-timeout read-timeout)))
+    (if socket-fd
+        (fli:with-dynamic-foreign-objects ((server-addr (:struct comm::sockaddr_in)))
+          ;; connect to remote address/port
+          (comm::initialize-sockaddr_in server-addr comm::*socket_af_inet* hostname service "udp")
+          (if (comm::connect socket-fd
+			     (fli:copy-pointer server-addr :type '(:struct comm::sockaddr))
+			     (fli:pointer-element-size server-addr))
+            ;; success, return socket fd
+            socket-fd
+            ;; fail, close socket and return nil
+            (progn
+              (comm::close-socket socket-fd)
+	      (error "cannot connect"))))
+	(error "cannot create socket"))))
+
+;; Register a special free action for closing datagram usocket when being GCed
+(defun usocket-special-free-action (object)
+  (when (and (typep object 'datagram-usocket)
+             (%open-p object))
+    (socket-close object)))
+
+(eval-when (:load-toplevel :execute)
+  (hcl:add-special-free-action 'usocket-special-free-action))
+
+(defun socket-connect (host port &key (protocol :stream) (element-type 'base-char)
+                       timeout deadline (nodelay t nodelay-specified)
+                       local-host (local-port #+win32 *auto-port* #-win32 nil))
+  (declare (ignorable nodelay))
+
+  ;; What's the meaning of this keyword?
+  (when deadline
+    (unimplemented 'deadline 'socket-connect))
+
+  #+(and lispworks4 (not lispworks4.4)) ; < 4.4.5
+  (when timeout
+    (unsupported 'timeout 'socket-connect :minimum "LispWorks 4.4.5"))
+
+  #+(or lispworks4 lispworks5.0) ; < 5.1
+  (when nodelay-specified
+    (unsupported 'nodelay 'socket-connect :minimum "LispWorks 5.1"))
+
+  #+lispworks4 #+lispworks4
+  (when local-host
+     (unsupported 'local-host 'socket-connect :minimum "LispWorks 5.0"))
+  (when local-port
+     (unsupported 'local-port 'socket-connect :minimum "LispWorks 5.0"))
+
+  (ecase protocol
+    (:stream
+     (let ((hostname (host-to-hostname host))
+	   (stream))
+       (setf stream
+	     (with-mapped-conditions ()
+	       (comm:open-tcp-stream hostname port
+				     :element-type element-type
+				     #-(and lispworks4 (not lispworks4.4)) ; >= 4.4.5
+				     #-(and lispworks4 (not lispworks4.4))
+				     :timeout timeout
+				     #-lispworks4 #-lispworks4
+				     #-lispworks4 #-lispworks4
+				     :local-address (when local-host (host-to-hostname local-host))
+				     :local-port local-port
+				     #-(or lispworks4 lispworks5.0) ; >= 5.1
+				     #-(or lispworks4 lispworks5.0)
+				     :nodelay nodelay)))
+       (if stream
+	   (make-stream-socket :socket (comm:socket-stream-socket stream)
+			       :stream stream)
+	   (error 'unknown-error))))
+    (:datagram
+     (let ((usocket (make-datagram-socket
+		     (if (and host port)
+			 (connect-to-udp-server host port
+						:local-address local-host
+						:local-port local-port)
+			 (open-udp-socket :local-address local-host
+					  :local-port local-port))
+		     :connected-p t)))
+       (hcl:flag-special-free-action usocket)
+       usocket))))
+
+(defun socket-listen (host port
+                           &key reuseaddress
+                           (reuse-address nil reuse-address-supplied-p)
+                           (backlog 5)
+                           (element-type 'base-char))
+  #+lispworks4.1
+  (unsupported 'host 'socket-listen :minimum "LispWorks 4.0 or newer than 4.1")
+  #+lispworks4.1
+  (unsupported 'backlog 'socket-listen :minimum "LispWorks 4.0 or newer than 4.1")
+
+  (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress))
+         (comm::*use_so_reuseaddr* reuseaddress)
+         (hostname (host-to-hostname host))
+         (sock (with-mapped-conditions ()
+                  #-lispworks4.1 (comm::create-tcp-socket-for-service
+                                  port :address hostname :backlog backlog)
+                  #+lispworks4.1 (comm::create-tcp-socket-for-service port))))
+    (make-stream-server-socket sock :element-type element-type)))
+
+(defmethod socket-accept ((usocket stream-server-usocket) &key element-type)
+  (let* ((sock (with-mapped-conditions (usocket)
+                 (comm::get-fd-from-socket (socket usocket))))
+         (stream (make-instance 'comm:socket-stream
+                                :socket sock
+                                :direction :io
+                                :element-type (or element-type
+                                                  (element-type usocket)))))
+    #+win32
+    (when sock
+      (setf (%ready-p usocket) nil))
+    (make-stream-socket :socket sock :stream stream)))
+
+;; Sockets and their streams are different objects
+;; close the stream in order to make sure buffers
+;; are correctly flushed and the socket closed.
+(defmethod socket-close ((usocket stream-usocket))
+  "Close socket."
+  (when (wait-list usocket)
+     (remove-waiter (wait-list usocket) usocket))
+  (close (socket-stream usocket)))
+
+(defmethod socket-close ((usocket usocket))
+  (when (wait-list usocket)
+     (remove-waiter (wait-list usocket) usocket))
+  (with-mapped-conditions (usocket)
+     (comm::close-socket (socket usocket))))
+
+(defmethod socket-close :after ((socket datagram-usocket))
+  "Additional socket-close method for datagram-usocket"
+  (setf (%open-p socket) nil))
+
+(defvar *message-send-buffer*
+  (make-array +max-datagram-packet-size+
+              :element-type '(unsigned-byte 8)
+              :allocation :static))
+
+(defvar *message-send-lock*
+  (mp:make-lock :name "USOCKET message send lock"))
+
+(defun send-message (socket-fd buffer &optional (length (length buffer)) host service)
+  "Send message to a socket, using sendto()/send()"
+  (declare (type integer socket-fd)
+           (type sequence buffer))
+  (let ((message *message-send-buffer*))
+    (fli:with-dynamic-foreign-objects ((client-addr (:struct comm::sockaddr_in))
+                                       (len :int
+					    #-(or lispworks4 lispworks5.0) ; <= 5.0
+                                            :initial-element
+                                            (fli:size-of '(:struct comm::sockaddr_in))))
+      (fli:with-dynamic-lisp-array-pointer (ptr message :type '(:unsigned :byte))
+        (mp:with-lock (*message-send-lock*)
+          (replace message buffer :end2 length)
+          (if (and host service)
+              (progn
+                (comm::initialize-sockaddr_in client-addr comm::*socket_af_inet* host service "udp")
+                (%sendto socket-fd ptr (min length +max-datagram-packet-size+) 0
+                         (fli:copy-pointer client-addr :type '(:struct comm::sockaddr))
+                         (fli:dereference len)))
+              (comm::%send socket-fd ptr (min length +max-datagram-packet-size+) 0)))))))
+
+(defmethod socket-send ((socket datagram-usocket) buffer length &key host port)
+  (let ((s (socket socket)))
+    (send-message s buffer length (and host (host-to-hbo host)) port)))
+
+(defvar *message-receive-buffer*
+  (make-array +max-datagram-packet-size+
+              :element-type '(unsigned-byte 8)
+              :allocation :static))
+
+(defvar *message-receive-lock*
+  (mp:make-lock :name "USOCKET message receive lock"))
+
+(defun receive-message (socket-fd &optional buffer (length (length buffer))
+			&key read-timeout (max-buffer-size +max-datagram-packet-size+))
+  "Receive message from socket, read-timeout is a float number in seconds.
+
+   This function will return 4 values:
+   1. receive buffer
+   2. number of receive bytes
+   3. remote address
+   4. remote port"
+  (declare (type integer socket-fd)
+           (type sequence buffer))
+  (let ((message *message-receive-buffer*)
+        old-timeout)
+    (fli:with-dynamic-foreign-objects ((client-addr (:struct comm::sockaddr_in))
+                                       (len :int
+					    #-(or lispworks4 lispworks5.0) ; <= 5.0
+                                            :initial-element
+                                            (fli:size-of '(:struct comm::sockaddr_in))))
+      (fli:with-dynamic-lisp-array-pointer (ptr message :type '(:unsigned :byte))
+        ;; setup new read timeout
+        (when read-timeout
+          (setf old-timeout (get-socket-receive-timeout socket-fd))
+          (set-socket-receive-timeout socket-fd read-timeout))
+        (mp:with-lock (*message-receive-lock*)
+          (let ((n (%recvfrom socket-fd ptr max-buffer-size 0
+                              (fli:copy-pointer client-addr :type '(:struct comm::sockaddr))
+                              len)))
+            ;; restore old read timeout
+            (when (and read-timeout (/= old-timeout read-timeout))
+              (set-socket-receive-timeout socket-fd old-timeout))
+            (if (plusp n)
+                (values (if buffer
+                            (replace buffer message
+                                     :end1 (min length max-buffer-size)
+                                     :end2 (min n max-buffer-size))
+                          (subseq message 0 (min n max-buffer-size)))
+                        (min n max-buffer-size)
+			(comm::ntohl (fli:foreign-slot-value
+				      (fli:foreign-slot-value client-addr
+							      'comm::sin_addr
+							      :object-type '(:struct comm::sockaddr_in)
+							      :type '(:struct comm::in_addr)
+							      :copy-foreign-object nil)
+				      'comm::s_addr
+				      :object-type '(:struct comm::in_addr)))
+                        (comm::ntohs (fli:foreign-slot-value client-addr
+							     'comm::sin_port
+							     :object-type '(:struct comm::sockaddr_in)
+							     :type '(:unsigned :short)
+							     :copy-foreign-object nil)))
+		(values nil n 0 0))))))))
+
+(defmethod socket-receive ((socket datagram-usocket) buffer length &key)
+  (let ((s (socket socket)))
+    (multiple-value-bind (buffer size host port)
+	(receive-message s buffer length)
+      (values buffer size host port))))
+
+(defmethod get-local-name ((usocket usocket))
+  (multiple-value-bind
+      (address port)
+      (comm:get-socket-address (socket usocket))
+    (values (hbo-to-vector-quad address) port)))
+
+(defmethod get-peer-name ((usocket stream-usocket))
+  (multiple-value-bind
+      (address port)
+      (comm:get-socket-peer-address (socket usocket))
+    (values (hbo-to-vector-quad address) port)))
+
+(defmethod get-local-address ((usocket usocket))
+  (nth-value 0 (get-local-name usocket)))
+
+(defmethod get-peer-address ((usocket stream-usocket))
+  (nth-value 0 (get-peer-name usocket)))
+
+(defmethod get-local-port ((usocket usocket))
+  (nth-value 1 (get-local-name usocket)))
+
+(defmethod get-peer-port ((usocket stream-usocket))
+  (nth-value 1 (get-peer-name usocket)))
+
+(defun get-hosts-by-name (name)
+  (with-mapped-conditions ()
+     (mapcar #'hbo-to-vector-quad
+             (comm:get-host-entry name :fields '(:addresses)))))
+
+(defun os-socket-handle (usocket)
+  (socket usocket))
+
+(defun usocket-listen (usocket)
+  (if (stream-usocket-p usocket)
+      (when (listen (socket-stream usocket))
+        usocket)
+    (when (comm::socket-listen (socket usocket))
+      usocket)))
+
+;;;
+;;; Non Windows implementation
+;;;   The Windows implementation needs to resort to the Windows API in order
+;;;   to achieve what we want (what we want is waiting without busy-looping)
+;;;
+
+#-win32
+(progn
+
+  (defun %setup-wait-list (wait-list)
+    (declare (ignore wait-list)))
+
+  (defun %add-waiter (wait-list waiter)
+    (declare (ignore wait-list waiter)))
+
+  (defun %remove-waiter (wait-list waiter)
+    (declare (ignore wait-list waiter)))
+
+  (defun wait-for-input-internal (wait-list &key timeout)
+    (with-mapped-conditions ()
+      ;; unfortunately, it's impossible to share code between
+      ;; non-win32 and win32 platforms...
+      ;; Can we have a sane -pref. complete [UDP!?]- API next time, please?
+      (dolist (x (wait-list-waiters wait-list))
+        (mp:notice-fd (os-socket-handle x)))
+      (labels ((wait-function (socks)
+		 (let (rv)
+		   (dolist (x socks rv)
+		     (when (usocket-listen x)
+		       (setf (state x) :READ
+			     rv t))))))
+	(if timeout
+	    (mp:process-wait-with-timeout "Waiting for a socket to become active"
+					(truncate timeout)
+					#'wait-function
+					(wait-list-waiters wait-list))
+	    (mp:process-wait "Waiting for a socket to become active"
+			     #'wait-function
+			     (wait-list-waiters wait-list))))
+      (dolist (x (wait-list-waiters wait-list))
+        (mp:unnotice-fd (os-socket-handle x)))
+      wait-list))
+
+) ; end of block
+
+
+;;;
+;;;  The Windows side of the story
+;;;    We want to wait without busy looping
+;;;    This code only works in threads which don't have (hidden)
+;;;    windows which need to receive messages. There are workarounds in the Windows API
+;;;    but are those available to 'us'.
+;;;
+
+
+#+win32
+(progn
+
+  ;; LispWorks doesn't provide an interface to wait for a socket
+  ;; to become ready (under Win32, that is) meaning that we need
+  ;; to resort to system calls to achieve the same thing.
+  ;; Luckily, it provides us access to the raw socket handles (as we 
+  ;; wrote the code above.
+
+  (defconstant fd-read 1)
+  (defconstant fd-read-bit 0)
+  (defconstant fd-write 2)
+  (defconstant fd-write-bit 1)
+  (defconstant fd-oob 4)
+  (defconstant fd-oob-bit 2)
+  (defconstant fd-accept 8)
+  (defconstant fd-accept-bit 3)
+  (defconstant fd-connect 16)
+  (defconstant fd-connect-bit 4)
+  (defconstant fd-close 32)
+  (defconstant fd-close-bit 5)
+  (defconstant fd-qos 64)
+  (defconstant fd-qos-bit 6)
+  (defconstant fd-group-qos 128)
+  (defconstant fd-group-qos-bit 7)
+  (defconstant fd-routing-interface 256)
+  (defconstant fd-routing-interface-bit 8)
+  (defconstant fd-address-list-change 512)
+  (defconstant fd-address-list-change-bit 9)
+  
+  (defconstant fd-max-events 10)
+
+  (defconstant fionread 1074030207)
+
+
+  ;; Note:
+  ;;
+  ;;  If special finalization has to occur for a given
+  ;;  system resource (handle), an associated object should
+  ;;  be created.  A special cleanup action should be added
+  ;;  to the system and a special cleanup action should
+  ;;  be flagged on all objects created for resources like it
+  ;;
+  ;;  We have 2 functions to do so:
+  ;;   * hcl:add-special-free-action (function-symbol)
+  ;;   * hcl:flag-special-free-action (object)
+  ;;
+  ;;  Note that the special free action will be called on all
+  ;;  objects which have been flagged for special free, so be
+  ;;  sure to check for the right argument type!
+  
+  (fli:define-foreign-type ws-socket () '(:unsigned :int))
+  (fli:define-foreign-type win32-handle () '(:unsigned :int))
+  (fli:define-c-struct wsa-network-events (network-events :long)
+    (error-code (:c-array :int 10)))
+
+  (fli:define-foreign-function (wsa-event-create "WSACreateEvent" :source)
+      ()
+      :lambda-list nil
+    :result-type :int
+    :module "ws2_32")
+
+  (fli:define-foreign-function (wsa-event-close "WSACloseEvent" :source)
+      ((event-object win32-handle))
+    :result-type :int
+    :module "ws2_32")
+
+  (fli:define-foreign-function (wsa-enum-network-events "WSAEnumNetworkEvents" :source)
+      ((socket ws-socket)
+       (event-object win32-handle)
+       (network-events (:reference-return wsa-network-events)))
+    :result-type :int
+    :module "ws2_32")
+  
+  (fli:define-foreign-function (wsa-event-select "WSAEventSelect" :source)
+      ((socket ws-socket)
+       (event-object win32-handle)
+       (network-events :long))
+    :result-type :int
+    :module "ws2_32")
+
+  (fli:define-foreign-function (wsa-get-last-error "WSAGetLastError" :source)
+      ()
+    :result-type :int
+    :module "ws2_32")
+
+  (fli:define-foreign-function (wsa-ioctlsocket "ioctlsocket" :source)
+      ((socket :long) (cmd :long) (argp (:ptr :long)))
+    :result-type :int
+    :module "ws2_32")
+
+
+  ;; The Windows system 
+
+
+  ;; Now that we have access to the system calls, this is the plan:
+
+  ;; 1. Receive a wait-list with associated sockets to wait for
+  ;; 2. Add all those sockets to an event handle
+  ;; 3. Listen for an event on that handle (we have a LispWorks system:: internal for that)
+  ;; 4. After listening, detect if there are errors
+  ;;    (this step is different from Unix, where we can have only one error)
+  ;; 5. If so, raise one of them
+  ;; 6. If not so, return the sockets which have input waiting for them
+
+
+  (defun maybe-wsa-error (rv &optional socket)
+    (unless (zerop rv)
+      (raise-usock-err (wsa-get-last-error) socket)))
+
+  (defun bytes-available-for-read (socket)
+    (fli:with-dynamic-foreign-objects ((int-ptr :long))
+      (let ((rv (wsa-ioctlsocket (os-socket-handle socket) fionread int-ptr)))
+        (if (= 0 rv)
+            (fli:dereference int-ptr)
+          0))))
+
+  (defun socket-ready-p (socket)
+     (if (typep socket 'stream-usocket)
+       (< 0 (bytes-available-for-read socket))
+       (%ready-p socket)))
+
+  (defun waiting-required (sockets)
+    (notany #'socket-ready-p sockets))
+
+  (defun wait-for-input-internal (wait-list &key timeout)
+    (when (waiting-required (wait-list-waiters wait-list))
+      (system:wait-for-single-object (wait-list-%wait wait-list)
+                                     "Waiting for socket activity" timeout))
+    (update-ready-and-state-slots (wait-list-waiters wait-list)))
+  
+  (defun map-network-events (func network-events)
+    (let ((event-map (fli:foreign-slot-value network-events 'network-events))
+          (error-array (fli:foreign-slot-pointer network-events 'error-code)))
+      (unless (zerop event-map)
+	  (dotimes (i fd-max-events)
+	    (unless (zerop (ldb (byte 1 i) event-map)) ;;### could be faster with ash and logand?
+	      (funcall func (fli:foreign-aref error-array i)))))))
+
+  (defun update-ready-and-state-slots (sockets)
+     (dolist (socket sockets)
+        (if (or (and (stream-usocket-p socket)
+                     (listen (socket-stream socket)))
+                (%ready-p socket))
+            (setf (state socket) :READ)
+          (multiple-value-bind
+                (rv network-events)
+                (wsa-enum-network-events (os-socket-handle socket) 0 t)
+             (if (zerop rv)
+                 (map-network-events #'(lambda (err-code)
+                                         (if (zerop err-code)
+                                             (setf (%ready-p socket) t
+                                                   (state socket) :READ)
+                                             (raise-usock-err err-code socket)))
+                                     network-events)
+                 (maybe-wsa-error rv socket))))))
+
+
+
+  ;; The wait-list part
+
+  (defun free-wait-list (wl)
+    (when (wait-list-p wl)
+      (unless (null (wait-list-%wait wl))
+        (wsa-event-close (wait-list-%wait wl)))))
+  
+  (eval-when (:load-toplevel :execute)
+    (hcl:add-special-free-action 'free-wait-list))
+  
+  (defun %setup-wait-list (wait-list)
+    (hcl:flag-special-free-action wait-list)
+    (setf (wait-list-%wait wait-list) (wsa-event-create)))
+
+  (defun %add-waiter (wait-list waiter)
+    (let ((events (etypecase waiter
+                    (stream-server-usocket (logior fd-connect fd-accept fd-close))
+                    (stream-usocket (logior fd-connect fd-read fd-oob fd-close))
+                    (datagram-usocket (logior fd-read)))))
+      (maybe-wsa-error
+       (wsa-event-select (os-socket-handle waiter) (wait-list-%wait wait-list) events)
+       waiter)))
+
+  (defun %remove-waiter (wait-list waiter)
+    (maybe-wsa-error
+     (wsa-event-select (os-socket-handle waiter) (wait-list-%wait wait-list) 0)
+     waiter))
+  
+) ; end of WIN32-block