[usocket-cvs] r535 - in usocket/trunk: . backend

[Chun Tian (binghe)]

Author: ctian
Date: Wed Jul  7 06:18:09 2010
New Revision: 535

Log:
SBCL: fix for ioctlsocket().

Modified:
   usocket/trunk/backend/sbcl.lisp
   usocket/trunk/usocket.lisp

Modified: usocket/trunk/backend/sbcl.lisp
==============================================================================
--- usocket/trunk/backend/sbcl.lisp	(original)
+++ usocket/trunk/backend/sbcl.lisp	Wed Jul  7 06:18:09 2010
@@ -427,9 +427,10 @@
   (defconstant fionread 1074030207)
 
   ;; For WaitForSingleObject
-  (defconstant +wait-failed+ -1) ; #xffffffff
-  (defconstant +wait-object-0+ 0)
-  (defconstant +wait-timeout+ 258)
+  (eval-when (:compile-toplevel)
+    (defconstant +wait-failed+ -1) ; #xffffffff
+    (defconstant +wait-object-0+ 0)
+    (defconstant +wait-timeout+ 258))
 
   (sb-alien:define-alien-type ws-socket sb-alien:unsigned-int)
 
@@ -466,7 +467,7 @@
       sb-alien:int
     (socket ws-socket)
     (cmd sb-alien:long)
-    (argp (* sb-alien::unsigned-long)))
+    (argp (* sb-alien:unsigned-long)))
 
   (defun raise-usock-err (errno socket)
     (error 'unknown-error
@@ -480,26 +481,34 @@
   (defun os-socket-handle (usocket)
     (sockint::fd->handle (sb-bsd-sockets:socket-file-descriptor (socket usocket))))
 
+  (defun socket-handle (usocket)
+    (sb-bsd-sockets:socket-file-descriptor (socket usocket)))
+
   (defun bytes-available-for-read (socket)
-    (sb-alien:with-alien ((int-ptr (* sb-alien:unsigned-long)))
-      (let ((rv (wsa-ioctlsocket (os-socket-handle socket) fionread int-ptr)))
-        (prog1
-            (if (= 0 rv) (sb-alien:deref int-ptr) 0)
-          (sb-alien:free-alien int-ptr)))))
+    (sb-alien:with-alien ((int-ptr sb-alien:unsigned-long))
+      (maybe-wsa-error (wsa-ioctlsocket (os-socket-handle socket) fionread (sb-alien:addr int-ptr))
+                       socket)
+      int-ptr))
 
   (defun socket-ready-p (socket)
     (if (typep socket 'stream-usocket)
-        (< 0 (bytes-available-for-read socket))
+        (plusp (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)
+    (format t "timeout: ~A, ~A~%" timeout (truncate (* 1000000 timeout)))
     (when (waiting-required (wait-list-waiters wait-list))
       (let ((rv (wait-for-single-object (wait-list-%wait wait-list) (truncate (* 1000000 timeout)))))
-        (format t "rv: ~A~%" rv)))
-    (update-ready-and-state-slots (wait-list-waiters wait-list)))
+        (ecase rv
+          ((#.+wait-object-0+ #.+wait-timeout+)
+           (update-ready-and-state-slots (wait-list-waiters wait-list)))
+          (#.+wait-failed+
+           (raise-usock-err
+            (sb-win32::get-last-error-message (sb-win32::get-last-error))
+            wait-list))))))
 
   (defun map-network-events (func network-events)
     (let ((event-map (sb-alien:slot network-events 'network-events))

Modified: usocket/trunk/usocket.lisp
==============================================================================
--- usocket/trunk/usocket.lisp	(original)
+++ usocket/trunk/usocket.lisp	Wed Jul  7 06:18:09 2010
@@ -311,13 +311,14 @@
     (dolist (x (wait-list-waiters socket-or-sockets))
       (when (setf (state x)
                   (if (and (stream-usocket-p x)
-                           (listen (socket-stream x)))
+                           (listen (socket-stream x))
+                           #+(and sbcl win32) nil) ; TODO: bug?!
                       :READ NIL))
         (incf sockets-ready)))
-         ;; the internal routine is responsibe for
-         ;; making sure the wait doesn't block on socket-streams of
-         ;; which theready- socket isn't ready, but there's space left in the
-         ;; buffer
+    ;; the internal routine is responsibe for
+    ;; making sure the wait doesn't block on socket-streams of
+    ;; which theready- socket isn't ready, but there's space left in the
+    ;; buffer
     (wait-for-input-internal socket-or-sockets
                              :timeout (if (zerop sockets-ready) timeout 0))
     (let ((to-result (when timeout