Author: ctian
Date: Mon Jul 5 05:03:05 2010
New Revision: 531
Log:
SBCL: commit untested WAIT-FOR-INPUT for win32.
Modified:
usocket/trunk/backend/lispworks.lisp
usocket/trunk/backend/sbcl.lisp
usocket/trunk/usocket.lisp
Modified: usocket/trunk/backend/lispworks.lisp
==============================================================================
--- usocket/trunk/backend/lispworks.lisp (original)
+++ usocket/trunk/backend/lispworks.lisp Mon Jul 5 05:03:05 2010
@@ -604,7 +604,8 @@
(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)
+ (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)
@@ -669,9 +670,9 @@
0))))
(defun socket-ready-p (socket)
- (if (typep socket 'stream-usocket)
- (< 0 (bytes-available-for-read 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))
@@ -686,29 +687,27 @@
(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)))))))
+ (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))))))
-
-
+ (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
Modified: usocket/trunk/backend/sbcl.lisp
==============================================================================
--- usocket/trunk/backend/sbcl.lisp (original)
+++ usocket/trunk/backend/sbcl.lisp Mon Jul 5 05:03:05 2010
@@ -13,6 +13,10 @@
(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
@@ -354,18 +358,15 @@
#+(and sbcl (not win32))
(progn
+ (defun %setup-wait-list (wait-list)
+ (declare (ignore wait-list)))
-(defun %setup-wait-list (wait-list)
- (declare (ignore wait-list)))
-
-(defun %add-waiter (wait-list waiter)
- (push (socket waiter) (wait-list-%wait wait-list)))
-
-(defun %remove-waiter (wait-list waiter)
- (setf (wait-list-%wait wait-list)
- (remove (socket waiter) (wait-list-%wait wait-list))))
-
+ (defun %add-waiter (wait-list waiter)
+ (push (socket waiter) (wait-list-%wait wait-list)))
+ (defun %remove-waiter (wait-list waiter)
+ (setf (wait-list-%wait wait-list)
+ (remove (socket waiter) (wait-list-%wait wait-list))))
(defun wait-for-input-internal (sockets &key timeout)
(with-mapped-conditions ()
@@ -398,8 +399,141 @@
(setf (state x) :READ))))))))))
) ; progn
+
+;;; WAIT-FOR-INPUT support for SBCL on Windows platform (Chun Tian (binghe))
+;;; Based on LispWorks version written by Erik Huelsmann.
+
#+(and sbcl win32)
- (warn "wait-for-input not (yet!) supported...")
+(progn
+ (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)
+
+ (sb-alien:define-alien-type ws-socket sb-alien:unsigned-int)
+
+ (sb-alien:define-alien-type nil
+ (sb-alien:struct wsa-network-events
+ (network-events sb-alien:long)
+ (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
+
+ (sb-alien:define-alien-routine ("WSACloseEvent" wsa-event-close)
+ (sb-alien:boolean #.sb-vm::n-machine-word-bits)
+ (event-object sb-alien::hinstance))
+
+ (sb-alien:define-alien-routine ("WSAEnumNetworkEvents" wsa-enum-network-events)
+ sb-alien:int
+ (socket ws-socket)
+ (event-object sb-alien::hinstance)
+ (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)
+ (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))
+
+ (defun maybe-wsa-error (rv &optional socket)
+ (unless (zerop rv)
+ (raise-usock-err (sockint::wsa-get-last-error) socket)))
+
+ (defun os-socket-handle (usocket)
+ (socket usocket))
+
+ (defun bytes-available-for-read (socket)
+ (sb-alien:with-alien ((int-ptr sb-alien:long))
+ (let ((rv (sockint::win32-ioctl (os-socket-handle socket) fionread int-ptr)))
+ (prog1
+ (if (= 0 rv) (sb-alien:deref int-ptr) 0)
+ (sb-alien:free-alien int-ptr)))))
+
+ (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))
+ (maybe-wsa-error
+ (wait-for-single-object (wait-list-%wait wait-list) (truncate (* 1000 timeout)))
+ wait-list))
+ (update-ready-and-state-slots (wait-list-waiters wait-list)))
+
+ (defun map-network-events (func network-events)
+ (let ((event-map (sb-alien:slot network-events 'network-events))
+ (error-array (sb-alien:slot 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 (sb-alien:deref 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))))))
+
+ (defun %setup-wait-list (wait-list)
+ (setf (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))))))
+
+ (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))
+) ; progn
#+ecl
(progn
@@ -423,5 +557,4 @@
(defun %remove-waiter (wl w)
(declare (ignore wl w)))
-
- )
+) ; progn
Modified: usocket/trunk/usocket.lisp
==============================================================================
--- usocket/trunk/usocket.lisp (original)
+++ usocket/trunk/usocket.lisp Mon Jul 5 05:03:05 2010
@@ -35,7 +35,7 @@
The last two remain unused in the current version.
")
- #+(and lispworks win32)
+ #+(and win32 (or sbcl lispworks))
(%ready-p
:initform nil
:accessor %ready-p
