July 2008 - usocket-cvs@common-lisp.net - mailman3.common-lisp.net

[usocket-cvs] r381 - usocket/branches/new-wfi/backend
by ehuelsmann＠common-lisp.net 23 Jul '08

23 Jul '08

Author: ehuelsmann Date: Wed Jul 23 17:13:51 2008 New Revision: 381 Modified: usocket/branches/new-wfi/backend/armedbear.lisp Log: Increased ABCL W-F-I efficiency. Modified: usocket/branches/new-wfi/backend/armedbear.lisp ============================================================================== --- usocket/branches/new-wfi/backend/armedbear.lisp (original) +++ usocket/branches/new-wfi/backend/armedbear.lisp Wed Jul 23 17:13:51 2008 @@ -88,6 +88,7 @@ (t (java:jclass-name (jop-class instance))))) +(declaim (inline jop-deref)) (defun jop-deref (instance) (if (java-object-proxy-p instance) (jop-value instance) @@ -355,14 +356,13 @@ (channels (mapcar #'socket sockets))) (unwind-protect (with-mapped-conditions () - (let ((jfalse (java:make-immediate-object nil :boolean)) - (sel (jdi:jop-deref selector))) + (let ((sel (jdi:jop-deref selector))) (dolist (channel channels) (let ((chan (jdi:jop-deref channel))) (java:jcall (java:jmethod "java.nio.channels.SelectableChannel" "configureBlocking" "boolean") - chan jfalse) + chan (java:make-immediate-object nil :boolean)) (java:jcall (java:jmethod "java.nio.channels.SelectableChannel" "register" "java.nio.channels.Selector" "int") @@ -387,25 +387,16 @@ (jdi:do-jmethod key "channel")))) (setf (state (gethash chan %wait)) :READ)))))))) - ;; cancel all Selector registrations - (let* ((keys (jdi:do-jmethod selector "keys")) - (iter (jdi:do-jmethod keys "iterator"))) - (loop while (java:jcall (java:jmethod "java.util.Iterator" "hasNext") - (jdi:jop-deref iter)) - do (java:jcall - (java:jmethod "java.nio.channels.SelectionKey" "cancel") - (java:jcall (java:jmethod "java.util.Iterator" "next") - (jdi:jop-deref iter))))) - ;; close the selector + ;; close the selector: all keys will be deregistered (java:jcall (java:jmethod "java.nio.channels.Selector" "close") (jdi:jop-deref selector)) ;; make all sockets blocking again. - (let ((jtrue (java:make-immediate-object t :boolean))) - (dolist (chan channels) - (java:jcall (java:jmethod "java.nio.channels.SelectableChannel" - "configureBlocking" - "boolean") - (jdi:jop-deref chan) jtrue)))))) + (dolist (channel channels) + (java:jcall (java:jmethod "java.nio.channels.SelectableChannel" + "configureBlocking" + "boolean") + (jdi:jop-deref channel) + (java:make-immediate-object t :boolean)))))) ;;

1 0

[usocket-cvs] r380 - usocket/branches/new-wfi/backend
by ehuelsmann＠common-lisp.net 23 Jul '08

23 Jul '08

Author: ehuelsmann Date: Wed Jul 23 16:54:57 2008 New Revision: 380 Modified: usocket/branches/new-wfi/backend/armedbear.lisp Log: Fix ABCL backend. Modified: usocket/branches/new-wfi/backend/armedbear.lisp ============================================================================== --- usocket/branches/new-wfi/backend/armedbear.lisp (original) +++ usocket/branches/new-wfi/backend/armedbear.lisp Wed Jul 23 16:54:57 2008 @@ -196,7 +196,6 @@ (jchan (jdi:do-jstatic-call "java.nio.channels.SocketChannel" "open" sock-addr)) (sock (jdi:do-jmethod-call jchan "socket"))) - (describe sock) (setf usock (make-stream-socket :socket jchan @@ -424,10 +423,10 @@ (defun %setup-wait-list (wl) (setf (wait-list-%wait wl) - (make-hash-table :rehash-size 1.3d0))) + (make-hash-table :test #'equal :rehash-size 1.3d0))) (defun %add-waiter (wl w) - (setf (gethash (socket w) (wait-list-%wait wl)) + (setf (gethash (jdi:jop-deref (socket w)) (wait-list-%wait wl)) w)) (defun %remove-waiter (wl w)

1 0

[usocket-cvs] r379 - in usocket/branches/new-wfi: . backend
by ehuelsmann＠common-lisp.net 22 Jul '08

22 Jul '08

Author: ehuelsmann Date: Tue Jul 22 19:06:15 2008 New Revision: 379 Modified: usocket/branches/new-wfi/BRANCH-README usocket/branches/new-wfi/backend/cmucl.lisp usocket/branches/new-wfi/backend/sbcl.lisp Log: Tackle ECL w-f-i, new style. At the same time, simplify the backend greatly by having less inline C code. Modified: usocket/branches/new-wfi/BRANCH-README ============================================================================== --- usocket/branches/new-wfi/BRANCH-README (original) +++ usocket/branches/new-wfi/BRANCH-README Tue Jul 22 19:06:15 2008 @@ -2,5 +2,4 @@ At least these backends are broken, for now: - - ECL - Scieneer Modified: usocket/branches/new-wfi/backend/cmucl.lisp ============================================================================== --- usocket/branches/new-wfi/backend/cmucl.lisp (original) +++ usocket/branches/new-wfi/backend/cmucl.lisp Tue Jul 22 19:06:15 2008 @@ -166,24 +166,27 @@ (declare (ignore wait-list))) (defun %add-waiter (wait-list waiter) - (declare (ignore wait-list waiter))) + (declare (ignore wait-list waiter)) + (push (socket waiter) (wait-list-%wait wait-list))) (defun %remove-waiter (wait-list waiter) - (declare (ignore wait-list waiter))) + (declare (ignore wait-list waiter)) + (setf (wait-list-%wait wait-list) + (remove (socket waiter) (wait-list-%wait waiter)))) (defun wait-for-input-internal (wait-list &key timeout) (with-mapped-conditions () (alien:with-alien ((rfds (alien:struct unix:fd-set))) (unix:fd-zero rfds) - (dolist (socket (wait-list-waiters wait-list)) - (unix:fd-set (socket socket) rfds)) + (dolist (socket (wait-list-%wait wait-list)) + (unix:fd-set socket rfds)) (multiple-value-bind (secs musecs) (split-timeout (or timeout 1)) (multiple-value-bind (count err) - (unix:unix-fast-select (1+ (reduce #'max (wait-list wait-list) - :key #'socket)) + (unix:unix-fast-select (1+ (reduce #'max + (wait-list-%wait wait-list))) (alien:addr rfds) nil nil (when timeout secs) musecs) (if (<= 0 count) Modified: usocket/branches/new-wfi/backend/sbcl.lisp ============================================================================== --- usocket/branches/new-wfi/backend/sbcl.lisp (original) +++ usocket/branches/new-wfi/backend/sbcl.lisp Tue Jul 22 19:06:15 2008 @@ -64,10 +64,37 @@ (ffi:c-inline () () :fixnum "FD_SETSIZE" :one-liner t)) + (defun fdset-alloc () + (ffi:c-inline () () :pointer-void + "cl_alloc_atomic(sizeof(fd_set))" :one-liner t)) + + (defun fdset-zero (fdset) + (ffi:c-inline (fdset) (:pointer-void) :void + "FD_ZERO((fd_set*)#0)" :one-liner t)) + + (defun fdset-set (fdset fd) + (ffi:c-inline (fdset fd) (:pointer-void :fixnum) :void + "FD_SET(#1,(fd_set*)#0)" :one-liner t)) + + (defun fdset-clr (fdset fd) + (ffi:c-inline (fdset fd) (:pointer-void :fixnum) :void + "FD_CLR(#1,(fd_set*)#0)" :one-liner t)) + + (defun fdset-fd-isset (fdset fd) + (ffi:c-inline (fdset fd) (:pointer-void :fixnum) :bool + "FD_ISSET(#1,(fd_set*)#0)" :one-liner t)) + + (declaim (inline fd-setsize + fdset-alloc + fdset-zero + fdset-set + fdset-clr + fdset-fd-isset)) + (defun get-host-name () (ffi:c-inline () () :object - "{ char *buf = GC_malloc(256); + "{ char *buf = cl_alloc_atomic(257); if (gethostname(buf,256) == 0) @(return) = make_simple_base_string(buf); @@ -75,61 +102,47 @@ @(return) = Cnil; }" :one-liner nil :side-effects nil)) - (defun read-select (read-fds to-secs &optional (to-musecs 0)) - (ffi:c-inline (read-fds to-secs to-musecs) (t t :unsigned-int) t - "{ - fd_set rfds; - cl_object cur_fd = #0; + (defun read-select (wl to-secs &optional (to-musecs 0)) + (let* ((sockets (wait-list-waiters wl)) + (rfds (wait-list-%wait wl)) + (max-fd (reduce #'(lambda (x y) + (let ((sy (sb-bsd-sockets:socket-file-descriptor + (socket y)))) + (if (< x sy) sy x))) + (cdr sockets) + :initial-value (sb-bsd-sockets:socket-file-descriptor + (socket (car sockets)))))) + (fdset-zero rfds) + (dolist (sock sockets) + (fdset-set rfds (sb-bsd-sockets:socket-file-descriptor + (socket sock)))) + (let ((count + (ffi:c-inline (to-secs to-musecs rfds max-fd) + (t :unsigned-int :pointer-void :int) + :int + " int count; - int max_fd = -1; struct timeval tv; - FD_ZERO(&rfds); - while (CONSP(cur_fd)) { - int fd = fixint(cur_fd->cons.car); - max_fd = (max_fd > fd) ? max_fd : fd; - FD_SET(fd, &rfds); - cur_fd = cur_fd->cons.cdr; - } - - if (#1 != Cnil) { - tv.tv_sec = fixnnint(#1); - tv.tv_usec = #2; + if (#0 != Cnil) { + tv.tv_sec = fixnnint(#0); + tv.tv_usec = #1; } - count = select(max_fd + 1, &rfds, NULL, NULL, - (#1 != Cnil) ? &tv : NULL); + @(return) = select(#3 + 1, (fd_set*)#2, NULL, NULL, + (#0 != Cnil) ? &tv : NULL); +"))) + (cond + ((= 0 count) + (values nil nil)) + ((< count 0) + ;; check for EINTR and EAGAIN; these should not err + (values nil (ffi:c-inline () () :int "errno" :one-liner t))) + (t + (dolist (sock sockets) + (when (fdset-fd-isset rfds (sb-bsd-sockets:socket-file-descriptor + (socket sock))) + (setf (state sock) :READ)))))))) - if (count == 0) - @(return 0) = Cnil; - @(return 1) = Cnil; - else if (count < 0) - /*###FIXME: We should be raising an error here... - - except, ofcourse in case of EINTR or EAGAIN */ - - @(return 0) = Cnil; - @(return 1) = MAKE_INTEGER(errno); - else - { - cl_object rv = Cnil; - cur_fd = #0; - - /* when we're going to use the same code on Windows, - as well as unix, we can't be sure it'll fit into - a fixnum: these aren't unix filehandle bitmaps sets on - Windows... */ - - while (CONSP(cur_fd)) { - int fd = fixint(cur_fd->cons.car); - if (FD_ISSET(fd, &rfds)) - rv = CONS(MAKE_INTEGER(fd), rv); - - cur_fd = cur_fd->cons.cdr; - } - @(return 0) = rv; - @(return 1) = Cnil; - } -}")) ) @@ -152,6 +165,7 @@ . operation-not-permitted-error) (sb-bsd-sockets:protocol-not-supported-error . protocol-not-supported-error) + #-ecl (sb-bsd-sockets:unknown-protocol . protocol-not-supported-error) (sb-bsd-sockets:socket-type-not-supported-error @@ -161,6 +175,7 @@ (sb-bsd-sockets:socket-error . ,#'map-socket-error) ;; Nameservice errors: mapped to unknown-error + #-ecl #-ecl #-ecl (sb-bsd-sockets:no-recovery-error . ns-no-recovery-error) (sb-bsd-sockets:try-again-error . ns-try-again-condition) (sb-bsd-sockets:host-not-found-error . ns-host-not-found-error))) @@ -315,23 +330,25 @@ #+ecl (progn - (defun wait-for-input-internal (sockets &key timeout) + (defun wait-for-input-internal (wl &key timeout) (with-mapped-conditions () (multiple-value-bind - (secs usecs) + (secs usecs) (split-timeout (or timeout 1)) - (let* ((sock-fds (mapcar #'sb-bsd-sockets:socket-file-descriptor - (mapcar #'socket sockets)))) - (multiple-value-bind - (result-fds err) - (read-select sock-fds (when timeout secs) usecs) - (if (null err) - (remove-if #'(lambda (s) - (not - (member - (sb-bsd-sockets:socket-file-descriptor - (socket s)) - result-fds))) - sockets) - (error (map-errno-error err)))))))) + (multiple-value-bind + (result-fds err) + (read-select wl (when timeout secs) usecs) + (unless (null err) + (error (map-errno-error err))))))) + + (defun %setup-wait-list (wl) + (setf (wait-list-%wait wl) + (fdset-alloc))) + + (defun %add-waiter (wl w) + (declare (ignore wl w))) + + (defun %remove-waiter (wl w) + (declare (ignore wl w))) + )

1 0

[usocket-cvs] r378 - usocket/branches/new-wfi/backend
by ehuelsmann＠common-lisp.net 22 Jul '08

22 Jul '08

Author: ehuelsmann Date: Tue Jul 22 16:23:17 2008 New Revision: 378 Modified: usocket/branches/new-wfi/backend/armedbear.lisp Log: Make the ABCL backend actually adhere to the new protocol (ie update the STATE slot). Modified: usocket/branches/new-wfi/backend/armedbear.lisp ============================================================================== --- usocket/branches/new-wfi/backend/armedbear.lisp (original) +++ usocket/branches/new-wfi/backend/armedbear.lisp Tue Jul 22 16:23:17 2008 @@ -377,7 +377,7 @@ ;; we actually have work to do (let* ((selkeys (jdi:do-jmethod selector "selectedKeys")) (selkey-iterator (jdi:do-jmethod selkeys "iterator")) - ready-sockets) + (%wait (wait-list-%wait wait-list))) (loop while (java:jcall (java:jmethod "java.util.Iterator" "hasNext") (jdi:jop-deref selkey-iterator)) @@ -386,16 +386,8 @@ "java.nio.channels.SelectionKey")) (chan (jdi:jop-deref (jdi:do-jmethod key "channel")))) - (push chan ready-sockets))) - (remove-if #'(lambda (s) - (not (member (jdi:jop-deref (socket s)) - ready-sockets - :test #'(lambda (x y) - (java:jcall (java:jmethod "java.lang.Object" - "equals" - "java.lang.Object") - x y))))) - sockets)))))) + (setf (state (gethash chan %wait)) + :READ)))))))) ;; cancel all Selector registrations (let* ((keys (jdi:do-jmethod selector "keys")) (iter (jdi:do-jmethod keys "iterator"))) @@ -431,10 +423,12 @@ ;; (defun %setup-wait-list (wl) - (declare (ignore wl))) + (setf (wait-list-%wait wl) + (make-hash-table :rehash-size 1.3d0))) (defun %add-waiter (wl w) - (declare (ignore wl w))) + (setf (gethash (socket w) (wait-list-%wait wl)) + w)) (defun %remove-waiter (wl w) - (declare (ignore wl w))) \ No newline at end of file + (remhash (socket w) (wait-list-%wait wl))) \ No newline at end of file

1 0

[usocket-cvs] r377 - usocket/trunk
by ehuelsmann＠common-lisp.net 22 Jul '08

22 Jul '08

Author: ehuelsmann Date: Tue Jul 22 02:24:21 2008 New Revision: 377 Modified: usocket/trunk/usocket.lisp Log: Fixes compilation issue with recent SBCL. Patch by Chun Tian (binghe.lisp(a)gmail.com) Modified: usocket/trunk/usocket.lisp ============================================================================== --- usocket/trunk/usocket.lisp (original) +++ usocket/trunk/usocket.lisp Tue Jul 22 02:24:21 2008 @@ -63,6 +63,11 @@ (:documentation "Socket which listens for stream connections to be initiated from remote sockets.")) +(defclass datagram-usocket (usocket) + ((connected-p :initarg :connected-p :accessor connected-p)) +;; ###FIXME: documentation to be added. + (:documentation "")) + (defun usocket-p (socket) (typep socket 'usocket)) @@ -75,11 +80,6 @@ (defun datagram-usocket-p (socket) (typep socket 'datagram-usocket)) -(defclass datagram-usocket (usocket) - ((connected-p :initarg :connected-p :accessor connected-p)) -;; ###FIXME: documentation to be added. - (:documentation "")) - (defun make-socket (&key socket) "Create a usocket socket type from implementation specific socket." (unless socket

1 0

[usocket-cvs] r376 - in usocket/branches/new-wfi: . backend
by ehuelsmann＠common-lisp.net 22 Jul '08

22 Jul '08

Author: ehuelsmann Date: Tue Jul 22 02:05:57 2008 New Revision: 376 Modified: usocket/branches/new-wfi/BRANCH-README usocket/branches/new-wfi/backend/armedbear.lisp Log: Update the ABCL backend with new w-f-i. Modified: usocket/branches/new-wfi/BRANCH-README ============================================================================== --- usocket/branches/new-wfi/BRANCH-README (original) +++ usocket/branches/new-wfi/BRANCH-README Tue Jul 22 02:05:57 2008 @@ -2,6 +2,5 @@ At least these backends are broken, for now: - - ABCL - ECL - Scieneer Modified: usocket/branches/new-wfi/backend/armedbear.lisp ============================================================================== --- usocket/branches/new-wfi/backend/armedbear.lisp (original) +++ usocket/branches/new-wfi/backend/armedbear.lisp Tue Jul 22 02:05:57 2008 @@ -349,8 +349,9 @@ ((datagram-usocket-p socket) "java.nio.channels.DatagramChannel"))) -(defun wait-for-input-internal (sockets &key timeout) - (let* ((ops (logior (op-read) (op-accept))) +(defun wait-for-input-internal (wait-list &key timeout) + (let* ((sockets (wait-list-waiters wait-list)) + (ops (logior (op-read) (op-accept))) (selector (jdi:do-jstatic "java.nio.channels.Selector" "open")) (channels (mapcar #'socket sockets))) (unwind-protect @@ -415,3 +416,25 @@ "boolean") (jdi:jop-deref chan) jtrue)))))) + +;; +;; +;; +;; The WAIT-LIST part +;; + +;; +;; Note that even though Java has the concept of the Selector class, which +;; remotely looks like a wait-list, it requires the sockets to be non-blocking. +;; usocket however doesn't make any such guarantees and is therefore unable to +;; use the concept outside of the waiting routine itself (blergh!). +;; + +(defun %setup-wait-list (wl) + (declare (ignore wl))) + +(defun %add-waiter (wl w) + (declare (ignore wl w))) + +(defun %remove-waiter (wl w) + (declare (ignore wl w))) \ No newline at end of file

1 0

[usocket-cvs] r375 - usocket/branches/new-wfi
by ehuelsmann＠common-lisp.net 20 Jul '08

20 Jul '08

Author: ehuelsmann Date: Sun Jul 20 15:22:13 2008 New Revision: 375 Modified: usocket/branches/new-wfi/BRANCH-README Log: Update BRANCH-README with the factual state of affairs. Modified: usocket/branches/new-wfi/BRANCH-README ============================================================================== --- usocket/branches/new-wfi/BRANCH-README (original) +++ usocket/branches/new-wfi/BRANCH-README Sun Jul 20 15:22:13 2008 @@ -3,5 +3,5 @@ At least these backends are broken, for now: - ABCL - - SBCL/ ECL + - ECL - Scieneer

1 0

[usocket-cvs] r374 - usocket/branches/new-wfi/backend
by ehuelsmann＠common-lisp.net 20 Jul '08

20 Jul '08

Author: ehuelsmann Date: Sun Jul 20 15:21:29 2008 New Revision: 374 Modified: usocket/branches/new-wfi/backend/sbcl.lisp Log: Remove obsolete comment. Modified: usocket/branches/new-wfi/backend/sbcl.lisp ============================================================================== --- usocket/branches/new-wfi/backend/sbcl.lisp (original) +++ usocket/branches/new-wfi/backend/sbcl.lisp Sun Jul 20 15:21:29 2008 @@ -275,7 +275,6 @@ (push (socket waiter) (wait-list-%wait wait-list))) (defun %remove-waiter (wait-list waiter) - ;;;### not removing from the waiters list?! (setf (wait-list-%wait wait-list) (remove (socket waiter) (wait-list-%wait wait-list))))

1 0

[usocket-cvs] r373 - in usocket/branches/new-wfi: . backend
by ehuelsmann＠common-lisp.net 20 Jul '08

20 Jul '08

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."))

1 0

[usocket-cvs] r372 - usocket/branches/new-wfi
by ehuelsmann＠common-lisp.net 20 Jul '08

20 Jul '08

Author: ehuelsmann Date: Sun Jul 20 13:52:23 2008 New Revision: 372 Modified: usocket/branches/new-wfi/usocket.lisp Log: Fix 'old-style' calling convention. Modified: usocket/branches/new-wfi/usocket.lisp ============================================================================== --- usocket/branches/new-wfi/usocket.lisp (original) +++ usocket/branches/new-wfi/usocket.lisp Sun Jul 20 13:52:23 2008 @@ -266,8 +266,7 @@ none." (unless (wait-list-p socket-or-sockets) (let ((wl (make-wait-list (if (listp socket-or-sockets) - socket-or-sockets (list socket-or-sockets)) - nil))) + socket-or-sockets (list socket-or-sockets))))) (multiple-value-bind (socks to) (wait-for-input wl :timeout timeout :ready-only ready-only)

1 0