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