Author: ehuelsmann Date: Sun Jul 20 14:36:20 2008 New Revision: 373
Modified: usocket/branches/new-wfi/BRANCH-README usocket/branches/new-wfi/backend/lispworks.lisp usocket/branches/new-wfi/usocket.lisp Log: Commit new W-F-I for LispWorks; including fixes to actually make the backend work at all.
Modified: usocket/branches/new-wfi/BRANCH-README ============================================================================== --- usocket/branches/new-wfi/BRANCH-README (original) +++ usocket/branches/new-wfi/BRANCH-README Sun Jul 20 14:36:20 2008 @@ -3,6 +3,5 @@ At least these backends are broken, for now:
- ABCL - - LispWorks (Win32) - SBCL/ ECL - Scieneer
Modified: usocket/branches/new-wfi/backend/lispworks.lisp ============================================================================== --- usocket/branches/new-wfi/backend/lispworks.lisp (original) +++ usocket/branches/new-wfi/backend/lispworks.lisp Sun Jul 20 14:36:20 2008 @@ -304,7 +304,7 @@
;; Now that we have access to the system calls, this is the plan:
- ;; 1. Receive a list of sockets to listen to + ;; 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 @@ -324,14 +324,6 @@ (fli:dereference int-ptr) 0))))
- (defun add-socket-to-event (socket event-object) - (let ((events (etypecase socket - (stream-server-usocket (logior fd-connect fd-accept fd-close)) - (stream-usocket (logior fd-connect fd-read fd-oob fd-close))))) - (maybe-wsa-error - (wsa-event-select (os-socket-handle socket) event-object events) - socket))) - (defun socket-ready-p (socket) (if (typep socket 'stream-usocket) (< 0 (bytes-available-for-read socket)) @@ -340,43 +332,65 @@ (defun waiting-required (sockets) (notany #'socket-ready-p sockets))
- (defun wait-for-input-internal (sockets &key timeout) - (let ((event-object (wsa-event-create))) - (unwind-protect - (progn - (when (waiting-required sockets) - (dolist (socket sockets) - (add-socket-to-event socket event-object)) - (system:wait-for-single-object event-object - "Waiting for socket activity" timeout)) - (update-ready-slots sockets) - (sockets-ready sockets)) - (wsa-event-close event-object)))) + (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)) + (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-slots (sockets) + (defun update-ready-and-state-slots (sockets) (dolist (socket sockets) - (unless (or (stream-usocket-p socket) ;; no need to check status for streams - (%ready-p socket)) ;; and sockets already marked ready - (multiple-value-bind - (rv network-events) - (wsa-enum-network-events (os-socket-handle socket) 0 t) - (if (zerop rv) + (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) + (setf (%ready-p socket) t + (state socket) :READ) (raise-usock-err err-code socket))) network-events) (maybe-wsa-error rv socket))))))
- (defun sockets-ready (sockets) - (remove-if-not #'socket-ready-p sockets)) + + + ;; 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))))) + + (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))))) + (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
Modified: usocket/branches/new-wfi/usocket.lisp ============================================================================== --- usocket/branches/new-wfi/usocket.lisp (original) +++ usocket/branches/new-wfi/usocket.lisp Sun Jul 20 14:36:20 2008 @@ -28,7 +28,23 @@ :WRITE - ready to write
The last two remain unused in the current version. -")) +") + #+(and lispworks win32) + (%ready-p + :initform nil + :accessor %ready-p + :documentation "Indicates whether the socket has been signalled +as ready for reading a new connection. + +The value will be set to T by `wait-for-input-internal' (given the +right conditions) and reset to NIL by `socket-accept'. + +Don't modify this slot or depend on it as it is really intended +to be internal only. + +Note: Accessed, but not used for 'stream-usocket'. +" + )) (:documentation "The main socket class.
@@ -58,21 +74,7 @@ #+lispworks 'base-char :reader element-type :documentation "Default element type for streams created by -`socket-accept'.") - #+(and lispworks win32) - (%ready-p - :initform nil - :accessor %ready-p - :documentation "Indicates whether the socket has been signalled -as ready for reading a new connection. - -The value will be set to T by `wait-for-input-internal' (given the -right conditions) and reset to NIL by `socket-accept'. - -Don't modify this slot or depend on it as it is really intended -to be internal only. -" - )) +`socket-accept'.")) (:documentation "Socket which listens for stream connections to be initiated from remote sockets."))