[usocket-cvs] r546 - usocket/trunk/backend

[Chun Tian (binghe)]

Author: ctian
Date: Thu Jul 15 23:05:27 2010
New Revision: 546

Log:
SBCL: first working WAIT-FOR-INPUT implementation.

Modified:
   usocket/trunk/backend/sbcl.lisp

Modified: usocket/trunk/backend/sbcl.lisp
==============================================================================
--- usocket/trunk/backend/sbcl.lisp	(original)
+++ usocket/trunk/backend/sbcl.lisp	Thu Jul 15 23:05:27 2010
@@ -13,10 +13,6 @@
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (require :sockets))
 
-#+(and sbcl win32) ; for "WaitForSingleObject"
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (sb-alien:load-shared-object "kernel32.dll"))
-
 #+sbcl
 (progn
   #-win32
@@ -399,9 +395,9 @@
 
 #+(and sbcl win32)
 (eval-when (:compile-toplevel)
-  (defconstant +wait-failed+ -1) ; #xffffffff
-  (defconstant +wait-object-0+ 0)
-  (defconstant +wait-timeout+ 258))
+  (defconstant +wsa-wait-failed+ #xffffffff)
+  (defconstant +wsa-wait-event-0+ 0)
+  (defconstant +wsa-wait-timeout+ 258))
 
 #+(and sbcl win32)
 (progn
@@ -429,6 +425,8 @@
   (defconstant fionread 1074030207)
 
   (sb-alien:define-alien-type ws-socket sb-alien:unsigned-int)
+  (sb-alien:define-alien-type ws-dword sb-alien:unsigned-long)
+  (sb-alien:define-alien-type ws-event sb-alien::hinstance)
 
   (sb-alien:define-alien-type nil
     (sb-alien:struct wsa-network-events
@@ -436,28 +434,35 @@
       (error-code (array sb-alien:int 10)))) ; 10 = fd-max-events
 
   (sb-alien:define-alien-routine ("WSACreateEvent" wsa-event-create)
-      sb-alien::hinstance) ; return type only
+      ws-event) ; return type only
+
+  (sb-alien:define-alien-routine ("WSAResetEvent" wsa-event-reset)
+      (boolean #.sb-vm::n-machine-word-bits)
+    (event-object ws-event))
 
   (sb-alien:define-alien-routine ("WSACloseEvent" wsa-event-close)
-      (sb-alien:boolean #.sb-vm::n-machine-word-bits)
-    (event-object sb-alien::hinstance))
+      (boolean #.sb-vm::n-machine-word-bits)
+    (event-object ws-event))
 
   (sb-alien:define-alien-routine ("WSAEnumNetworkEvents" wsa-enum-network-events)
       sb-alien:int
     (socket ws-socket)
-    (event-object sb-alien::hinstance)
+    (event-object ws-event)
     (network-events (* (sb-alien:struct wsa-network-events))))
 
   (sb-alien:define-alien-routine ("WSAEventSelect" wsa-event-select)
       sb-alien:int
     (socket ws-socket)
-    (event-object sb-alien::hinstance)
+    (event-object ws-event)
     (network-events sb-alien:long))
 
-  (sb-alien:define-alien-routine ("WaitForSingleObject" wait-for-single-object)
-      sb-alien:long
-    (object sb-alien::hinstance)
-    (timeout sb-alien:long))
+  (sb-alien:define-alien-routine ("WSAWaitForMultipleEvents" wsa-wait-for-multiple-events)
+      ws-dword
+    (number-of-events ws-dword)
+    (events (* ws-event))
+    (wait-all-p (boolean #.sb-vm::n-machine-word-bits))
+    (timeout ws-dword)
+    (alertable-p (boolean #.sb-vm::n-machine-word-bits)))
 
   (sb-alien:define-alien-routine ("ioctlsocket" wsa-ioctlsocket)
       sb-alien:int
@@ -496,11 +501,12 @@
 
   (defun wait-for-input-internal (wait-list &key timeout)
     (when (waiting-required (wait-list-waiters wait-list))
-      (let ((rv (wait-for-single-object (wait-list-%wait wait-list) (truncate (* 1000000 timeout)))))
+      (let ((rv (wsa-wait-for-multiple-events 1 (wait-list-%wait wait-list)
+                                              nil (truncate (* 1000 timeout)) nil)))
         (ecase rv
-          ((#.+wait-object-0+ #.+wait-timeout+)
+          ((#.+wsa-wait-event-0+ #.+wsa-wait-timeout+)
            (update-ready-and-state-slots (wait-list-waiters wait-list)))
-          (#.+wait-failed+
+          ((#.+wsa-wait-failed+)
            (raise-usock-err
             (sb-win32::get-last-error-message (sb-win32::get-last-error))
             wait-list))))))
@@ -530,24 +536,32 @@
                                       network-events)
                 (maybe-wsa-error rv socket)))))))
 
+  (defun os-wait-list-%wait (wait-list)
+    (sb-alien:deref (wait-list-%wait wait-list)))
+
+  (defun (setf os-wait-list-%wait) (value wait-list)
+    (setf (sb-alien:deref (wait-list-%wait wait-list)) value))
+
   (defun %setup-wait-list (wait-list)
-    (setf (wait-list-%wait wait-list) (wsa-event-create))
+    (setf (wait-list-%wait wait-list) (sb-alien:make-alien ws-event))
+    (setf (os-wait-list-%wait wait-list) (wsa-event-create))
     (sb-ext:finalize wait-list
                      #'(lambda () (unless (null (wait-list-%wait wait-list))
-                                    (wsa-event-close (wait-list-%wait wait-list))))))
+                                    (wsa-event-close (os-wait-list-%wait wait-list))
+                                    (sb-alien:free-alien (wait-list-%wait wait-list))))))
 
   (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))
+                    (stream-usocket (logior fd-read))
                     (datagram-usocket (logior fd-read)))))
       (maybe-wsa-error
-       (wsa-event-select (os-socket-handle waiter) (wait-list-%wait wait-list) events)
+       (wsa-event-select (os-socket-handle waiter) (os-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)
+     (wsa-event-select (os-socket-handle waiter) (os-wait-list-%wait wait-list) 0)
      waiter))
 ) ; progn