Author: ehuelsmann Date: Tue Jun 5 11:07:58 2007 New Revision: 259
Modified: usocket/trunk/TODO usocket/trunk/backend/allegro.lisp usocket/trunk/backend/armedbear.lisp usocket/trunk/backend/clisp.lisp usocket/trunk/backend/cmucl.lisp usocket/trunk/backend/lispworks.lisp usocket/trunk/backend/openmcl.lisp usocket/trunk/backend/sbcl.lisp Log: Wrap new wait-for-input code in error handling code. Also update TODO.
Modified: usocket/trunk/TODO ============================================================================== --- usocket/trunk/TODO (original) +++ usocket/trunk/TODO Tue Jun 5 11:07:58 2007 @@ -1,4 +1,14 @@
+- Implement wait-for-input-internal for + * SBCL Win32 + * LispWorks Win32 + +- Implement errors for (the alien interface code of) + * SBCL Unix + * CMUCL Unix + * OpenMCL + + - Extend ABCL socket support with the 4 java errors in java.net.* so that they can map to our usocket errors instead of mapping all errors to unknown-error.
Modified: usocket/trunk/backend/allegro.lisp ============================================================================== --- usocket/trunk/backend/allegro.lisp (original) +++ usocket/trunk/backend/allegro.lisp Tue Jun 5 11:07:58 2007 @@ -126,16 +126,17 @@ (host-to-hostname name))))))
(defun wait-for-input-internal (sockets &key timeout) - (let ((active-internal-sockets - (if timeout - (mp:wait-for-input-available (mapcar #'socket sockets) - :timeout timeout) - (mp:wait-for-input-available (mapcar #'socket sockets))))) - ;; this is quadratic, but hey, the active-internal-sockets - ;; list is very short and it's only quadratic in the length of that one. - ;; When I have more time I could recode it to something of linear - ;; complexity. - ;; [Same code is also used in lispworks.lisp, openmcl.lisp] - (remove-if #'(lambda (x) - (not (member (socket x) active-internal-sockets))) - sockets))) + (with-mapped-conditions () + (let ((active-internal-sockets + (if timeout + (mp:wait-for-input-available (mapcar #'socket sockets) + :timeout timeout) + (mp:wait-for-input-available (mapcar #'socket sockets))))) + ;; this is quadratic, but hey, the active-internal-sockets + ;; list is very short and it's only quadratic in the length of that one. + ;; When I have more time I could recode it to something of linear + ;; complexity. + ;; [Same code is also used in lispworks.lisp, openmcl.lisp] + (remove-if #'(lambda (x) + (not (member (socket x) active-internal-sockets))) + sockets))))
Modified: usocket/trunk/backend/armedbear.lisp ============================================================================== --- usocket/trunk/backend/armedbear.lisp (original) +++ usocket/trunk/backend/armedbear.lisp Tue Jun 5 11:07:58 2007 @@ -351,8 +351,7 @@ (selector (jdi:do-jstatic "java.nio.channels.Selector" "open")) (channels (mapcar #'socket sockets))) (unwind-protect -;; (with-mapped-conditions () - (progn + (with-mapped-conditions () (let ((jfalse (java:make-immediate-object nil :boolean)) (sel (jdi:jop-deref selector))) (dolist (channel channels)
Modified: usocket/trunk/backend/clisp.lisp ============================================================================== --- usocket/trunk/backend/clisp.lisp (original) +++ usocket/trunk/backend/clisp.lisp Tue Jun 5 11:07:58 2007 @@ -126,19 +126,20 @@
(defmethod wait-for-input-internal (sockets &key timeout) - (multiple-value-bind - (secs musecs) - (split-timeout (or timeout 1)) - (let* ((request-list (mapcar #'(lambda (x) - (if (stream-server-usocket-p x) - (socket x) - (list (socket x) :input))) - sockets)) - (status-list (if timeout - (socket:socket-status request-list secs musecs) - (socket:socket-status request-list)))) - (remove nil - (mapcar #'(lambda (x y) - (when y x)) - sockets status-list))))) + (with-mapped-conditions () + (multiple-value-bind + (secs musecs) + (split-timeout (or timeout 1)) + (let* ((request-list (mapcar #'(lambda (x) + (if (stream-server-usocket-p x) + (socket x) + (list (socket x) :input))) + sockets)) + (status-list (if timeout + (socket:socket-status request-list secs musecs) + (socket:socket-status request-list)))) + (remove nil + (mapcar #'(lambda (x y) + (when y x)) + sockets status-list))))))
Modified: usocket/trunk/backend/cmucl.lisp ============================================================================== --- usocket/trunk/backend/cmucl.lisp (original) +++ usocket/trunk/backend/cmucl.lisp Tue Jun 5 11:07:58 2007 @@ -164,24 +164,25 @@ (unix:unix-gethostname))
(defun wait-for-input-internal (sockets &key timeout) - (alien:with-alien ((rfds (alien:struct unix:fd-set))) - (unix:fd-zero rfds) - (dolist (socket sockets) - (unix:fd-set (socket socket) rfds)) - (multiple-value-bind - (secs musecs) - (split-timeout (or timeout 1)) + (with-mapped-conditions () + (alien:with-alien ((rfds (alien:struct unix:fd-set))) + (unix:fd-zero rfds) + (dolist (socket sockets) + (unix:fd-set (socket socket) rfds)) (multiple-value-bind - (count err) - (unix:unix-fast-select (1+ (reduce #'max sockets - :key #'socket)) - (alien:addr rfds) nil nil - (when timeout secs) musecs) - (if (<= 0 count) - ;; process the result... - (remove-if #'(lambda (x) - (not (unix:fd-isset (socket x) rfds))) - sockets) - (progn - ;;###FIXME generate an error, except for EINTR - )))))) + (secs musecs) + (split-timeout (or timeout 1)) + (multiple-value-bind + (count err) + (unix:unix-fast-select (1+ (reduce #'max sockets + :key #'socket)) + (alien:addr rfds) nil nil + (when timeout secs) musecs) + (if (<= 0 count) + ;; process the result... + (remove-if #'(lambda (x) + (not (unix:fd-isset (socket x) rfds))) + sockets) + (progn + ;;###FIXME generate an error, except for EINTR + )))))))
Modified: usocket/trunk/backend/lispworks.lisp ============================================================================== --- usocket/trunk/backend/lispworks.lisp (original) +++ usocket/trunk/backend/lispworks.lisp Tue Jun 5 11:07:58 2007 @@ -150,18 +150,17 @@
#-win32 (defun wait-for-input-internal (sockets &key timeout) - ;; unfortunately, it's impossible to share code between - ;; non-win32 and win32 platforms... - ;; Can we have a sane -pref. complete [UDP!?]- API next time, please? - (mapcar #'mp:notice-fd sockets - :key #'os-socket-handle) - (mp:process-wait-with-timeout "Waiting for a socket to become active" - (truncate timeout) - #'(lambda (socks) - (some #'usocket-listen socks)) - sockets) - (mapcar #'mp:unnotice-fd sockets - :key #'os-socket-handle) - (loop for r in (mapcar #'usocket-listen sockets) - if r - collect r)) + (with-mapped-conditions () + ;; unfortunately, it's impossible to share code between + ;; non-win32 and win32 platforms... + ;; Can we have a sane -pref. complete [UDP!?]- API next time, please? + (mapcar #'mp:notice-fd sockets + :key #'os-socket-handle) + (mp:process-wait-with-timeout "Waiting for a socket to become active" + (truncate timeout) + #'(lambda (socks) + (some #'usocket-listen socks)) + sockets) + (mapcar #'mp:unnotice-fd sockets + :key #'os-socket-handle) + (remove nil (mapcar #'usocket-listen sockets))))
Modified: usocket/trunk/backend/openmcl.lisp ============================================================================== --- usocket/trunk/backend/openmcl.lisp (original) +++ usocket/trunk/backend/openmcl.lisp Tue Jun 5 11:07:58 2007 @@ -144,17 +144,18 @@ (host-to-hostname name))))))
(defun wait-for-input-internal (sockets &key timeout) - (let* ((ticks-timeout (truncate (* (or timeout 1) ccl::*ticks-per-second*))) - (active-internal-sockets - (input-available-p (mapcar #'socket sockets) - (when timeout ticks-timeout)))) - ;; this is quadratic, but hey, the active-internal-sockets - ;; list is very short and it's only quadratic in the length of that one. - ;; When I have more time I could recode it to something of linear - ;; complexity. - ;; [Same code is also used in lispworks.lisp, allegro.lisp] - (remove-if #'(lambda (x) - (not (member (socket x) active-internal-sockets))) - sockets))) + (with-mapped-conditions () + (let* ((ticks-timeout (truncate (* (or timeout 1) ccl::*ticks-per-second*))) + (active-internal-sockets + (input-available-p (mapcar #'socket sockets) + (when timeout ticks-timeout)))) + ;; this is quadratic, but hey, the active-internal-sockets + ;; list is very short and it's only quadratic in the length of that one. + ;; When I have more time I could recode it to something of linear + ;; complexity. + ;; [Same code is also used in lispworks.lisp, allegro.lisp] + (remove-if #'(lambda (x) + (not (member (socket x) active-internal-sockets))) + sockets))))
Modified: usocket/trunk/backend/sbcl.lisp ============================================================================== --- usocket/trunk/backend/sbcl.lisp (original) +++ usocket/trunk/backend/sbcl.lisp Tue Jun 5 11:07:58 2007 @@ -254,34 +254,36 @@ (progn #-win32 (defun wait-for-input-internal (sockets &key timeout) - (sb-alien:with-alien ((rfds (sb-alien:struct sb-unix:fd-set))) - (sb-unix:fd-zero rfds) - (dolist (socket sockets) - (sb-unix:fd-set (sb-bsd-sockets:socket-file-descriptor (socket socket)) - rfds)) - (multiple-value-bind - (secs musecs) - (split-timeout (or timeout 1)) - (multiple-value-bind - (count err) - (sb-unix:unix-fast-select - (1+ (reduce #'max (mapcar #'socket sockets) - :key #'sb-bsd-sockets:socket-file-descriptor)) - (sb-alien:addr rfds) nil nil - (when timeout secs) musecs) - (if (<= 0 count) - ;; process the result... - (remove-if - #'(lambda (x) - (not (sb-unix:fd-isset - (sb-bsd-sockets:socket-file-descriptor (socket x)) - rfds))) - sockets) - (progn - (unless (= err sb-unix:EINTR) - (error (map-errno-error err)))) - ;;###FIXME generate an error, except for EINTR - ))))) + (with-mapped-conditions () + (sb-alien:with-alien ((rfds (sb-alien:struct sb-unix:fd-set))) + (sb-unix:fd-zero rfds) + (dolist (socket sockets) + (sb-unix:fd-set + (sb-bsd-sockets:socket-file-descriptor (socket socket)) + rfds)) + (multiple-value-bind + (secs musecs) + (split-timeout (or timeout 1)) + (multiple-value-bind + (count err) + (sb-unix:unix-fast-select + (1+ (reduce #'max (mapcar #'socket sockets) + :key #'sb-bsd-sockets:socket-file-descriptor)) + (sb-alien:addr rfds) nil nil + (when timeout secs) musecs) + (if (<= 0 count) + ;; process the result... + (remove-if + #'(lambda (x) + (not (sb-unix:fd-isset + (sb-bsd-sockets:socket-file-descriptor (socket x)) + rfds))) + sockets) + (progn + (unless (= err sb-unix:EINTR) + (error (map-errno-error err)))) + ;;###FIXME generate an error, except for EINTR + ))))))
#+win32 (warn "wait-for-input not (yet!) supported...") @@ -290,15 +292,17 @@ #+ecl (progn (defun wait-for-input-internal (sockets &key timeout) - (multiple-value-bind - (secs usecs) - (split-timeout (or timeout 1)) - (let* ((sock-fds (mapcar #'sb-bsd-sockets:socket-file-descriptor - (mapcar #'socket sockets))) - (result-fds (read-select sock-fds (when timeout secs) usecs))) - (remove-if #'(lambda (s) - (not (member - (sb-bsd-sockets:socket-file-descriptor (socket s)) - result-fds))) - sockets)))) + (with-mapped-conditions () + (multiple-value-bind + (secs usecs) + (split-timeout (or timeout 1)) + (let* ((sock-fds (mapcar #'sb-bsd-sockets:socket-file-descriptor + (mapcar #'socket sockets))) + (result-fds (read-select sock-fds (when timeout secs) usecs))) + (remove-if #'(lambda (s) + (not + (member + (sb-bsd-sockets:socket-file-descriptor (socket s)) + result-fds))) + sockets))))) )