Author: ctian Date: Sun Dec 9 02:02:09 2012 New Revision: 701
Log: [ECL] Add WAIT-FOR-INPUT support for ECL DFFI mode.
Modified: usocket/trunk/backend/ecl.lisp usocket/trunk/backend/lispworks.lisp usocket/trunk/backend/sbcl.lisp
Modified: usocket/trunk/backend/ecl.lisp ============================================================================== --- usocket/trunk/backend/ecl.lisp Sat Dec 8 08:35:12 2012 (r700) +++ usocket/trunk/backend/ecl.lisp Sun Dec 9 02:02:09 2012 (r701) @@ -13,75 +13,142 @@
#+(and ecl-bytecmp windows) (progn + (ffi:def-function ("gethostname" c-gethostname) + ((name (* :unsigned-char)) + (len :int)) + :returning :int + :module "ws2_32") + + (defun get-host-name () + "Returns the hostname" + (ffi:with-foreign-object (name '(:array :unsigned-char 256)) + (when (zerop (c-gethostname (ffi:char-array-to-pointer name) 256)) + (ffi:convert-from-foreign-string name)))) + + (ffi:def-foreign-type ws-socket :unsigned-int) + (ffi:def-foreign-type ws-dword :unsigned-long) + (ffi:def-foreign-type ws-event :pointer-void) + + (ffi:def-struct wsa-network-events + (network-events :long) + (error-code (:array :int 10))) + + (ffi:def-function ("WSACreateEvent" wsa-event-create) + () + :returning ws-event + :module "ws2_32") + + (ffi:def-function ("WSACloseEvent" c-wsa-event-close) + ((event-object ws-event)) + :returning :int + :module "ws2_32") + + (defun wsa-event-close (ws-event) + (not (zerop (c-wsa-event-close ws-event)))) + + (ffi:def-function ("WSAEnumNetworkEvents" wsa-enum-network-events) + ((socket ws-socket) + (event-object ws-event) + (network-events (* wsa-network-events))) + :returning :int + :module "ws2_32") + + (ffi:def-function ("WSAEventSelect" wsa-event-select) + ((socket ws-socket) + (event-object ws-event) + (network-events :long)) + :returning :int + :module "ws2_32") + + (ffi:def-function ("WSAWaitForMultipleEvents" c-wsa-wait-for-multiple-events) + ((number-of-events ws-dword) + (events (* ws-event)) + (wait-all-p :int) + (timeout ws-dword) + (alertable-p :int)) + :returning ws-dword + :module "ws2_32") + + (defun wsa-wait-for-multiple-events (number-of-events events wait-all-p timeout alertable-p) + (c-wsa-wait-for-multiple-events number-of-events + events + (if wait-all-p -1 0) + timeout + (if alertable-p -1 0))) + + (ffi:def-function ("ioctlsocket" wsa-ioctlsocket) + ((socket ws-socket) + (cmd :long) + (argp (* :unsigned-long))) + :returning :int + :module "ws2_32") + + (ffi:def-function ("WSAGetLastError" wsa-get-last-error) + () + :returning :int + :module "ws2_32") + + (defun maybe-wsa-error (rv &optional socket) + (unless (zerop rv) + (raise-usock-err (wsa-get-last-error) socket))) + + (defun bytes-available-for-read (socket) + (ffi:with-foreign-object (int-ptr :unsigned-long) + (maybe-wsa-error (wsa-ioctlsocket (socket-handle socket) fionread int-ptr) + socket) + (let ((int (ffi:deref-pointer int-ptr :unsigned-long))) + (prog1 int + (when (plusp int) + (setf (state socket) :read)))))) + + (defun map-network-events (func network-events) + (let ((event-map (ffi:get-slot-value network-events 'network-events)) + (error-array (ffi:get-slot-pointer network-events 'error-code))) + (unless (zerop event-map) + (dotimes (i fd-max-events) + (unless (zerop (ldb (byte 1 i) event-map)) + (funcall func (ffi:deref-array error-array :int i))))))) + + (defun update-ready-and-state-slots (sockets) + (dolist (socket sockets) + (if (%ready-p socket) + (progn + (setf (state socket) :READ)) + (ffi:with-foreign-object (network-events 'wsa-network-events) + (let ((rv (wsa-enum-network-events (socket-handle socket) 0 network-events))) + (if (zerop rv) + (map-network-events + #'(lambda (err-code) + (if (zerop err-code) + (progn + (setf (state socket) :READ) + (when (stream-server-usocket-p socket) + (setf (%ready-p socket) t))) + (raise-usock-err err-code socket))) + network-events) + (maybe-wsa-error rv socket))))))) + + (defun os-wait-list-%wait (wait-list) + (ffi:deref-pointer (wait-list-%wait wait-list) 'ws-event)) + + (defun (setf os-wait-list-%wait) (value wait-list) + (setf (ffi:deref-pointer (wait-list-%wait wait-list) 'ws-event) value)) + + (defun free-wait-list (wl) + (when (wait-list-p wl) + (unless (null (wait-list-%wait wl)) + (wsa-event-close (os-wait-list-%wait wl)) + (ffi:free-foreign-object (wait-list-%wait wl)) + (setf (wait-list-%wait wl) nil)))) + + (defun %setup-wait-list (wait-list) + (setf (wait-list-%wait wait-list) + (ffi:allocate-foreign-object 'ws-event)) + (setf (os-wait-list-%wait wait-list) + (wsa-event-create)) + (ext:set-finalizer wait-list #'free-wait-list))
-(ffi:def-function ("gethostname" c-gethostname) - ((name (* :unsigned-char)) - (len :int)) - :returning :int - :module "ws2_32") - -(defun get-host-name () - "Returns the hostname" - (ffi:with-foreign-object (name '(:array :unsigned-char 256)) - (when (zerop (c-gethostname (ffi:char-array-to-pointer name) 256)) - (ffi:convert-from-foreign-string name)))) - -(ffi:def-foreign-type ws-socket :signed) -(ffi:def-foreign-type ws-dword :unsigned-long) -(ffi:def-foreign-type ws-event :pointer-void) - -(ffi:def-struct wsa-network-events - (network-events :long) - (error-code (:array :int 10))) - -(ffi:def-function ("WSACreateEvent" wsa-event-create) - () - :returning ws-event - :module "ws2_32") - -(ffi:def-function ("WSACloseEvent" c-wsa-event-close) - ((event-object ws-event)) - :returning :int - :module "ws2_32") - -(defun wsa-event-close (ws-event) - (not (zerop (c-wsa-event-close ws-event)))) - -(ffi:def-function ("WSAEnumNetworkEvents" wsa-enum-network-events) - ((socket ws-socket) - (event-object ws-event) - (network-events (* wsa-network-events))) - :returning :int - :module "ws2_32") - -(ffi:def-function ("WSAEventSelect" wsa-event-select) - ((socket ws-socket) - (event-object ws-event) - (network-events :long)) - :returning :int - :module "ws2_32") - -(ffi:def-function ("WSAWaitForMultipleEvents" c-wsa-wait-for-multiple-events) - ((number-of-events ws-dword) - (events (* ws-event)) - (wait-all-p :int) - (timeout ws-dword) - (alertable-p :int)) - :returning ws-dword - :module "ws2_32") - -(defun wsa-wait-for-multiple-events (number-of-events events wait-all-p timeout alertable-p) - (c-wsa-wait-for-multiple-events number-of-events - events - (if wait-all-p -1 0) - timeout - (if alertable-p -1 0))) - -(ffi:def-function ("ioctlsocket" wsa-ioctlsocket) - ((socket ws-socket) - (cmd :long) - (argp (* :unsigned-long))) - :returning :int - :module "ws2_32") + (defun os-socket-handle (usocket) + (socket-handle usocket))
) ; #+(and ecl-bytecmp windows)
Modified: usocket/trunk/backend/lispworks.lisp ============================================================================== --- usocket/trunk/backend/lispworks.lisp Sat Dec 8 08:35:12 2012 (r700) +++ usocket/trunk/backend/lispworks.lisp Sun Dec 9 02:02:09 2012 (r701) @@ -764,7 +764,8 @@ (defun free-wait-list (wl) (when (wait-list-p wl) (unless (null (wait-list-%wait wl)) - (wsa-event-close (wait-list-%wait wl))))) + (wsa-event-close (wait-list-%wait wl)) + (setf (wait-list-%wait wl) nil))))
(eval-when (:load-toplevel :execute) (hcl:add-special-free-action 'free-wait-list))
Modified: usocket/trunk/backend/sbcl.lisp ============================================================================== --- usocket/trunk/backend/sbcl.lisp Sat Dec 8 08:35:12 2012 (r700) +++ usocket/trunk/backend/sbcl.lisp Sun Dec 9 02:02:09 2012 (r701) @@ -525,6 +525,36 @@
(defun waiting-required (sockets) (notany #'socket-ready-p sockets)) + + (defun raise-usock-err (errno &optional socket) + (error 'unknown-error + :socket socket + :real-error errno)) + + (defun wait-for-input-internal (wait-list &key timeout) + (when (waiting-required (wait-list-waiters wait-list)) + (let ((rv (wsa-wait-for-multiple-events 1 (wait-list-%wait wait-list) + nil (truncate (* 1000 timeout)) nil))) + (ecase rv + ((#.+wsa-wait-event-0+) + (update-ready-and-state-slots (wait-list-waiters wait-list))) + ((#.+wsa-wait-timeout+)) ; do nothing here + ((#.+wsa-wait-failed+) + (maybe-wsa-error rv)))))) + + (defun %add-waiter (wait-list waiter) + (let ((events (etypecase waiter + (stream-server-usocket (logior fd-connect fd-accept fd-close)) + (stream-usocket (logior fd-read)) + (datagram-usocket (logior fd-read))))) + (maybe-wsa-error + (wsa-event-select (os-socket-handle waiter) (os-wait-list-%wait wait-list) events) + waiter))) + + (defun %remove-waiter (wait-list waiter) + (maybe-wsa-error + (wsa-event-select (os-socket-handle waiter) (os-wait-list-%wait wait-list) 0) + waiter)) ) ; progn
#+(and sbcl win32) @@ -579,11 +609,6 @@ (cmd sb-alien:long) (argp (* sb-alien:unsigned-long)))
- (defun raise-usock-err (errno socket) - (error 'unknown-error - :socket socket - :real-error errno)) - (defun maybe-wsa-error (rv &optional socket) (unless (zerop rv) (raise-usock-err (sockint::wsa-get-last-error) socket))) @@ -599,19 +624,6 @@ (when (plusp int-ptr) (setf (state socket) :read)))))
- (defun wait-for-input-internal (wait-list &key timeout) - (when (waiting-required (wait-list-waiters wait-list)) - (let ((rv (wsa-wait-for-multiple-events 1 (wait-list-%wait wait-list) - nil (truncate (* 1000 timeout)) nil))) - (ecase rv - ((#.+wsa-wait-event-0+) - (update-ready-and-state-slots (wait-list-waiters wait-list))) - ((#.+wsa-wait-timeout+)) ; do nothing here - ((#.+wsa-wait-failed+) - (raise-usock-err - (sb-win32::get-last-error-message (sb-win32::get-last-error)) - 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))) @@ -674,19 +686,6 @@ (unless (null alien) (sb-alien:free-alien alien))))))
- (defun %add-waiter (wait-list waiter) - (let ((events (etypecase waiter - (stream-server-usocket (logior fd-connect fd-accept fd-close)) - (stream-usocket (logior fd-read)) - (datagram-usocket (logior fd-read))))) - (maybe-wsa-error - (wsa-event-select (os-socket-handle waiter) (os-wait-list-%wait wait-list) events) - waiter))) - - (defun %remove-waiter (wait-list waiter) - (maybe-wsa-error - (wsa-event-select (os-socket-handle waiter) (os-wait-list-%wait wait-list) 0) - waiter)) ) ; progn
#+(and ecl (not win32))