[usocket-cvs] r373 - in usocket/branches/new-wfi: . backend

[ehuelsmann at common-lisp.net]

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