[usocket-cvs] r550 - in usocket/trunk: . backend vendor
Chun Tian (binghe)
ctian at common-lisp.net
Tue Jul 20 04:25:43 UTC 2010
Author: ctian
Date: Tue Jul 20 00:25:42 2010
New Revision: 550
Log:
ECL: first working WAIT-FOR-INPUT implementation on win32.
Added:
usocket/trunk/backend/sbcl.obj (contents, props changed)
usocket/trunk/condition.obj (contents, props changed)
usocket/trunk/package.obj (contents, props changed)
usocket/trunk/server.obj (contents, props changed)
usocket/trunk/usocket.obj (contents, props changed)
usocket/trunk/vendor/spawn-thread.obj (contents, props changed)
usocket/trunk/vendor/split-sequence.obj (contents, props changed)
Modified:
usocket/trunk/backend/sbcl.lisp
usocket/trunk/usocket.lisp
Modified: usocket/trunk/backend/sbcl.lisp
==============================================================================
--- usocket/trunk/backend/sbcl.lisp (original)
+++ usocket/trunk/backend/sbcl.lisp Tue Jul 20 00:25:42 2010
@@ -393,14 +393,12 @@
;;; WAIT-FOR-INPUT support for SBCL on Windows platform (Chun Tian (binghe))
;;; Based on LispWorks version written by Erik Huelsmann.
-#+(and sbcl win32)
-(eval-when (:compile-toplevel)
+#+win32 ; shared by ECL and SBCL
+(progn
(defconstant +wsa-wait-failed+ #xffffffff)
(defconstant +wsa-wait-event-0+ 0)
- (defconstant +wsa-wait-timeout+ 258))
+ (defconstant +wsa-wait-timeout+ 258)
-#+(and sbcl win32)
-(progn
(defconstant fd-read 1)
(defconstant fd-read-bit 0)
(defconstant fd-write 2)
@@ -424,6 +422,22 @@
(defconstant fd-max-events 10)
(defconstant fionread 1074030207)
+ ;; Note: for ECL, socket-handle will return raw Windows Handle,
+ ;; while SBCL returns OSF Handle instead.
+ (defun socket-handle (usocket)
+ (sb-bsd-sockets:socket-file-descriptor (socket usocket)))
+
+ (defun socket-ready-p (socket)
+ (if (typep socket 'stream-usocket)
+ (plusp (bytes-available-for-read socket))
+ (%ready-p socket)))
+
+ (defun waiting-required (sockets)
+ (notany #'socket-ready-p sockets))
+) ; progn
+
+#+(and sbcl win32)
+(progn
(sb-alien:define-alien-type ws-socket sb-alien:unsigned-int)
(sb-alien:define-alien-type ws-dword sb-alien:unsigned-long)
(sb-alien:define-alien-type ws-event sb-alien::hinstance)
@@ -482,23 +496,12 @@
(defun os-socket-handle (usocket)
(sockint::fd->handle (sb-bsd-sockets:socket-file-descriptor (socket usocket))))
- (defun socket-handle (usocket)
- (sb-bsd-sockets:socket-file-descriptor (socket usocket)))
-
(defun bytes-available-for-read (socket)
(sb-alien:with-alien ((int-ptr sb-alien:unsigned-long))
(maybe-wsa-error (wsa-ioctlsocket (os-socket-handle socket) fionread (sb-alien:addr int-ptr))
socket)
int-ptr))
- (defun socket-ready-p (socket)
- (if (typep socket 'stream-usocket)
- (plusp (bytes-available-for-read socket))
- (%ready-p socket)))
-
- (defun waiting-required (sockets)
- (notany #'socket-ready-p sockets))
-
(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)
@@ -589,3 +592,87 @@
(defun %remove-waiter (wl w)
(declare (ignore wl w)))
) ; progn
+
+#+(and ecl win32)
+(progn
+ (defun maybe-wsa-error (rv &optional syscall)
+ (unless (zerop rv)
+ (sb-bsd-sockets::socket-error syscall)))
+
+ (defun %setup-wait-list (wl)
+ (setf (wait-list-%wait wl)
+ (ffi:c-inline () () :int
+ "WSAEVENT event;
+ event = WSACreateEvent();
+ @(return) = event;")))
+
+ (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
+ (ffi:c-inline ((socket-handle waiter) (wait-list-%wait wait-list) events)
+ (:fixnum :fixnum :fixnum) :fixnum
+ "int result;
+ result = WSAEventSelect((SOCKET)#0, (WSAEVENT)#1, (long)#2);
+ @(return) = result;")
+ '%add-waiter)))
+
+ (defun %remove-waiter (wait-list waiter)
+ (maybe-wsa-error
+ (ffi:c-inline ((socket-handle waiter) (wait-list-%wait wait-list))
+ (:fixnum :fixnum) :fixnum
+ "int result;
+ result = WSAEventSelect((SOCKET)#0, (WSAEVENT)#1, 0L);
+ @(return) = result;")
+ '%remove-waiter))
+
+ ;; TODO: how to handle error (result) in this call?
+ (defun bytes-available-for-read (socket)
+ (ffi:c-inline ((socket-handle socket)) (:fixnum) :fixnum
+ "u_long nbytes;
+ int result;
+ nbytes = 0L;
+ result = ioctlsocket((SOCKET)#0, FIONREAD, &nbytes);
+ @(return) = nbytes;"))
+
+ (defun update-ready-and-state-slots (sockets)
+ (dolist (socket sockets)
+ (if (or (and (stream-usocket-p socket)
+ (listen (socket-stream socket)))
+ (%ready-p socket))
+ (setf (state socket) :READ)
+ (let ((events (etypecase socket
+ (stream-server-usocket (logior fd-connect fd-accept fd-close))
+ (stream-usocket (logior fd-read))
+ (datagram-usocket (logior fd-read)))))
+ ;; TODO: check the iErrorCode array
+ (if (ffi:c-inline ((socket-handle socket) events) (:fixnum :fixnum) :bool
+ "WSANETWORKEVENTS network_events;
+ int i, result;
+ result = WSAEnumNetworkEvents((SOCKET)#0, 0, &network_events);
+ if (!result) {
+ @(return) = (#1 & network_events.lNetworkEvents)? Ct : Cnil;
+ } else
+ @(return) = Cnil;")
+ (setf (%ready-p socket) t
+ (state socket) :READ)
+ (sb-bsd-sockets::socket-error 'update-ready-and-state-slots))))))
+
+ (defun wait-for-input-internal (wait-list &key timeout)
+ (when (waiting-required (wait-list-waiters wait-list))
+ (let ((rv (ffi:c-inline ((wait-list-%wait wait-list) (truncate (* 1000 timeout)))
+ (:fixnum :fixnum) :fixnum
+ "DWORD result;
+ WSAEVENT events[1];
+ events[0] = (WSAEVENT)#0;
+ result = WSAWaitForMultipleEvents(1, events, NULL, #1, NULL);
+ @(return) = result;")))
+ (ecase rv
+ ((#.+wsa-wait-event-0+ #.+wsa-wait-timeout+)
+ (update-ready-and-state-slots (wait-list-waiters wait-list)))
+ ((#.+wsa-wait-failed+)
+ (sb-bsd-sockets::socket-error 'wait-for-input-internal))))))
+
+) ; progn
Added: usocket/trunk/backend/sbcl.obj
==============================================================================
Binary file. No diff available.
Added: usocket/trunk/condition.obj
==============================================================================
Binary file. No diff available.
Added: usocket/trunk/package.obj
==============================================================================
Binary file. No diff available.
Added: usocket/trunk/server.obj
==============================================================================
Binary file. No diff available.
Modified: usocket/trunk/usocket.lisp
==============================================================================
--- usocket/trunk/usocket.lisp (original)
+++ usocket/trunk/usocket.lisp Tue Jul 20 00:25:42 2010
@@ -35,7 +35,7 @@
The last two remain unused in the current version.
")
- #+(and win32 (or sbcl lispworks))
+ #+(and win32 (or sbcl ecl lispworks))
(%ready-p
:initform nil
:accessor %ready-p
@@ -304,11 +304,11 @@
(values (if ready-only socks socket-or-sockets) to)))))
(let* ((start (get-internal-real-time))
(sockets-ready 0))
+ #-(and win32 (or sbcl ecl))
(dolist (x (wait-list-waiters socket-or-sockets))
(when (setf (state x)
(if (and (stream-usocket-p x)
- (listen (socket-stream x))
- #+(and sbcl win32) nil) ; TODO: bug?!
+ (listen (socket-stream x)))
:READ NIL))
(incf sockets-ready)))
;; the internal routine is responsibe for
Added: usocket/trunk/usocket.obj
==============================================================================
Binary file. No diff available.
Added: usocket/trunk/vendor/spawn-thread.obj
==============================================================================
Binary file. No diff available.
Added: usocket/trunk/vendor/split-sequence.obj
==============================================================================
Binary file. No diff available.
More information about the usocket-cvs
mailing list