From ehuelsmann at common-lisp.net  Thu Jul  3 21:29:45 2008
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Thu,  3 Jul 2008 17:29:45 -0400 (EDT)
Subject: [usocket-cvs] r360 - usocket/branches/new-wfi
Message-ID: <20080703212945.42FB5340BB@common-lisp.net>

Author: ehuelsmann
Date: Thu Jul  3 17:29:44 2008
New Revision: 360

Modified:
   usocket/branches/new-wfi/usocket.lisp
Log:
Fix new-wfi code (generic part).

Modified: usocket/branches/new-wfi/usocket.lisp
==============================================================================
--- usocket/branches/new-wfi/usocket.lisp	(original)
+++ usocket/branches/new-wfi/usocket.lisp	Thu Jul  3 17:29:44 2008
@@ -275,7 +275,7 @@
           (values (if ready-only socks socket-or-sockets) to)))))
   (let* ((start (get-internal-real-time))
          (sockets-ready 0))
-    (dolist (x (wait-list-waiters sockets))
+    (dolist (x (wait-list-waiters socket-or-sockets))
       (when (setf (state x)
                   (if (and (stream-usocket-p x)
                            (listen (socket-stream x)))


From ehuelsmann at common-lisp.net  Thu Jul  3 22:33:38 2008
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Thu,  3 Jul 2008 18:33:38 -0400 (EDT)
Subject: [usocket-cvs] r361 - usocket/branches/new-wfi/backend
Message-ID: <20080703223338.649D85D286@common-lisp.net>

Author: ehuelsmann
Date: Thu Jul  3 18:33:36 2008
New Revision: 361

Modified:
   usocket/branches/new-wfi/backend/sbcl.lisp
Log:
Fix SBCL backend (non Win32).

Modified: usocket/branches/new-wfi/backend/sbcl.lisp
==============================================================================
--- usocket/branches/new-wfi/backend/sbcl.lisp	(original)
+++ usocket/branches/new-wfi/backend/sbcl.lisp	Thu Jul  3 18:33:36 2008
@@ -268,13 +268,26 @@
 #+sbcl
 (progn
   #-win32
+(defun %setup-wait-list (wait-list)
+  (declare (ignore wait-list)))
+
+(defun %add-waiter (wait-list waiter)
+  (push (socket waiter) (wait-list-%wait wait-list)))
+
+(defun %remove-waiter (wait-list waiter)
+  ;;;### not removing from the waiters list?!
+  (setf (wait-list-%wait wait-list)
+        (remove (socket waiter) (wait-list-%wait wait-list))))
+
+
+
   (defun wait-for-input-internal (sockets &key timeout)
     (with-mapped-conditions ()
       (sb-alien:with-alien ((rfds (sb-alien:struct sb-unix:fd-set)))
          (sb-unix:fd-zero rfds)
-         (dolist (socket sockets)
+         (dolist (socket (wait-list-%wait sockets))
            (sb-unix:fd-set
-            (sb-bsd-sockets:socket-file-descriptor (socket socket))
+            (sb-bsd-sockets:socket-file-descriptor socket)
             rfds))
          (multiple-value-bind
              (secs musecs)
@@ -282,7 +295,7 @@
            (multiple-value-bind
                (count err)
                (sb-unix:unix-fast-select
-                (1+ (reduce #'max (mapcar #'socket sockets)
+                (1+ (reduce #'max (mapcar #'socket (wait-list-waiters sockets))
                             :key #'sb-bsd-sockets:socket-file-descriptor))
                 (sb-alien:addr rfds) nil nil
                 (when timeout secs) musecs)
@@ -291,12 +304,11 @@
 		   (error (map-errno-error err)))
 		 (when (< 0 count)
 		   ;; process the result...
-		   (remove-if
-		    #'(lambda (x)
-			(not (sb-unix:fd-isset
-			      (sb-bsd-sockets:socket-file-descriptor (socket x))
-			      rfds)))
-		    sockets))))))))
+                   (dolist (x (wait-list-waiters sockets))
+                     (when (not (sb-unix:fd-isset
+                                 (sb-bsd-sockets:socket-file-descriptor (socket x))
+                                 rfds))
+                       (setf (state x) :READ))))))))))
 
   #+win32
   (warn "wait-for-input not (yet!) supported...")


From ehuelsmann at common-lisp.net  Fri Jul  4 23:19:20 2008
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Fri,  4 Jul 2008 19:19:20 -0400 (EDT)
Subject: [usocket-cvs] r362 - usocket/branches/new-wfi/backend
Message-ID: <20080704231920.C14A8690E2@common-lisp.net>

Author: ehuelsmann
Date: Fri Jul  4 19:19:05 2008
New Revision: 362

Modified:
   usocket/branches/new-wfi/backend/clisp.lisp
Log:
Fix CLISP backend.

Modified: usocket/branches/new-wfi/backend/clisp.lisp
==============================================================================
--- usocket/branches/new-wfi/backend/clisp.lisp	(original)
+++ usocket/branches/new-wfi/backend/clisp.lisp	Fri Jul  4 19:19:05 2008
@@ -144,14 +144,15 @@
         (split-timeout (or timeout 1))
       (dolist (x (wait-list-%wait wait-list))
         (setf (cdr x) :INPUT))
-      (let* ((status-list (if timeout
+      (let* ((request-list (wait-list-%wait wait-list))
+             (status-list (if timeout
                               (socket:socket-status request-list secs musecs)
                             (socket:socket-status request-list)))
              (sockets (wait-list-waiters wait-list)))
         (do* ((x (pop sockets) (pop sockets))
               (y (pop status-list) (pop status-list)))
-             ((or (null sockets) (null status-list)))
-          (when y
+             ((null x))
+          (when (eq y :INPUT)
             (setf (state x) :READ)))
         wait-list))))
 


From ehuelsmann at common-lisp.net  Sun Jul 13 11:05:41 2008
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Sun, 13 Jul 2008 07:05:41 -0400 (EDT)
Subject: [usocket-cvs] r363 - usocket/trunk/backend
Message-ID: <20080713110541.61A61662D7@common-lisp.net>

Author: ehuelsmann
Date: Sun Jul 13 07:05:40 2008
New Revision: 363

Modified:
   usocket/trunk/backend/sbcl.lisp
Log:
Commit change to trunk which should have been there all the time, but got committed to the 0.3.x branch only, for some reason.

Modified: usocket/trunk/backend/sbcl.lisp
==============================================================================
--- usocket/trunk/backend/sbcl.lisp	(original)
+++ usocket/trunk/backend/sbcl.lisp	Sun Jul 13 07:05:40 2008
@@ -67,7 +67,7 @@
   (defun get-host-name ()
     (ffi:c-inline
      () () :object
-     "{ char *buf = GC_malloc(256);
+     "{ char *buf = cl_alloc_atomic(257);
 
         if (gethostname(buf,256) == 0)
           @(return) = make_simple_base_string(buf);


From ehuelsmann at common-lisp.net  Sun Jul 13 18:16:20 2008
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Sun, 13 Jul 2008 14:16:20 -0400 (EDT)
Subject: [usocket-cvs] r364 - trivial-sockets
Message-ID: <20080713181620.3504B46181@common-lisp.net>

Author: ehuelsmann
Date: Sun Jul 13 14:16:19 2008
New Revision: 364

Added:
   trivial-sockets/
   trivial-sockets/README
   trivial-sockets/abcl.lisp
   trivial-sockets/allegro.lisp
   trivial-sockets/clisp.lisp
   trivial-sockets/cmucl.lisp
   trivial-sockets/defpackage.lisp
   trivial-sockets/errors.lisp
   trivial-sockets/lispworks.lisp
   trivial-sockets/openmcl.lisp
   trivial-sockets/sbcl.lisp
   trivial-sockets/server.lisp
   trivial-sockets/trivial-sockets.asd
   trivial-sockets/trivial-sockets.texi
Log:
Trivial sockets imported as gotten from the clbuild project mirror.

Added: trivial-sockets/README
==============================================================================
--- (empty file)
+++ trivial-sockets/README	Sun Jul 13 14:16:19 2008
@@ -0,0 +1,58 @@
+Trivial-sockets: 
+  server and client stream sockets for undemanding network applications
+
+Usage examples:
+
+(with-open-stream (s (trivial-sockets:open-stream "www.google.com" 80)) 
+  (format s "HEAD / HTTP/1.0~%Host: www.google.com~%~%") 
+  (force-output s) 
+  (loop 
+    (let ((l (read-line s nil nil))) 
+      (unless l (return)) 
+      (princ l) (terpri))))
+
+(trivial-sockets:with-server (s (:port 8913 :reuse-address t))
+   (loop
+    (with-open-stream (c (trivial-sockets:accept-connection s)) 
+        (read-line c)
+        (format c "Hi there!~%"))))
+
+
+Proper documentation is in trivial-sockets.texi.  If you have Texinfo
+installed you can convert this to DVI or PDF using texi2dvi or
+texi2pdf, or use makeinfo to create an Info file for use with Emacs or
+the standalone info reader.
+
+
+Installation:
+
+Use asdf-install.  
+
+  * (asdf:operate 'asdf:load-op 'asdf-install)
+  * (asdf-install:install 'trivial-sockets)
+
+Or if you don't have asdf-install but you do have asdf, create a
+symlink from a directory in your asdf:*central-registry* and run
+
+  * (asdf:operate 'asdf:load-op 'trivial-sockets)
+
+Or if you don't have asdf, either (a) get it, or (b) compile the files by
+hand in an order that satisfies the dependencies in trivial-sockets.asd
+
+
+References:
+
+http://www.cliki.net/asdf-install
+http://www.cliki.net/asdf
+
+
+Thanks to: (alphabetical order)
+
+- Andras Simon for Armed Bear CL support
+- Edi Weitz, by whose asdf-install work some of the code was inspired
+- Oliver Markovic, for OpenMCL support
+- Rudi Schlatte, for a ton of stuff including OpenMCL and CMUCL server 
+  support, work on the manual, and also the Stevens justification I 
+  needed to make SO_REUSEADDR default 
+- Sven Van Caekenberghe provided Lispworks support
+

Added: trivial-sockets/abcl.lisp
==============================================================================
--- (empty file)
+++ trivial-sockets/abcl.lisp	Sun Jul 13 14:16:19 2008
@@ -0,0 +1,60 @@
+
+(in-package :trivial-sockets)
+
+(defun resolve-hostname (name)
+  (cond
+   ((eql name :any) "0.0.0.0")
+   ((typep name '(vector * 4)) (format nil "~{~A~^.~}" (coerce name 'list)))
+   (t name)))
+
+(defun open-stream (peer-host peer-port
+                              &key (local-host :any) (local-port 0)
+                              (external-format :default)
+                              (element-type 'character)
+                              (protocol :tcp))
+  (unless (and (eql local-host :any) (eql local-port 0))
+    (error 'unsupported :feature :bind))
+  (unless (eql protocol :tcp)
+    (error 'unsupported :feature `(:protocol ,protocol)))
+  (unless (eql external-format :default)
+    (error 'unsupported :feature :external-format))
+  (handler-bind ((error (lambda (c) (error 'socket-error :nested-error c))))
+                (ext:get-socket-stream
+                 (ext:make-socket (resolve-hostname peer-host) peer-port)
+                 :element-type element-type)))
+
+
+(defun open-server (&key (host :any) (port 0)
+                         (reuse-address t)
+                         (backlog 50)
+                         (protocol :tcp))
+  "Returns a SERVER object and the port that was bound, as multiple values"
+  (unless (eql protocol :tcp)
+    (error 'unsupported :feature `(:protocol ,protocol)))
+  (unless (equal (resolve-hostname host) "0.0.0.0")
+    (error 'unsupported :feature :bind))
+  (unless (= backlog 50)
+    ;; the default, as of jdk 1.4.2
+    (error 'unsupported :feature :backlog))
+  (handler-bind ((error (lambda (c) (error 'socket-error :nested-error c))))
+    (let ((sock (ext:make-server-socket port)))
+      (java:jcall (java:jmethod "java.net.ServerSocket" "setReuseAddress" "boolean")
+		  sock
+		  (java:make-immediate-object reuse-address :boolean))
+      (values sock
+	      (java:jcall (java:jmethod "java.net.ServerSocket" "getLocalPort")
+			  sock)))))
+
+(defun close-server (server)
+  (ext:server-socket-close server))
+
+(defun accept-connection (socket
+                          &key
+                          (external-format :default)
+                          (element-type 'character))
+  (unless (eql external-format :default)
+    (error 'unsupported :feature :external-format))
+  (handler-bind ((error (lambda (c) (error 'socket-error :nested-error c))))
+    (ext:get-socket-stream (ext:socket-accept socket)
+			   :element-type element-type)))
+

Added: trivial-sockets/allegro.lisp
==============================================================================
--- (empty file)
+++ trivial-sockets/allegro.lisp	Sun Jul 13 14:16:19 2008
@@ -0,0 +1,60 @@
+(in-package :trivial-sockets)
+
+(defun resolve-hostname (name)
+  (cond
+   ((eql name :any) "0.0.0.0")
+   ((typep name '(vector * 4)) (format nil "~{~A~^.~}" (coerce name 'list)))
+   (t name)))
+
+(defun open-stream (peer-host peer-port 
+			      &key (local-host :any) (local-port 0)
+			      (external-format :default)
+			      (element-type 'character)
+			      (protocol :tcp))
+  (declare (ignore element-type))
+  (unless (eql protocol :tcp)
+    (error 'unsupported :feature `(:protocol ,protocol)))
+  (unless (eql external-format :default)
+    (error 'unsupported :feature :external-format))
+  (handler-bind ((error (lambda (c) (error 'socket-error :nested-error c))))
+    (socket:make-socket :address-family :internet
+			:connect :active
+			:type :stream
+			:remote-host (resolve-hostname peer-host)
+			:remote-port peer-port
+			:local-host (resolve-hostname local-host)
+			:local-port local-port)))
+			      
+			      
+(defun open-server (&key (host :any) (port 0)
+			 (reuse-address t)
+			 (backlog 1)
+			 (protocol :tcp))
+  "Returns a SERVER object and the port that was bound, as multiple values"
+  (unless (eql protocol :tcp)
+    (error 'unsupported :feature `(:protocol ,protocol)))
+  (handler-bind ((error
+                  (lambda (c) (error 'socket-error :nested-error c))))
+    (let* ((host (if (eql host :any) nil host))
+           (socket (socket:make-socket :address-family :internet
+				       :type :stream
+				       :connect :passive
+				       :local-host host
+				       :local-port port
+				       :reuse-address reuse-address
+				       :backlog backlog)))
+      (values socket (socket:local-port socket)))))
+
+(defun close-server (server)
+  (close server))
+
+(defun accept-connection (socket
+			  &key
+			  (external-format :default)
+			  (element-type 'character))
+  (declare (ignore element-type))      ; bivalent streams
+  (unless (eql external-format :default)
+    (error 'unsupported :feature :external-format))
+  (handler-bind ((error
+                  (lambda (c) (error 'socket-error :nested-error c))))
+    (socket:accept-connection socket :wait t)))

Added: trivial-sockets/clisp.lisp
==============================================================================
--- (empty file)
+++ trivial-sockets/clisp.lisp	Sun Jul 13 14:16:19 2008
@@ -0,0 +1,56 @@
+(in-package :trivial-sockets)
+
+(defun resolve-hostname (name)
+  (cond
+   ((eql name :any) "0.0.0.0")
+   ((typep name '(vector * 4)) (format nil "~{~A~^.~}" (coerce name 'list)))
+   (t name)))
+
+(defun open-stream (peer-host peer-port 
+			      &key (local-host :any) (local-port 0)
+			      (external-format :default)
+			      (element-type 'character)
+			      (protocol :tcp))
+  (unless (and (eql local-host :any) (eql local-port 0))
+    (error 'unsupported :feature :bind))
+  (unless (eql protocol :tcp)
+    (error 'unsupported :feature `(:protocol ,protocol)))
+  ;; FIXME I wish there were a smarter way to detect only the errors 
+  ;; we're interested in, but CLISP impnotes don't say what to look for
+  (handler-bind ((error (lambda (c) (error 'socket-error :nested-error c))))
+    (socket:socket-connect peer-port (resolve-hostname peer-host)
+			   :element-type element-type
+			   :external-format external-format
+			   :buffered nil
+			   )))
+
+
+(defun open-server (&key (host :any) (port 0)
+			 (reuse-address t)
+			 (backlog 1)
+			 (protocol :tcp))
+  (unless (eql protocol :tcp)
+    (error 'unsupported :feature `(:protocol ,protocol)))
+  (unless (equal (resolve-hostname host) "0.0.0.0")
+    (error 'unsupported :feature :bind))
+  (unless (= backlog 1)
+    ;; we established that the default backlog is 1 by stracing clisp
+    ;; 2.33.2 (2004-06-02) (built 3304881526)
+    (error 'unsupported :feature :backlog))
+  (unless reuse-address
+    (error 'unsupported :feature :nil-reuse-address))
+  (handler-bind ((error (lambda (c) (error 'socket-error :nested-error c))))
+    (let ((s (socket:socket-server port)))
+      (values s (socket:socket-server-port s)))))
+    
+(defun close-server (server)
+  (socket:socket-server-close server))
+
+(defun accept-connection (socket
+			  &key
+			  (external-format :default)
+			  (element-type 'character))
+  (handler-bind ((error (lambda (c) (error 'socket-error :nested-error c))))
+    (socket:socket-accept socket :external-format external-format
+			  :element-type element-type
+			  :buffered nil)))

Added: trivial-sockets/cmucl.lisp
==============================================================================
--- (empty file)
+++ trivial-sockets/cmucl.lisp	Sun Jul 13 14:16:19 2008
@@ -0,0 +1,72 @@
+(in-package :trivial-sockets)
+
+(defun resolve-hostname (name)
+  (cond
+   ((eql name :any) "0.0.0.0")
+   ((typep name '(vector * 4)) (format nil "~{~A~^.~}" (coerce name 'list)))
+   (t name)))
+
+(defun pretty-stream-name (host port)
+  (format nil "~A:~A" (resolve-hostname host) port))
+
+(defun open-stream (peer-host peer-port 
+			      &key (local-host :any) (local-port 0)
+			      (external-format :default)
+			      (element-type 'character)
+			      (protocol :tcp))
+  (unless (eql external-format :default)
+    (error 'unsupported :feature :external-format))
+  (unless (and (eql local-host :any) (eql local-port 0))
+    (error 'unsupported :feature :bind))
+  (unless (eql protocol :tcp)
+    (error 'unsupported :feature `(:protocol ,protocol)))
+  ;; connect-to-inet-socket signals simple-erors.  not great
+  (handler-bind ((error (lambda (c) (error 'socket-error :nested-error c))))
+    (let ((s (ext:connect-to-inet-socket
+              (resolve-hostname peer-host) peer-port)))
+      (sys:make-fd-stream s :input t :output t :element-type element-type
+			  :buffering :full
+                          :name (pretty-stream-name peer-host peer-port)))))
+
+(defun open-server (&key (host :any) (port 0)
+                    (reuse-address t)
+                    (backlog 1)
+                    (protocol :tcp))
+  "Returns a SERVER object and the port that was bound, as multiple values"
+  (unless (eql protocol :tcp)
+    (error 'unsupported :feature `(:protocol ,protocol)))
+  (handler-bind ((error (lambda (c) (error 'socket-error :nested-error c))))
+    (let ((socket (if (equal (resolve-hostname host) "0.0.0.0")
+                      ;; create-inet-listener barfs on `:host nil'
+                      (ext:create-inet-listener port :stream
+                                                :reuse-address reuse-address
+                                                :backlog backlog)
+                      (ext:create-inet-listener port :stream
+                                                :reuse-address reuse-address
+                                                :backlog backlog
+                                                :host host))))
+      (multiple-value-bind (host port)
+          (ext:get-socket-host-and-port socket)
+        (declare (ignore host))
+        (values socket port)))))
+			      
+(defun close-server (server)
+  (unix:unix-close server))
+
+(defun accept-connection (socket
+			  &key
+			  (external-format :default)
+			  (element-type 'character))
+  (unless (eql external-format :default)
+    (error 'unsupported :feature :external-format))
+  (handler-bind ((error (lambda (c) (error 'socket-error :nested-error c))))
+    (let ((fd (ext:accept-tcp-connection socket)))
+    (multiple-value-bind (peer-host peer-port)
+        (ext:get-peer-host-and-port fd)
+      (sys:make-fd-stream fd
+                          :input t :output t
+                          :element-type element-type
+                          :auto-close t
+                          :buffering :full
+                          :name (pretty-stream-name peer-host peer-port))))))
+

Added: trivial-sockets/defpackage.lisp
==============================================================================
--- (empty file)
+++ trivial-sockets/defpackage.lisp	Sun Jul 13 14:16:19 2008
@@ -0,0 +1,8 @@
+(in-package :cl-user)
+(defpackage trivial-sockets
+  (:use :CL)
+  (:export #:open-stream #:socket-error #:socket-nested-error
+	   #:unsupported #:unsupported-feature
+	   #:open-server #:close-server #:accept-connection
+	   #:with-server))
+

Added: trivial-sockets/errors.lisp
==============================================================================
--- (empty file)
+++ trivial-sockets/errors.lisp	Sun Jul 13 14:16:19 2008
@@ -0,0 +1,11 @@
+(in-package :trivial-sockets)
+
+;; you're using a part of the interface that the implementation doesn't do
+(define-condition unsupported (error) 
+  ((feature :initarg :feature :reader unsupported-feature)))
+
+;; all-purpose error: host not found, host not responding,
+;; no service on that port, etc
+(define-condition socket-error (error)
+  ((nested-error :initarg :nested-error :reader socket-nested-error)))
+

Added: trivial-sockets/lispworks.lisp
==============================================================================
--- (empty file)
+++ trivial-sockets/lispworks.lisp	Sun Jul 13 14:16:19 2008
@@ -0,0 +1,114 @@
+(in-package :trivial-sockets)
+
+(defun resolve-hostname (name)
+  (cond
+   ((eql name :any) "0.0.0.0")
+   ((typep name '(vector * 4)) (format nil "~{~A~^.~}" (coerce name 'list)))
+   (t name)))
+
+(defun open-stream (peer-host peer-port 
+			      &key (local-host :any) (local-port 0)
+			      (external-format :default)
+			      (element-type 'base-char)
+			      (protocol :tcp))
+  (unless (eql protocol :tcp)
+    (error 'unsupported :feature `(:protocol ,protocol)))
+  (unless (eql external-format :default)
+    (error 'unsupported :feature `(:external-format ,external-format)))
+  (unless (eql local-host :any)
+    (error 'unsupported :feature `(:local-host ,local-host)))
+  (unless (eql local-port 0)
+    (error 'unsupported :feature `(:local-port ,local-port)))
+  (handler-bind ((error (lambda (c) (error 'socket-error :nested-error c))))
+    (comm:open-tcp-stream (resolve-hostname peer-host)
+                          peer-port
+                          :element-type element-type
+                          :errorp t)))
+		
+;; there is no (published) way to make a server socket in lispworks
+;; this server implementation is a hack around the otherwise elegant
+;; lispworks #'comm:start-up-server functionality
+
+(defun make-queue ()
+  (cons nil nil))
+
+(defun queue-empty-p (queue)
+  (null (car queue)))
+
+(defun enqueue (x queue)
+  (if (null (car queue))
+      (setf (cdr queue) (setf (car queue) (list x)))
+    (setf (cdr (cdr queue)) (list x)
+          (cdr queue) (cdr (cdr queue))))
+  (car queue))
+
+(defun dequeue (queue)
+  (pop (car queue)))
+
+(defclass server ()
+  ((process :reader get-process)
+   (lock :initform (mp:make-lock))
+   (clients :initform (make-queue))))
+
+(defun open-server (&key (host :any) (port 0)
+                         (reuse-address t)
+                         (backlog 5)
+                         (protocol :tcp))
+  "Returns a SERVER object and the port that was bound, as multiple values"
+  (unless (eql host :any) 
+    ;; not in the manual, appears in arglist, maybe not on all platforms
+    (error 'unsupported :feature `(:host ,host)))
+  (unless (eql protocol :tcp)
+    (error 'unsupported :feature `(:protocol ,protocol)))
+  (unless (eql backlog 5)
+    ;; not in the manual, appears in arglist, maybe not on all platforms
+    (error 'unsupported :feature `(:backlog ,backlog)))
+  (let ((server (make-instance 'server)))
+    (with-slots (process lock clients) 
+        server
+      (multiple-value-bind (new-process condition)
+          ;; we enqueue all incoming connections until #'accept-connection retrieves them
+	  (let ((comm::*use_so_reuseaddr* reuse-address))
+	    (comm:start-up-server :function #'(lambda (socket)
+						(mp:with-lock (lock)
+							      (enqueue socket clients)))
+				  :service port
+				  :wait t))
+        (when condition
+          (error 'socket-error :nested-error condition))
+        (setf process new-process)))
+    (values server port))) ;; we do not return the actual port when port was 0
+
+(defun close-server (server)
+  (with-slots (process)
+      server
+    (mp:process-kill process)
+    (setf process nil)))
+
+(defun accept-connection (server
+                          &key
+                          (external-format :default)
+                          (element-type 'base-char))
+  (unless (eql external-format :default)
+    (error 'unsupported :feature `(:external-format, external-format)))
+  (let (client-socket)
+    (with-slots (process lock clients)
+        server
+      (unless process 
+        (error 'socket-error :nested-error (make-instance 'simple-error :format-string "Server closed"))) 
+      (loop 
+       (mp:with-lock (lock)
+         (unless (queue-empty-p clients)
+           (setf client-socket (dequeue clients))
+           (return)))
+       (mp:process-wait "Waiting for incoming connections" 
+                        #'(lambda (server)
+                            (with-slots (lock clients)
+                                server
+                              (mp:with-lock (lock)
+                                (not (queue-empty-p clients)))))
+                        server)))
+    (make-instance 'comm:socket-stream
+                   :socket client-socket
+                   :direction :io
+                   :element-type element-type)))

Added: trivial-sockets/openmcl.lisp
==============================================================================
--- (empty file)
+++ trivial-sockets/openmcl.lisp	Sun Jul 13 14:16:19 2008
@@ -0,0 +1,60 @@
+(in-package :trivial-sockets)
+
+(defun resolve-hostname (name)
+  (cond
+   ((eql name :any) "0.0.0.0")
+   ((typep name '(vector * 4)) (format nil "~{~A~^.~}" (coerce name 'list)))
+   (t name)))
+
+(defun open-stream (peer-host peer-port 
+			      &key (local-host :any) (local-port 0)
+			      (external-format :default)
+			      (element-type 'character)
+			      (protocol :tcp))
+  (declare (ignore element-type))
+  (unless (eql protocol :tcp)
+    (error 'unsupported :feature `(:protocol ,protocol)))
+  (unless (eql external-format :default)
+    (error 'unsupported :feature :external-format))
+  (handler-bind ((ccl::socket-creation-error
+                  (lambda (c) (error 'socket-error :nested-error c))))
+    (ccl:make-socket :address-family :internet
+		     :connect :active
+		     :type :stream
+		     :remote-host (resolve-hostname peer-host)
+		     :remote-port peer-port
+		     :local-host (resolve-hostname local-host)
+		     :local-port local-port)))
+			      
+(defun open-server (&key (host :any) (port 0)
+			 (reuse-address t)
+			 (backlog 1)
+			 (protocol :tcp))
+  "Returns a SERVER object and the port that was bound, as multiple values"
+  (unless (eql protocol :tcp)
+    (error 'unsupported :feature `(:protocol ,protocol)))
+  (handler-bind ((ccl::socket-creation-error
+                  (lambda (c) (error 'socket-error :nested-error c))))
+    (let* ((host (if (eql host :any) nil host))
+           (socket (ccl:make-socket :address-family :internet
+                                    :type :stream
+                                    :connect :passive
+                                    :local-host host
+                                    :local-port port
+                                    :reuse-address reuse-address
+                                    :backlog backlog)))
+      (values socket (ccl:local-port socket)))))
+
+(defun close-server (server)
+  (close server))
+
+(defun accept-connection (socket
+			  &key
+			  (external-format :default)
+			  (element-type 'character))
+  (declare (ignore element-type))      ; openmcl streams are bivalent.
+  (unless (eql external-format :default)
+    (error 'unsupported :feature :external-format))
+  (handler-bind ((ccl:socket-error
+                  (lambda (c) (error 'socket-error :nested-error c))))
+    (ccl:accept-connection socket :wait t)))
\ No newline at end of file

Added: trivial-sockets/sbcl.lisp
==============================================================================
--- (empty file)
+++ trivial-sockets/sbcl.lisp	Sun Jul 13 14:16:19 2008
@@ -0,0 +1,63 @@
+(in-package :trivial-sockets)
+
+(defun resolve-hostname (name)
+  (cond
+   ((eql name :any)  #(0 0 0 0))
+   ((typep name '(vector * 4)) name)
+   (t (car (sb-bsd-sockets:host-ent-addresses
+	    (sb-bsd-sockets:get-host-by-name name))))))
+
+(defun open-stream (peer-host peer-port 
+			      &key (local-host :any) (local-port 0)
+			      (external-format :default)
+			      (element-type 'character)
+			      (protocol :tcp))
+  (unless (eql external-format :default)
+    (error 'unsupported :feature :external-format))
+  (handler-bind ((sb-bsd-sockets:socket-error 
+		  (lambda (c) (error 'socket-error :nested-error c)))
+		 (sb-bsd-sockets:name-service-error 
+		  (lambda (c) (error 'socket-error :nested-error c))))
+    (let ((s (make-instance 'sb-bsd-sockets:inet-socket
+			    :type :stream
+			    :protocol protocol))
+	  (me (resolve-hostname local-host)))
+      (unless (and (equal me #(0 0 0 0)) (eql local-port 0))
+	(sb-bsd-sockets:socket-bind s me local-port))
+      (sb-bsd-sockets:socket-connect
+       s (resolve-hostname peer-host) peer-port)
+      (sb-bsd-sockets:socket-make-stream  s :input t :output t
+					  :element-type element-type
+					  :buffering :full))))
+
+(defun open-server (&key (host :any) (port 0)
+			 (reuse-address t)
+			 (backlog 1)
+			 (protocol :tcp))
+  "Returns a SERVER object and the port that was bound, as multiple values"
+  (let ((sock (make-instance 'sb-bsd-sockets:inet-socket 
+			     :type :stream
+			     :protocol protocol)))
+    (when reuse-address
+      (setf (sb-bsd-sockets:sockopt-reuse-address sock) t))
+    (sb-bsd-sockets:socket-bind  sock (resolve-hostname host) port)
+    (sb-bsd-sockets:socket-listen sock backlog)
+    (multiple-value-bind (h p) (sb-bsd-sockets:socket-name sock)
+      (declare (ignore h))
+      (values sock p))))
+
+(defun close-server (server)
+  (sb-bsd-sockets:socket-close server))
+
+(defun accept-connection (socket
+			  &key
+			  (external-format :default)
+			  (element-type 'character))
+  (unless (eql external-format :default)
+    (error 'unsupported :feature :external-format))
+  (let ((s (sb-bsd-sockets:socket-accept socket)))
+    (sb-bsd-sockets:socket-make-stream s
+				       :input t :output t
+				       :element-type element-type
+				       :buffering :full)))
+

Added: trivial-sockets/server.lisp
==============================================================================
--- (empty file)
+++ trivial-sockets/server.lisp	Sun Jul 13 14:16:19 2008
@@ -0,0 +1,10 @@
+(in-package :trivial-sockets)
+
+(defmacro with-server ((name arguments) &body forms)
+  `(let (,name)
+     (unwind-protect 
+	 (progn
+	   (setf ,name (open-server , at arguments))
+	   (locally
+               , at forms))
+       (when ,name (close-server ,name)))))

Added: trivial-sockets/trivial-sockets.asd
==============================================================================
--- (empty file)
+++ trivial-sockets/trivial-sockets.asd	Sun Jul 13 14:16:19 2008
@@ -0,0 +1,21 @@
+;;; -*- Lisp -*-
+(defpackage #:trivial-sockets-system  (:use #:asdf #:cl))
+(in-package #:trivial-sockets-system )
+
+(defsystem trivial-sockets
+    :version "0.3"
+    :depends-on (#+sbcl sb-bsd-sockets)
+    :components ((:file "defpackage")
+		 (:file "errors"  :depends-on ("defpackage"))
+		 (:file 
+		  #+sbcl "sbcl" 
+		  #+cmu "cmucl"
+		  #+clisp "clisp"
+		  #+acl-socket "allegro"
+		  #+openmcl "openmcl"
+		  #+lispworks "lispworks"
+		  #+armedbear "abcl"
+		  :depends-on ("defpackage"))
+		 (:file "server" :depends-on ("defpackage"))
+		 ))
+

Added: trivial-sockets/trivial-sockets.texi
==============================================================================
--- (empty file)
+++ trivial-sockets/trivial-sockets.texi	Sun Jul 13 14:16:19 2008
@@ -0,0 +1,444 @@
+\input texinfo          @c -*- texinfo -*-
+ at c %**start of header
+ at setfilename trivial-sockets.info
+ at settitle TRIVIAL-SOCKETS Manual
+ at c %**end of header
+
+ at c merge type index into function index
+ at syncodeindex tp fn
+ at c ... and concept index, too.
+ at synindex cp fn
+
+ at c for install-info
+ at dircategory Software development
+ at direntry
+* trivial-sockets: (trivial-sockets).  CL socket interface for scripting/interactive use
+ at end direntry
+
+ at copying
+This manual describes TRIVIAL-SOCKETS, a simple socket interface for Common
+Lisp programs and libraries.
+     
+Copyright @copyright{} 2004 Daniel Barlow and contributors
+
+Permission is hereby granted, free of charge, to any person obtaining
+a copy of this software and associated documentation files (the
+``Software''), to deal in the Software without restriction, including
+without limitation the rights to use, copy, modify, merge, publish,
+distribute, sublicense, and/or sell copies of the Software, and to
+permit persons to whom the Software is furnished to do so, subject to
+the following conditions:
+
+The above copyright notice and this permission notice shall be
+included in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED ``AS IS'', WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
+ at end copying
+
+
+
+ at titlepage
+ at title TRIVIAL-SOCKETS
+     
+ at c The following two commands start the copyright page.
+ at page
+ at vskip 0pt plus 1filll
+ at insertcopying
+ at end titlepage
+     
+ at c Output the table of contents at the beginning.
+ at contents
+
+ at c -------------------
+
+ at ifnottex
+
+ at node Top
+ at top TRIVIAL-SOCKETS: a socket interface for scripting and interactive use
+
+ at insertcopying
+
+ at menu
+* Introduction::        Design goals and target audience
+* Installation::        How to download and install
+* API::
+* Index::              
+ at end menu
+
+ at end ifnottex
+
+ at c -------------------
+
+ at node  Introduction
+ at chapter Introduction
+
+TRIVIAL-SOCKETS is a portable socket interface that allows CL programs
+to open connected (client) stream sockets to network services
+(e.g. HTTP, FTP, SMTP servers) and communicate with them.  It's
+intended mostly for use by small ``script'' programs and for
+interactive use where the effort involved in writing one's own
+portable wrapper layer for several Lisp implementations would outweigh
+that spent on the actual application.
+
+In the interests of simplicity and ease of porting, the functionality
+available through TRIVIAL-SOCKETS has been deliberately restricted.
+For a more general sockets interface which may allow access to more
+functionality, the reader is encouraged to consult his Lisp
+implementation's documentation.
+
+ at node Installation
+ at chapter Installation
+ at cindex{Installation}
+
+TRIVIAL-SOCKETS is distributed via asdf-install.  If you are on the
+Internet and your Lisp implementation has asdf-install available, you
+may download and compile this package with an invocation like
+
+ at lisp
+(asdf-install:install 'trivial-sockets)
+ at end lisp
+
+The trivial-sockets package has been PGP-signed by Daniel Barlow, and
+asdf-install will by default check that the signature is good and that
+a trust path exists between you and him.  If not, you will be prompted
+for a decision on whether to install anyway.  See asdf-install
+documentation for more details on how this works.
+
+Once you have installed trivial-sockets, the next time you wish to
+load it you need only evaluate
+
+ at lisp
+(asdf:operate 'asdf:load-op 'trivial-sockets)
+ at end lisp
+
+or if you have an asdf system that uses it, add
+ at code{trivial-sockets} to the @code{:depends-on} clause of that system
+and it will be loaded whenever your system is.
+
+ at chapter API
+ at node API
+
+ at section Types
+ at cindex{Host designator}
+ at cindex{IP address}
+ at cindex{Address}
+ at cindex{Protocol}
+
+A @emph{host designator} is one of the following:
+
+ at enumerate
+ at item A string, which is resolved as a hostname by the system resolver,
+typically using DNS or YP or some other implementation-defined
+mechanism.  For example, @code{"www.google.com"}
+
+ at item An IPv4 address in "dotted quad" notation: e.g. @code{"127.0.0.1"}
+
+ at item (Implementation-defined): An IPv4 address in whatever ``native''
+format the implementation uses to represent same, if applicable.
+For example, @code{#(127 0 0 1)} or @code{2130706433}
+
+ at item The keyword @code{:ANY}, which corresponds to INADDR_ANY or "0.0.0.0"
+ at end enumerate
+
+A @emph{protocol specifier} is a keyword naming an
+ at uref{http://www.iana.org/assignments/protocol-numbers,,IANA protocol
+number} (as typically found in @file{/etc/protocols} on Unix-like
+systems) or the corresponding number.  Implementations must support
+ at code{:TCP} at a minimum.
+
+ at section Functions
+
+ at anchor{Function open-stream}
+ at defun open-stream peer-host peer-port &key local-host local-port external-format element-type protocol
+ at result{} stream
+
+ at strong{Arguments and Values:}
+
+ at var{peer-host}--a host designator.
+
+ at var{peer-port}--an integer.
+
+ at var{local-host}--a host designator.  The default is @code{:any}.
+
+ at var{local-port}--an integer.  The default is @code{0}.
+
+ at var{external-format}--an external file format designator.  The default
+is @code{:default}.
+
+ at var{element-type}--a type specifier; see the Common Lisp function
+ at code{open} for valid values.  The default is @code{'character}.
+
+ at var{protocol}--a protocol specifier.  The default is @code{:tcp}.
+
+ at strong{Description:}
+
+Return a stream to the named service, open for both reading and writing.
+The stream is usually buffered, so be sure to use @code{force-output}
+where necessary.
+
+If the stream cannot be created for any reason, an error of type
+ at code{socket-error} is signaled. 
+
+The stream should be closed in the usual way when no longer needed:
+see the Common Lisp functions @code{close}, @code{with-open-stream}
+ at end defun
+
+ at anchor{Function open-server}
+ at defun open-server &key host port reuse-address backlog protocol
+ at result{} server socket
+
+ at strong{Arguments and Values:}
+
+ at var{host}--a host designator.  The default is @code{:any}.
+
+ at var{port}--an integer.  The default is @code{0}.
+
+ at var{reuse-address}-- at code{t} or @code{nil}.  The default is @code{t}.
+
+ at var{backlog}--an integer.  The default is @code{1}.
+
+ at var{protocol}--a protocol specifier.  The default is @code{:tcp}.
+
+ at strong{Description:}
+
+Create a listening server socket.  If @var{port} is 0, an unused port
+will be chosen by the implementation/operating system.  @var{Host}
+may be set to the address of any local network interface to restrict
+the socket to that interface.
+
+If @var{reuse-address} is true (the default, as recommended by Stevens)
+then the @code{SO_REUSEADDR} socket option will be set, which allows the
+the port to be reused immediately after it has been closed, without
+waiting for a timeout (``2*MSL'') to expire.
+
+ at var{Backlog} sets how many pending connections are queued by the
+operating system.
+
+If the socket cannot be created for any reason, an error of type
+ at code{socket-error} is signaled. 
+
+The nature of the object returned is implementation-dependent.  When
+the socket is no longer needed it should be closed with
+ at code{close-server}.
+
+ at xref{Macro with-server}.
+ at end defun
+
+ at c <3dqes6$e49 at bosnia.pop.psu.edu> or see 242-246 of 
+ at c "TCP/IP Illustrated, Volume 1"
+
+ at anchor{Function close-server}
+ at defun close-server server
+ at result{} result
+
+ at strong{Arguments and Values:}
+
+ at var{server}--a server socket.
+
+ at var{result}--implementation-dependent.
+
+ at strong{Description:}
+
+Close @var{server} and release all resources associated with it.
+Note that opening a new server on the same address/port will not be
+immediately possible unless the earlier server was created with the
+ at code{:reuse-address} argument.
+ at end defun
+
+ at anchor{Macro with-server}
+ at defmac with-server (server args) declaration* form*
+ at result{} results
+
+ at strong{Arguments and Values:}
+
+ at var{server}--a variable.
+
+ at var{args}--a list of arguments.
+
+ at var{declaration}--a declare expression.
+
+ at var{forms}--an implicit @code{progn}.
+
+ at var{results}--the values returned by the @var{forms}.
+
+ at strong{Description:}
+
+ at code{with-server} uses @code{open-server} to create a server socket
+named by @var{server}.  @var{Args} are used as keyword arguments to
+ at code{open-server}.
+
+ at code{with-server} evaluates the @var{forms} as an implicit progn with
+ at var{server} bound to the value returned by @code{open-server}.
+
+When control leaves the body, either normally or abnormally (such as by
+use of @code{throw}), the server socket is automatically closed.
+
+The consequences are undefined if an attempt is made to assign to 
+the variable @var{server} within the body forms.
+ at end defmac
+
+ at anchor{Function accept-connection}
+ at defun accept-connection server &key external-format element-type
+ at result{} stream
+
+ at strong{Arguments and Values:}
+
+ at var{server}--a server socket.
+
+ at var{external-format}--an external file format designator.  The default
+is @code{:default}.
+
+ at var{element-type}--a type specifier; see the Common Lisp function
+ at code{open} for valid values.  The default is @code{'character}.
+
+ at strong{Description:}
+
+Accept a connection to @var{server}, returning a stream connected to
+the client which is open for both reading and writing.  The stream is
+usually buffered, so be sure to use @code{force-output} where
+necessary.
+
+If no connection is pending, @code{accept-connection} waits until one
+arrives.
+
+If anything goes wrong, an error of type @code{socket-error} is
+signaled.
+ at end defun
+
+ at section Examples
+
+ at subsection Simple client
+
+ at lisp
+;; this is not HTTP compliant, really.  But it's good enough
+;; for a demonstration
+(with-open-stream (s (trivial-sockets:open-stream "www.google.com" 80)) 
+  (format s "HEAD / HTTP/1.0~%Host: www.google.com~%~%") 
+  (force-output s) 
+  (loop 
+    (let ((l (read-line s nil nil))) 
+      (unless l (return)) 
+      (princ l) (terpri))))
+ at end lisp
+
+ at subsection Simple (single-threaded) server
+
+ at lisp
+(trivial-sockets:with-server (s (:port 8913 :reuse-address t))
+   (loop
+    (with-open-stream (c (trivial-sockets:accept-connection s)) 
+        (read-line c)
+        (format c "This is a compliant though pointless implementation ~
+of the finger protocol~%"))))
+ at end lisp
+
+
+ at section Errors
+
+ at anchor{Condition unsupported}
+ at deftp {Condition} unsupported
+Class precedence list: @w{error}
+
+This exists so that partial implementations of this interface may be
+created for environments which are incapable of supporting the full
+API.  An @code{unsupported} error is signaled if the user requests
+functionality that is not implemented for the Lisp environment in use.
+ at end deftp
+
+ at anchor{Condition socket-error}
+ at deftp {Condition} socket-error
+Class precedence list: @w{error}
+
+A @code{socket-error} error is signaled when an error situation occurs
+during opening of the stream.  If you need more detail, this is
+probably a sign that you have outgrown this interface and will have to
+resort to unportable code (error codes vary between systems:were you
+expecting @code{HOST_UNREACH} or @code{NET_UNREACH}?).  With that in
+mind, you can access the implementation-specific error using
+
+ at lisp
+(socket-nested-error condition)
+ at end lisp
+
+ at end deftp
+
+ at chapter Implementation-dependent
+ at node Implementation-dependent
+
+Not all features in this interface are supported on all platforms,
+owing to deficiencies in the underlying socket layers that it uses.
+
+Many implementations signal socket-related errors using non-specific
+error classes such as ERROR or SIMPLE-ERROR.  (Some others, perhaps,
+signal more specific errors but the code in trivial-sockets does not
+know that.  Patches welcome).  Where we don't know of a specific
+error, we catch the general ones and resignal @code{SOCKET-ERROR}, so
+it's possible sometimes that errors shich are nothing at all to do
+with sockets (e.g. keyboard interrupts or external signals) also get
+presented as SOCKET-ERRORs.  This applies in all implementations
+listed except where noted.
+
+ at itemize
+
+ at item Armed Bear CL currently supports only client sockets, and only
+for TCP, with unspecified local endpoint, and with the default
+external-format.
+
+ at item Allegro CL (tested in Allegro 6.2. trial) has no support for
+protocols other than @code{:tcp} or non-default external-formats.
+Allegro sockets are multivalent, so it ignores the
+ at code{:element-type}.  
+
+ at item CLISP has no support for protocols that are not @code{:tcp}, or for
+binding the local address/port.  Its streams are unbuffered, as CLISP
+buffered streams do not return any data at all on reads until the
+buffer is full - making them no use for any protocol in which one side
+sends less than 4k at a time.  (CLISP ``interactively buffered''
+streams are likely to fix this, but as of October 2004 have not yet
+been implemented). 
+
+ at item CMUCL has no support for external-formats other than
+ at code{:default}, for protocols that are not @code{:tcp}, or for
+binding the local address/port. 
+
+ at item Lispworks supports TCP only,  It doesn't do
+non-default local address in server sockets, or listen backlog length.
+It doesn't do non-default external-formats.  If the local port is 0,
+ at code{open-server} doesn't return the real port number.  It also uses
+an odd construction involving multiple threads for server sockets
+which in principle should be transparent but don't say we didn't warn
+you.
+
+ at item OpenMCL socket support is very similar to that of Allegro: all
+implementation notes applicable to Allegro also hold for OpenMCL.
+Additionally, errors signaled by instances of @code{ccl:socket-error}
+are caught and resignaled as @code{socket-error}.
+
+ at item SBCL has no support for external-formats other than @code{:default}.
+Errors signaled by @code{sb-bsd-sockets:socket-error} and @code
+{sb-bsd-sockets:name-service-error} are caught and resignaled as
+ at code{socket-error}.
+
+ at end itemize
+
+Patches to improve per-implementation support for this interface are
+welcome.  Patches which include an appropriate update for the manual
+are doubly if not sevenfoldly so.
+
+ at c -------------------
+
+
+ at node Index,
+ at unnumbered Index
+     
+ at printindex fn
+
+ at bye
+


From ehuelsmann at common-lisp.net  Sun Jul 13 18:19:33 2008
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Sun, 13 Jul 2008 14:19:33 -0400 (EDT)
Subject: [usocket-cvs] r365 - trivial-sockets
Message-ID: <20080713181933.664AA601C5@common-lisp.net>

Author: ehuelsmann
Date: Sun Jul 13 14:19:33 2008
New Revision: 365

Modified:
   trivial-sockets/README
Log:
Update trivial-sockets/README.

Modified: trivial-sockets/README
==============================================================================
--- trivial-sockets/README	(original)
+++ trivial-sockets/README	Sun Jul 13 14:19:33 2008
@@ -1,19 +1,31 @@
-Trivial-sockets: 
+
+*
+*  NOTE NOTE *****  IMPORTANT *****
+*
+*
+*  This package is no longer maintained.  If you're looking for a sockets
+*  library which does receive maintenance, check out usocket.
+*
+*  You can find usocket at http://common-lisp.net/project/usocket/
+*
+
+
+Trivial-sockets:
   server and client stream sockets for undemanding network applications
 
 Usage examples:
 
-(with-open-stream (s (trivial-sockets:open-stream "www.google.com" 80)) 
-  (format s "HEAD / HTTP/1.0~%Host: www.google.com~%~%") 
-  (force-output s) 
-  (loop 
-    (let ((l (read-line s nil nil))) 
-      (unless l (return)) 
+(with-open-stream (s (trivial-sockets:open-stream "www.google.com" 80))
+  (format s "HEAD / HTTP/1.0~%Host: www.google.com~%~%")
+  (force-output s)
+  (loop
+    (let ((l (read-line s nil nil)))
+      (unless l (return))
       (princ l) (terpri))))
 
 (trivial-sockets:with-server (s (:port 8913 :reuse-address t))
    (loop
-    (with-open-stream (c (trivial-sockets:accept-connection s)) 
+    (with-open-stream (c (trivial-sockets:accept-connection s))
         (read-line c)
         (format c "Hi there!~%"))))
 
@@ -26,7 +38,7 @@
 
 Installation:
 
-Use asdf-install.  
+Use asdf-install.
 
   * (asdf:operate 'asdf:load-op 'asdf-install)
   * (asdf-install:install 'trivial-sockets)


From ehuelsmann at common-lisp.net  Sun Jul 13 18:22:28 2008
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Sun, 13 Jul 2008 14:22:28 -0400 (EDT)
Subject: [usocket-cvs] r366 - public_html/releases/old
Message-ID: <20080713182228.4719E232CE@common-lisp.net>

Author: ehuelsmann
Date: Sun Jul 13 14:22:27 2008
New Revision: 366

Added:
   public_html/releases/old/
   public_html/releases/old/trivial-sockets.tar.gz   (contents, props changed)
Log:
Make trivial-sockets available online again, asdf-install friendliness.

Added: public_html/releases/old/trivial-sockets.tar.gz
==============================================================================
Binary file. No diff available.


From ehuelsmann at common-lisp.net  Sun Jul 13 18:59:37 2008
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Sun, 13 Jul 2008 14:59:37 -0400 (EDT)
Subject: [usocket-cvs] r367 - public_html
Message-ID: <20080713185937.4BA0C2F051@common-lisp.net>

Author: ehuelsmann
Date: Sun Jul 13 14:59:36 2008
New Revision: 367

Modified:
   public_html/api-docs.shtml
Log:
Update FAQ.

Modified: public_html/api-docs.shtml
==============================================================================
--- public_html/api-docs.shtml	(original)
+++ public_html/api-docs.shtml	Sun Jul 13 14:59:36 2008
@@ -159,6 +159,16 @@
 <h1><a name="faqs">How do I ...</a></h1>
 
 <dl class="faq">
+<dt>... force the output to be written to the network?
+</dt>
+<dd>When you write output to the stream, it may be buffered before
+   sent over the network - for optimal performance of small writes.  You
+   can force the buffer to be flushed the same way as with normal streams:
+
+<pre>(format (socket-stream socket) "Hello there~%")   ;; output into buffers
+(force-output (socket-stream socket))             ;; &lt;== flush the buffers, if any
+</pre>
+</dd>
 <dt>... check whether the other end has closed my socket stream?
 </dt>
 <dd>Reading from a stream which has been closed at the remote end


From ehuelsmann at common-lisp.net  Sun Jul 13 19:00:53 2008
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Sun, 13 Jul 2008 15:00:53 -0400 (EDT)
Subject: [usocket-cvs] r368 - public_html
Message-ID: <20080713190053.44A3F610B6@common-lisp.net>

Author: ehuelsmann
Date: Sun Jul 13 15:00:50 2008
New Revision: 368

Modified:
   public_html/index.shtml
Log:
Add quick-link to the faq.

Modified: public_html/index.shtml
==============================================================================
--- public_html/index.shtml	(original)
+++ public_html/index.shtml	Sun Jul 13 15:00:50 2008
@@ -16,6 +16,7 @@
 <ul>
 <li><a href="#goal">Goal</a></li>
 <li><a href="#documentation">Documentation</a></li>
+<li><a href="api-docs.shtml#faqs"><i>FAQ</i></a></li>
 <li><a href="#implementations">Supported implementations</a></li>
 <li><a href="#community">Community</a></li>
 <li><a href="#development">Development</a></li>


From hhubner at common-lisp.net  Sat Jul 19 11:54:23 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Sat, 19 Jul 2008 07:54:23 -0400 (EDT)
Subject: [usocket-cvs] r369 - usocket/branches/hans
Message-ID: <20080719115423.B6A0E70308@common-lisp.net>

Author: hhubner
Date: Sat Jul 19 07:54:23 2008
New Revision: 369

Removed:
   usocket/branches/hans/
Log:
delete obsolete branch


From ehuelsmann at common-lisp.net  Sat Jul 19 22:38:17 2008
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Sat, 19 Jul 2008 18:38:17 -0400 (EDT)
Subject: [usocket-cvs] r371 - usocket/branches/new-wfi/backend
Message-ID: <20080719223817.A170050016@common-lisp.net>

Author: ehuelsmann
Date: Sat Jul 19 18:38:17 2008
New Revision: 371

Modified:
   usocket/branches/new-wfi/backend/lispworks.lisp
Log:
Add documentation to the LispWorks backend.

Modified: usocket/branches/new-wfi/backend/lispworks.lisp
==============================================================================
--- usocket/branches/new-wfi/backend/lispworks.lisp	(original)
+++ usocket/branches/new-wfi/backend/lispworks.lisp	Sat Jul 19 18:38:17 2008
@@ -243,6 +243,23 @@
 
   (defconstant fionread 1074030207)
 
+
+  ;; Note:
+  ;;
+  ;;  If special finalization has to occur for a given
+  ;;  system resource (handle), an associated object should
+  ;;  be created.  A special cleanup action should be added
+  ;;  to the system and a special cleanup action should
+  ;;  be flagged on all objects created for resources like it
+  ;;
+  ;;  We have 2 functions to do so:
+  ;;   * hcl:add-special-free-action (function-symbol)
+  ;;   * hcl:flag-special-free-action (object)
+  ;;
+  ;;  Note that the special free action will be called on all
+  ;;  objects which have been flagged for special free, so be
+  ;;  sure to check for the right argument type!
+  
   (fli:define-foreign-type ws-socket () '(:unsigned :int))
   (fli:define-foreign-type win32-handle () '(:unsigned :int))
   (fli:define-c-struct wsa-network-events (network-events :long)


From ehuelsmann at common-lisp.net  Sun Jul 20 17:52:24 2008
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Sun, 20 Jul 2008 13:52:24 -0400 (EDT)
Subject: [usocket-cvs] r372 - usocket/branches/new-wfi
Message-ID: <20080720175224.4DE9375187@common-lisp.net>

Author: ehuelsmann
Date: Sun Jul 20 13:52:23 2008
New Revision: 372

Modified:
   usocket/branches/new-wfi/usocket.lisp
Log:
Fix 'old-style' calling convention.

Modified: usocket/branches/new-wfi/usocket.lisp
==============================================================================
--- usocket/branches/new-wfi/usocket.lisp	(original)
+++ usocket/branches/new-wfi/usocket.lisp	Sun Jul 20 13:52:23 2008
@@ -266,8 +266,7 @@
 none."
   (unless (wait-list-p socket-or-sockets)
     (let ((wl (make-wait-list (if (listp socket-or-sockets)
-                                  socket-or-sockets (list socket-or-sockets))
-                              nil)))
+                                  socket-or-sockets (list socket-or-sockets)))))
       (multiple-value-bind
             (socks to)
           (wait-for-input wl :timeout timeout :ready-only ready-only)


From ehuelsmann at common-lisp.net  Sun Jul 20 18:36:21 2008
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Sun, 20 Jul 2008 14:36:21 -0400 (EDT)
Subject: [usocket-cvs] r373 - in usocket/branches/new-wfi: . backend
Message-ID: <20080720183621.17B1138069@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."))
 


From ehuelsmann at common-lisp.net  Sun Jul 20 19:21:29 2008
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Sun, 20 Jul 2008 15:21:29 -0400 (EDT)
Subject: [usocket-cvs] r374 - usocket/branches/new-wfi/backend
Message-ID: <20080720192129.C47BA7913E@common-lisp.net>

Author: ehuelsmann
Date: Sun Jul 20 15:21:29 2008
New Revision: 374

Modified:
   usocket/branches/new-wfi/backend/sbcl.lisp
Log:
Remove obsolete comment.

Modified: usocket/branches/new-wfi/backend/sbcl.lisp
==============================================================================
--- usocket/branches/new-wfi/backend/sbcl.lisp	(original)
+++ usocket/branches/new-wfi/backend/sbcl.lisp	Sun Jul 20 15:21:29 2008
@@ -275,7 +275,6 @@
   (push (socket waiter) (wait-list-%wait wait-list)))
 
 (defun %remove-waiter (wait-list waiter)
-  ;;;### not removing from the waiters list?!
   (setf (wait-list-%wait wait-list)
         (remove (socket waiter) (wait-list-%wait wait-list))))
 


From ehuelsmann at common-lisp.net  Sun Jul 20 19:22:13 2008
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Sun, 20 Jul 2008 15:22:13 -0400 (EDT)
Subject: [usocket-cvs] r375 - usocket/branches/new-wfi
Message-ID: <20080720192213.DB9F81C09E@common-lisp.net>

Author: ehuelsmann
Date: Sun Jul 20 15:22:13 2008
New Revision: 375

Modified:
   usocket/branches/new-wfi/BRANCH-README
Log:
Update BRANCH-README with the factual state of affairs.


Modified: usocket/branches/new-wfi/BRANCH-README
==============================================================================
--- usocket/branches/new-wfi/BRANCH-README	(original)
+++ usocket/branches/new-wfi/BRANCH-README	Sun Jul 20 15:22:13 2008
@@ -3,5 +3,5 @@
 At least these backends are broken, for now:
 
  - ABCL
- - SBCL/ ECL
+ - ECL
  - Scieneer


From ehuelsmann at common-lisp.net  Tue Jul 22 06:06:06 2008
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Tue, 22 Jul 2008 02:06:06 -0400 (EDT)
Subject: [usocket-cvs] r376 - in usocket/branches/new-wfi: . backend
Message-ID: <20080722060606.27198742ED@common-lisp.net>

Author: ehuelsmann
Date: Tue Jul 22 02:05:57 2008
New Revision: 376

Modified:
   usocket/branches/new-wfi/BRANCH-README
   usocket/branches/new-wfi/backend/armedbear.lisp
Log:
Update the ABCL backend with new w-f-i.

Modified: usocket/branches/new-wfi/BRANCH-README
==============================================================================
--- usocket/branches/new-wfi/BRANCH-README	(original)
+++ usocket/branches/new-wfi/BRANCH-README	Tue Jul 22 02:05:57 2008
@@ -2,6 +2,5 @@
 
 At least these backends are broken, for now:
 
- - ABCL
  - ECL
  - Scieneer

Modified: usocket/branches/new-wfi/backend/armedbear.lisp
==============================================================================
--- usocket/branches/new-wfi/backend/armedbear.lisp	(original)
+++ usocket/branches/new-wfi/backend/armedbear.lisp	Tue Jul 22 02:05:57 2008
@@ -349,8 +349,9 @@
    ((datagram-usocket-p socket)
     "java.nio.channels.DatagramChannel")))
 
-(defun wait-for-input-internal (sockets &key timeout)
-  (let* ((ops (logior (op-read) (op-accept)))
+(defun wait-for-input-internal (wait-list &key timeout)
+  (let* ((sockets (wait-list-waiters wait-list))
+         (ops (logior (op-read) (op-accept)))
          (selector (jdi:do-jstatic "java.nio.channels.Selector" "open"))
          (channels (mapcar #'socket sockets)))
     (unwind-protect
@@ -415,3 +416,25 @@
                                           "boolean")
                       (jdi:jop-deref chan) jtrue))))))
 
+
+;;
+;;
+;;
+;; The WAIT-LIST part
+;;
+
+;;
+;; Note that even though Java has the concept of the Selector class, which
+;; remotely looks like a wait-list, it requires the sockets to be non-blocking.
+;; usocket however doesn't make any such guarantees and is therefore unable to
+;; use the concept outside of the waiting routine itself (blergh!).
+;;
+
+(defun %setup-wait-list (wl)
+  (declare (ignore wl)))
+
+(defun %add-waiter (wl w)
+  (declare (ignore wl w)))
+
+(defun %remove-waiter (wl w)
+  (declare (ignore wl w)))
\ No newline at end of file


From ehuelsmann at common-lisp.net  Tue Jul 22 06:24:22 2008
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Tue, 22 Jul 2008 02:24:22 -0400 (EDT)
Subject: [usocket-cvs] r377 - usocket/trunk
Message-ID: <20080722062422.CA02A7518B@common-lisp.net>

Author: ehuelsmann
Date: Tue Jul 22 02:24:21 2008
New Revision: 377

Modified:
   usocket/trunk/usocket.lisp
Log:
Fixes compilation issue with recent SBCL.

Patch by Chun Tian (binghe.lisp at gmail.com)

Modified: usocket/trunk/usocket.lisp
==============================================================================
--- usocket/trunk/usocket.lisp	(original)
+++ usocket/trunk/usocket.lisp	Tue Jul 22 02:24:21 2008
@@ -63,6 +63,11 @@
   (:documentation "Socket which listens for stream connections to
 be initiated from remote sockets."))
 
+(defclass datagram-usocket (usocket)
+  ((connected-p :initarg :connected-p :accessor connected-p))
+;; ###FIXME: documentation to be added.
+  (:documentation ""))
+
 (defun usocket-p (socket)
   (typep socket 'usocket))
 
@@ -75,11 +80,6 @@
 (defun datagram-usocket-p (socket)
   (typep socket 'datagram-usocket))
 
-(defclass datagram-usocket (usocket)
-  ((connected-p :initarg :connected-p :accessor connected-p))
-;; ###FIXME: documentation to be added.
-  (:documentation ""))
-
 (defun make-socket (&key socket)
   "Create a usocket socket type from implementation specific socket."
   (unless socket


From ehuelsmann at common-lisp.net  Tue Jul 22 20:23:18 2008
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Tue, 22 Jul 2008 16:23:18 -0400 (EDT)
Subject: [usocket-cvs] r378 - usocket/branches/new-wfi/backend
Message-ID: <20080722202318.10C071A0C0@common-lisp.net>

Author: ehuelsmann
Date: Tue Jul 22 16:23:17 2008
New Revision: 378

Modified:
   usocket/branches/new-wfi/backend/armedbear.lisp
Log:
Make the ABCL backend actually adhere to the new protocol (ie update the STATE slot).

Modified: usocket/branches/new-wfi/backend/armedbear.lisp
==============================================================================
--- usocket/branches/new-wfi/backend/armedbear.lisp	(original)
+++ usocket/branches/new-wfi/backend/armedbear.lisp	Tue Jul 22 16:23:17 2008
@@ -377,7 +377,7 @@
                 ;; we actually have work to do
                 (let* ((selkeys (jdi:do-jmethod selector "selectedKeys"))
                        (selkey-iterator (jdi:do-jmethod selkeys "iterator"))
-                       ready-sockets)
+                       (%wait (wait-list-%wait wait-list)))
                   (loop while (java:jcall
                                (java:jmethod "java.util.Iterator" "hasNext")
                                (jdi:jop-deref selkey-iterator))
@@ -386,16 +386,8 @@
                                         "java.nio.channels.SelectionKey"))
                                   (chan (jdi:jop-deref
                                          (jdi:do-jmethod key "channel"))))
-                             (push chan ready-sockets)))
-                  (remove-if #'(lambda (s)
-                                 (not (member (jdi:jop-deref (socket s))
-                                              ready-sockets
-                                              :test #'(lambda (x y)
-                                                        (java:jcall (java:jmethod "java.lang.Object"
-                                                                             "equals"
-                                                                             "java.lang.Object")
-                                                                    x y)))))
-                             sockets))))))
+                             (setf (state (gethash chan %wait))
+                                   :READ))))))))
       ;; cancel all Selector registrations
       (let* ((keys (jdi:do-jmethod selector "keys"))
              (iter (jdi:do-jmethod keys "iterator")))
@@ -431,10 +423,12 @@
 ;;
 
 (defun %setup-wait-list (wl)
-  (declare (ignore wl)))
+  (setf (wait-list-%wait wl)
+        (make-hash-table :rehash-size 1.3d0)))
 
 (defun %add-waiter (wl w)
-  (declare (ignore wl w)))
+  (setf (gethash (socket w) (wait-list-%wait wl))
+        w))
 
 (defun %remove-waiter (wl w)
-  (declare (ignore wl w)))
\ No newline at end of file
+  (remhash (socket w) (wait-list-%wait wl)))
\ No newline at end of file


From ehuelsmann at common-lisp.net  Tue Jul 22 23:06:15 2008
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Tue, 22 Jul 2008 19:06:15 -0400 (EDT)
Subject: [usocket-cvs] r379 - in usocket/branches/new-wfi: . backend
Message-ID: <20080722230615.A6CE5406A@common-lisp.net>

Author: ehuelsmann
Date: Tue Jul 22 19:06:15 2008
New Revision: 379

Modified:
   usocket/branches/new-wfi/BRANCH-README
   usocket/branches/new-wfi/backend/cmucl.lisp
   usocket/branches/new-wfi/backend/sbcl.lisp
Log:
Tackle ECL w-f-i, new style. At the same time, simplify the backend greatly by having less inline C code.

Modified: usocket/branches/new-wfi/BRANCH-README
==============================================================================
--- usocket/branches/new-wfi/BRANCH-README	(original)
+++ usocket/branches/new-wfi/BRANCH-README	Tue Jul 22 19:06:15 2008
@@ -2,5 +2,4 @@
 
 At least these backends are broken, for now:
 
- - ECL
  - Scieneer

Modified: usocket/branches/new-wfi/backend/cmucl.lisp
==============================================================================
--- usocket/branches/new-wfi/backend/cmucl.lisp	(original)
+++ usocket/branches/new-wfi/backend/cmucl.lisp	Tue Jul 22 19:06:15 2008
@@ -166,24 +166,27 @@
   (declare (ignore wait-list)))
 
 (defun %add-waiter (wait-list waiter)
-  (declare (ignore wait-list waiter)))
+  (declare (ignore wait-list waiter))
+  (push (socket waiter) (wait-list-%wait wait-list)))
 
 (defun %remove-waiter (wait-list waiter)
-  (declare (ignore wait-list waiter)))
+  (declare (ignore wait-list waiter))
+  (setf (wait-list-%wait wait-list)
+        (remove (socket waiter) (wait-list-%wait waiter))))
 
 (defun wait-for-input-internal (wait-list &key timeout)
   (with-mapped-conditions ()
     (alien:with-alien ((rfds (alien:struct unix:fd-set)))
        (unix:fd-zero rfds)
-       (dolist (socket (wait-list-waiters wait-list))
-         (unix:fd-set (socket socket) rfds))
+       (dolist (socket (wait-list-%wait wait-list))
+         (unix:fd-set socket rfds))
        (multiple-value-bind
            (secs musecs)
            (split-timeout (or timeout 1))
          (multiple-value-bind
              (count err)
-             (unix:unix-fast-select (1+ (reduce #'max (wait-list wait-list)
-                                                :key #'socket))
+             (unix:unix-fast-select (1+ (reduce #'max
+                                                (wait-list-%wait wait-list)))
                                     (alien:addr rfds) nil nil
                                     (when timeout secs) musecs)
            (if (<= 0 count)

Modified: usocket/branches/new-wfi/backend/sbcl.lisp
==============================================================================
--- usocket/branches/new-wfi/backend/sbcl.lisp	(original)
+++ usocket/branches/new-wfi/backend/sbcl.lisp	Tue Jul 22 19:06:15 2008
@@ -64,10 +64,37 @@
     (ffi:c-inline () () :fixnum
      "FD_SETSIZE" :one-liner t))
 
+  (defun fdset-alloc ()
+    (ffi:c-inline () () :pointer-void
+     "cl_alloc_atomic(sizeof(fd_set))" :one-liner t))
+
+  (defun fdset-zero (fdset)
+    (ffi:c-inline (fdset) (:pointer-void) :void
+     "FD_ZERO((fd_set*)#0)" :one-liner t))
+
+  (defun fdset-set (fdset fd)
+    (ffi:c-inline (fdset fd) (:pointer-void :fixnum) :void
+     "FD_SET(#1,(fd_set*)#0)" :one-liner t))
+
+  (defun fdset-clr (fdset fd)
+    (ffi:c-inline (fdset fd) (:pointer-void :fixnum) :void
+     "FD_CLR(#1,(fd_set*)#0)" :one-liner t))
+
+  (defun fdset-fd-isset (fdset fd)
+    (ffi:c-inline (fdset fd) (:pointer-void :fixnum) :bool
+     "FD_ISSET(#1,(fd_set*)#0)" :one-liner t))
+
+  (declaim (inline fd-setsize
+                   fdset-alloc
+                   fdset-zero
+                   fdset-set
+                   fdset-clr
+                   fdset-fd-isset))
+
   (defun get-host-name ()
     (ffi:c-inline
      () () :object
-     "{ char *buf = GC_malloc(256);
+     "{ char *buf = cl_alloc_atomic(257);
 
         if (gethostname(buf,256) == 0)
           @(return) = make_simple_base_string(buf);
@@ -75,61 +102,47 @@
           @(return) = Cnil;
       }" :one-liner nil :side-effects nil))
 
-  (defun read-select (read-fds to-secs &optional (to-musecs 0))
-    (ffi:c-inline (read-fds to-secs to-musecs) (t t :unsigned-int) t
-      "{
-          fd_set rfds;
-          cl_object cur_fd = #0;
+  (defun read-select (wl to-secs &optional (to-musecs 0))
+    (let* ((sockets (wait-list-waiters wl))
+           (rfds (wait-list-%wait wl))
+           (max-fd (reduce #'(lambda (x y)
+                               (let ((sy (sb-bsd-sockets:socket-file-descriptor
+                                          (socket y))))
+                                 (if (< x sy) sy x)))
+                           (cdr sockets)
+                           :initial-value (sb-bsd-sockets:socket-file-descriptor
+                                           (socket (car sockets))))))
+      (fdset-zero rfds)
+      (dolist (sock sockets)
+        (fdset-set rfds (sb-bsd-sockets:socket-file-descriptor
+                         (socket sock))))
+      (let ((count
+             (ffi:c-inline (to-secs to-musecs rfds max-fd)
+                           (t :unsigned-int :pointer-void :int)
+                           :int
+      "
           int count;
-          int max_fd = -1;
           struct timeval tv;
 
-          FD_ZERO(&rfds);
-          while (CONSP(cur_fd)) {
-            int fd = fixint(cur_fd->cons.car);
-            max_fd = (max_fd > fd) ? max_fd : fd;
-            FD_SET(fd, &rfds);
-            cur_fd = cur_fd->cons.cdr;
-          }
-
-          if (#1 != Cnil) {
-            tv.tv_sec = fixnnint(#1);
-            tv.tv_usec = #2;
+          if (#0 != Cnil) {
+            tv.tv_sec = fixnnint(#0);
+            tv.tv_usec = #1;
           }
-          count = select(max_fd + 1, &rfds, NULL, NULL,
-                         (#1 != Cnil) ? &tv : NULL);
+        @(return) = select(#3 + 1, (fd_set*)#2, NULL, NULL,
+                           (#0 != Cnil) ? &tv : NULL);
+")))
+        (cond
+          ((= 0 count)
+           (values nil nil))
+          ((< count 0)
+           ;; check for EINTR and EAGAIN; these should not err
+           (values nil (ffi:c-inline () () :int "errno" :one-liner t)))
+          (t
+           (dolist (sock sockets)
+             (when (fdset-fd-isset rfds (sb-bsd-sockets:socket-file-descriptor
+                                         (socket sock)))
+               (setf (state sock) :READ))))))))
 
-          if (count == 0)
-            @(return 0) = Cnil;
-            @(return 1) = Cnil;
-          else if (count < 0)
-            /*###FIXME: We should be raising an error here...
-
-              except, ofcourse in case of EINTR or EAGAIN */
-
-            @(return 0) = Cnil;
-            @(return 1) = MAKE_INTEGER(errno);
-          else
-            {
-              cl_object rv = Cnil;
-              cur_fd = #0;
-
-              /* when we're going to use the same code on Windows,
-                 as well as unix, we can't be sure it'll fit into
-                 a fixnum: these aren't unix filehandle bitmaps sets on
-                 Windows... */
-
-              while (CONSP(cur_fd)) {
-                int fd = fixint(cur_fd->cons.car);
-                if (FD_ISSET(fd, &rfds))
-                  rv = CONS(MAKE_INTEGER(fd), rv);
-
-                cur_fd = cur_fd->cons.cdr;
-              }
-              @(return 0) = rv;
-              @(return 1) = Cnil;
-            }
-}"))
 
 )
 
@@ -152,6 +165,7 @@
      . operation-not-permitted-error)
     (sb-bsd-sockets:protocol-not-supported-error
      . protocol-not-supported-error)
+    #-ecl
     (sb-bsd-sockets:unknown-protocol
      . protocol-not-supported-error)
     (sb-bsd-sockets:socket-type-not-supported-error
@@ -161,6 +175,7 @@
     (sb-bsd-sockets:socket-error . ,#'map-socket-error)
 
     ;; Nameservice errors: mapped to unknown-error
+    #-ecl #-ecl #-ecl
     (sb-bsd-sockets:no-recovery-error . ns-no-recovery-error)
     (sb-bsd-sockets:try-again-error . ns-try-again-condition)
     (sb-bsd-sockets:host-not-found-error . ns-host-not-found-error)))
@@ -315,23 +330,25 @@
 
 #+ecl
 (progn
-  (defun wait-for-input-internal (sockets &key timeout)
+  (defun wait-for-input-internal (wl &key timeout)
     (with-mapped-conditions ()
       (multiple-value-bind
-          (secs usecs)
+            (secs usecs)
           (split-timeout (or timeout 1))
-        (let* ((sock-fds (mapcar #'sb-bsd-sockets:socket-file-descriptor
-                                 (mapcar #'socket sockets))))
-	  (multiple-value-bind
-		(result-fds err)
-	      (read-select sock-fds (when timeout secs) usecs)
-	    (if (null err)
-		(remove-if #'(lambda (s)
-			       (not
-				(member
-				 (sb-bsd-sockets:socket-file-descriptor
-				  (socket s))
-				 result-fds)))
-			   sockets)
-		(error (map-errno-error err))))))))
+        (multiple-value-bind
+              (result-fds err)
+            (read-select wl (when timeout secs) usecs)
+          (unless (null err)
+            (error (map-errno-error err)))))))
+
+  (defun %setup-wait-list (wl)
+    (setf (wait-list-%wait wl)
+          (fdset-alloc)))
+
+  (defun %add-waiter (wl w)
+    (declare (ignore wl w)))
+
+  (defun %remove-waiter (wl w)
+    (declare (ignore wl w)))
+
   )


From ehuelsmann at common-lisp.net  Wed Jul 23 20:54:58 2008
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Wed, 23 Jul 2008 16:54:58 -0400 (EDT)
Subject: [usocket-cvs] r380 - usocket/branches/new-wfi/backend
Message-ID: <20080723205458.3C9385061@common-lisp.net>

Author: ehuelsmann
Date: Wed Jul 23 16:54:57 2008
New Revision: 380

Modified:
   usocket/branches/new-wfi/backend/armedbear.lisp
Log:
Fix ABCL backend.

Modified: usocket/branches/new-wfi/backend/armedbear.lisp
==============================================================================
--- usocket/branches/new-wfi/backend/armedbear.lisp	(original)
+++ usocket/branches/new-wfi/backend/armedbear.lisp	Wed Jul 23 16:54:57 2008
@@ -196,7 +196,6 @@
              (jchan (jdi:do-jstatic-call "java.nio.channels.SocketChannel"
                                          "open" sock-addr))
              (sock (jdi:do-jmethod-call jchan "socket")))
-        (describe sock)
          (setf usock
                (make-stream-socket
                 :socket jchan
@@ -424,10 +423,10 @@
 
 (defun %setup-wait-list (wl)
   (setf (wait-list-%wait wl)
-        (make-hash-table :rehash-size 1.3d0)))
+        (make-hash-table :test #'equal :rehash-size 1.3d0)))
 
 (defun %add-waiter (wl w)
-  (setf (gethash (socket w) (wait-list-%wait wl))
+  (setf (gethash (jdi:jop-deref (socket w)) (wait-list-%wait wl))
         w))
 
 (defun %remove-waiter (wl w)


From ehuelsmann at common-lisp.net  Wed Jul 23 21:13:51 2008
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Wed, 23 Jul 2008 17:13:51 -0400 (EDT)
Subject: [usocket-cvs] r381 - usocket/branches/new-wfi/backend
Message-ID: <20080723211351.6C8D375187@common-lisp.net>

Author: ehuelsmann
Date: Wed Jul 23 17:13:51 2008
New Revision: 381

Modified:
   usocket/branches/new-wfi/backend/armedbear.lisp
Log:
Increased ABCL W-F-I efficiency.

Modified: usocket/branches/new-wfi/backend/armedbear.lisp
==============================================================================
--- usocket/branches/new-wfi/backend/armedbear.lisp	(original)
+++ usocket/branches/new-wfi/backend/armedbear.lisp	Wed Jul 23 17:13:51 2008
@@ -88,6 +88,7 @@
    (t
     (java:jclass-name (jop-class instance)))))
 
+(declaim (inline jop-deref))
 (defun jop-deref (instance)
   (if (java-object-proxy-p instance)
       (jop-value instance)
@@ -355,14 +356,13 @@
          (channels (mapcar #'socket sockets)))
     (unwind-protect
         (with-mapped-conditions ()
-          (let ((jfalse (java:make-immediate-object nil :boolean))
-                (sel (jdi:jop-deref selector)))
+          (let ((sel (jdi:jop-deref selector)))
             (dolist (channel channels)
               (let ((chan (jdi:jop-deref channel)))
                 (java:jcall (java:jmethod "java.nio.channels.SelectableChannel"
                                           "configureBlocking"
                                           "boolean")
-                            chan jfalse)
+                            chan (java:make-immediate-object nil :boolean))
                 (java:jcall (java:jmethod "java.nio.channels.SelectableChannel"
                                           "register"
                                           "java.nio.channels.Selector" "int")
@@ -387,25 +387,16 @@
                                          (jdi:do-jmethod key "channel"))))
                              (setf (state (gethash chan %wait))
                                    :READ))))))))
-      ;; cancel all Selector registrations
-      (let* ((keys (jdi:do-jmethod selector "keys"))
-             (iter (jdi:do-jmethod keys "iterator")))
-        (loop while (java:jcall (java:jmethod "java.util.Iterator" "hasNext")
-                                (jdi:jop-deref iter))
-              do (java:jcall
-                  (java:jmethod "java.nio.channels.SelectionKey" "cancel")
-                  (java:jcall (java:jmethod "java.util.Iterator" "next")
-                              (jdi:jop-deref iter)))))
-      ;; close the selector
+      ;; close the selector: all keys will be deregistered
       (java:jcall (java:jmethod "java.nio.channels.Selector" "close")
                   (jdi:jop-deref selector))
       ;; make all sockets blocking again.
-      (let ((jtrue (java:make-immediate-object t :boolean)))
-        (dolist (chan channels)
-          (java:jcall (java:jmethod "java.nio.channels.SelectableChannel"
-                                          "configureBlocking"
-                                          "boolean")
-                      (jdi:jop-deref chan) jtrue))))))
+     (dolist (channel channels)
+       (java:jcall (java:jmethod "java.nio.channels.SelectableChannel"
+                                 "configureBlocking"
+                                 "boolean")
+                      (jdi:jop-deref channel)
+                      (java:make-immediate-object t :boolean))))))
 
 
 ;;


From ehuelsmann at common-lisp.net  Thu Jul 24 21:18:47 2008
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Thu, 24 Jul 2008 17:18:47 -0400 (EDT)
Subject: [usocket-cvs] r382 - in usocket/branches/new-wfi: . backend
Message-ID: <20080724211847.84E586308A@common-lisp.net>

Author: ehuelsmann
Date: Thu Jul 24 17:18:46 2008
New Revision: 382

Modified:
   usocket/branches/new-wfi/backend/allegro.lisp
   usocket/branches/new-wfi/backend/armedbear.lisp
   usocket/branches/new-wfi/backend/clisp.lisp
   usocket/branches/new-wfi/backend/cmucl.lisp
   usocket/branches/new-wfi/backend/lispworks.lisp
   usocket/branches/new-wfi/backend/openmcl.lisp
   usocket/branches/new-wfi/backend/sbcl.lisp
   usocket/branches/new-wfi/backend/scl.lisp
   usocket/branches/new-wfi/usocket.lisp
Log:
Make sockets clean up their associated wait-list, if closed correctly.

Modified: usocket/branches/new-wfi/backend/allegro.lisp
==============================================================================
--- usocket/branches/new-wfi/backend/allegro.lisp	(original)
+++ usocket/branches/new-wfi/backend/allegro.lisp	Thu Jul 24 17:18:46 2008
@@ -63,6 +63,8 @@
 ;; because socket-streams are also sockets.
 (defmethod socket-close ((usocket usocket))
   "Close socket."
+  (when (wait-list usocket)
+     (remove-waiter (wait-list usocket) usocket))
   (with-mapped-conditions (usocket)
     (close (socket usocket))))
 

Modified: usocket/branches/new-wfi/backend/armedbear.lisp
==============================================================================
--- usocket/branches/new-wfi/backend/armedbear.lisp	(original)
+++ usocket/branches/new-wfi/backend/armedbear.lisp	Thu Jul 24 17:18:46 2008
@@ -245,6 +245,8 @@
 ;;    (print (jcall (jmethod "java.net.BindException" "getMessage") native-exception))))
 
 (defmethod socket-close ((usocket usocket))
+  (when (wait-list usocket)
+     (remove-waiter (wait-list usocket) usocket))
   (with-mapped-conditions (usocket)
     (jdi:do-jmethod (socket usocket) "close")))
 
@@ -252,6 +254,8 @@
 ;; socket streams. Closing the stream flushes
 ;; its buffers *and* closes the socket.
 (defmethod socket-close ((usocket stream-usocket))
+  (when (wait-list usocket)
+     (remove-waiter (wait-list usocket) usocket))
   (with-mapped-conditions (usocket)
     (close (socket-stream usocket))))
 

Modified: usocket/branches/new-wfi/backend/clisp.lisp
==============================================================================
--- usocket/branches/new-wfi/backend/clisp.lisp	(original)
+++ usocket/branches/new-wfi/backend/clisp.lisp	Thu Jul 24 17:18:46 2008
@@ -96,10 +96,14 @@
 ;; are the same object
 (defmethod socket-close ((usocket usocket))
   "Close socket."
+  (when (wait-list usocket)
+     (remove-waiter (wait-list usocket) usocket))
   (with-mapped-conditions (usocket)
     (close (socket usocket))))
 
 (defmethod socket-close ((usocket stream-server-usocket))
+  (when (wait-list usocket)
+     (remove-waiter (wait-list usocket) usocket))
   (socket:socket-server-close (socket usocket)))
 
 (defmethod get-local-name ((usocket usocket))
@@ -227,6 +231,8 @@
       rv))
 
   (defmethod socket-close ((usocket datagram-usocket))
+    (when (wait-list usocket)
+       (remove-waiter (wait-list usocket) usocket))
     (rawsock:sock-close (socket usocket)))
 
   )

Modified: usocket/branches/new-wfi/backend/cmucl.lisp
==============================================================================
--- usocket/branches/new-wfi/backend/cmucl.lisp	(original)
+++ usocket/branches/new-wfi/backend/cmucl.lisp	Thu Jul 24 17:18:46 2008
@@ -97,11 +97,15 @@
 ;; socket stream when closing a stream socket.
 (defmethod socket-close ((usocket stream-usocket))
   "Close socket."
+  (when (wait-list usocket)
+     (remove-waiter (wait-list usocket) usocket))
   (with-mapped-conditions (usocket)
     (close (socket-stream usocket))))
 
 (defmethod socket-close ((usocket usocket))
   "Close socket."
+  (when (wait-list usocket)
+     (remove-waiter (wait-list usocket) usocket))
   (with-mapped-conditions (usocket)
     (ext:close-socket (socket usocket))))
 

Modified: usocket/branches/new-wfi/backend/lispworks.lisp
==============================================================================
--- usocket/branches/new-wfi/backend/lispworks.lisp	(original)
+++ usocket/branches/new-wfi/backend/lispworks.lisp	Thu Jul 24 17:18:46 2008
@@ -117,9 +117,13 @@
 ;; are correctly flushed and the socket closed.
 (defmethod socket-close ((usocket stream-usocket))
   "Close socket."
+  (when (wait-list usocket)
+     (remove-waiter (wait-list usocket) usocket))
   (close (socket-stream usocket)))
 
 (defmethod socket-close ((usocket usocket))
+  (when (wait-list usocket)
+     (remove-waiter (wait-list usocket) usocket))
   (with-mapped-conditions (usocket)
      (comm::close-socket (socket usocket))))
 

Modified: usocket/branches/new-wfi/backend/openmcl.lisp
==============================================================================
--- usocket/branches/new-wfi/backend/openmcl.lisp	(original)
+++ usocket/branches/new-wfi/backend/openmcl.lisp	Thu Jul 24 17:18:46 2008
@@ -106,6 +106,8 @@
 ;; and their associated objects are represented
 ;; by the same object.
 (defmethod socket-close ((usocket usocket))
+  (when (wait-list usocket)
+     (remove-waiter (wait-list usocket) usocket))
   (with-mapped-conditions (usocket)
     (close (socket usocket))))
 

Modified: usocket/branches/new-wfi/backend/sbcl.lisp
==============================================================================
--- usocket/branches/new-wfi/backend/sbcl.lisp	(original)
+++ usocket/branches/new-wfi/backend/sbcl.lisp	Thu Jul 24 17:18:46 2008
@@ -244,10 +244,14 @@
 ;; different objects. Be sure to close the stream (which
 ;; closes the socket too) when closing a stream-socket.
 (defmethod socket-close ((usocket usocket))
+  (when (wait-list usocket)
+     (remove-waiter (wait-list usocket) usocket))
   (with-mapped-conditions (usocket)
     (sb-bsd-sockets:socket-close (socket usocket))))
 
 (defmethod socket-close ((usocket stream-usocket))
+  (when (wait-list usocket)
+     (remove-waiter (wait-list usocket) usocket))
   (with-mapped-conditions (usocket)
     (close (socket-stream usocket))))
 

Modified: usocket/branches/new-wfi/backend/scl.lisp
==============================================================================
--- usocket/branches/new-wfi/backend/scl.lisp	(original)
+++ usocket/branches/new-wfi/backend/scl.lisp	Thu Jul 24 17:18:46 2008
@@ -69,11 +69,15 @@
 ;; are flushed and the socket is closed correctly afterwards.
 (defmethod socket-close ((usocket usocket))
   "Close socket."
+  (when (wait-list usocket)
+     (remove-waiter (wait-list usocket) usocket))
   (with-mapped-conditions (usocket)
     (ext:close-socket (socket usocket))))
 
 (defmethod socket-close ((usocket stream-usocket))
   "Close socket."
+  (when (wait-list usocket)
+     (remove-waiter (wait-list usocket) usocket))
   (with-mapped-conditions (usocket)
     (close (socket-stream usocket))))
 

Modified: usocket/branches/new-wfi/usocket.lisp
==============================================================================
--- usocket/branches/new-wfi/usocket.lisp	(original)
+++ usocket/branches/new-wfi/usocket.lisp	Thu Jul 24 17:18:46 2008
@@ -16,6 +16,10 @@
     :initarg :socket
     :accessor socket
     :documentation "Implementation specific socket object instance.'")
+   (wait-list
+    :initform nil
+    :accessor wait-list
+    :documentation "WAIT-LIST the object is associated with.")
    (state
     :initform nil
     :accessor state
@@ -225,8 +229,8 @@
 ;; Implementation specific:
 ;;
 ;;  %setup-wait-list
-;;  add-waiter
-;;  remove-waiter
+;;  %add-waiter
+;;  %remove-waiter
 
 (declaim (inline %setup-wait-list
                  %add-waiter
@@ -241,17 +245,23 @@
     wl))
 
 (defun add-waiter (wait-list input)
-  (setf (gethash (socket input) (wait-list-map wait-list)) input)
+  (setf (gethash (socket input) (wait-list-map wait-list)) input
+        (wait-list input) wait-list)
   (pushnew input (wait-list-waiters wait-list))
   (%add-waiter wait-list input))
 
 (defun remove-waiter (wait-list input)
   (%remove-waiter wait-list input)
   (setf (wait-list-waiters wait-list)
-        (remove input (wait-list-waiters wait-list)))
+        (remove input (wait-list-waiters wait-list))
+        (wait-list input) nil)
   (remhash (socket input) (wait-list-map wait-list)))
 
-
+(defun remove-all-waiters (wait-list)
+  (dolist (waiter (wait-list-waiters wait-list))
+    (%remove-waiter waiter))
+  (setf (wait-list-waiters wait-list) nil)
+  (clrhash (wait-list-map wait-list)))
 
 
 (defun wait-for-input (socket-or-sockets &key timeout ready-only)


From ehuelsmann at common-lisp.net  Sat Jul 26 11:27:57 2008
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Sat, 26 Jul 2008 07:27:57 -0400 (EDT)
Subject: [usocket-cvs] r383 - usocket/branches/new-wfi
Message-ID: <20080726112757.6A6B779166@common-lisp.net>

Author: ehuelsmann
Date: Sat Jul 26 07:27:56 2008
New Revision: 383

Modified:
   usocket/branches/new-wfi/package.lisp
Log:
Export API symbols.

Modified: usocket/branches/new-wfi/package.lisp
==============================================================================
--- usocket/branches/new-wfi/package.lisp	(original)
+++ usocket/branches/new-wfi/package.lisp	Sat Jul 26 07:27:56 2008
@@ -15,7 +15,6 @@
              #:socket-listen
              #:socket-accept
              #:socket-close
-             #:wait-for-input
              #:get-local-address
              #:get-peer-address
              #:get-local-port
@@ -23,6 +22,12 @@
              #:get-local-name
              #:get-peer-name
 
+             #:wait-for-input ; waiting for input-ready state (select() like)
+             #:make-wait-list
+             #:add-waiter
+             #:remove-waiter
+             #:remove-all-waiters
+
              #:with-connected-socket ; convenience macros
              #:with-server-socket
              #:with-client-socket


From ehuelsmann at common-lisp.net  Sat Jul 26 21:55:24 2008
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Sat, 26 Jul 2008 17:55:24 -0400 (EDT)
Subject: [usocket-cvs] r386 - usocket/branches/new-wfi
Message-ID: <20080726215524.1316D1F00F@common-lisp.net>

Author: ehuelsmann
Date: Sat Jul 26 17:55:23 2008
New Revision: 386

Removed:
   usocket/branches/new-wfi/
Log:
Remove new-wfi branch now that it's integrated with the trunk.


From ehuelsmann at common-lisp.net  Sat Jul 26 22:00:18 2008
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Sat, 26 Jul 2008 18:00:18 -0400 (EDT)
Subject: [usocket-cvs] r387 - usocket/trunk
Message-ID: <20080726220018.9E6DC610B9@common-lisp.net>

Author: ehuelsmann
Date: Sat Jul 26 18:00:18 2008
New Revision: 387

Modified:
   usocket/trunk/TODO
Log:
Update TODO.

Modified: usocket/trunk/TODO
==============================================================================
--- usocket/trunk/TODO	(original)
+++ usocket/trunk/TODO	Sat Jul 26 18:00:18 2008
@@ -1,18 +1,17 @@
-
-- 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.
-
-- Add INET6 support.
-
-For more TODO items, see http://trac.common-lisp.net/usocket/report.
+
+- Implement wait-for-input-internal for
+    * SBCL 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.
+
+- Add INET6 support.
+
+For more TODO items, see http://trac.common-lisp.net/usocket/report.


From ehuelsmann at common-lisp.net  Sat Jul 26 22:00:47 2008
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Sat, 26 Jul 2008 18:00:47 -0400 (EDT)
Subject: [usocket-cvs] r388 - usocket/branches/0.4.x
Message-ID: <20080726220047.E49C276042@common-lisp.net>

Author: ehuelsmann
Date: Sat Jul 26 18:00:47 2008
New Revision: 388

Modified:
   usocket/branches/0.4.x/TODO
Log:
Update TODO.


Modified: usocket/branches/0.4.x/TODO
==============================================================================
--- usocket/branches/0.4.x/TODO	(original)
+++ usocket/branches/0.4.x/TODO	Sat Jul 26 18:00:47 2008
@@ -1,18 +1,17 @@
-
-- 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.
-
-- Add INET6 support.
-
-For more TODO items, see http://trac.common-lisp.net/usocket/report.
+
+- Implement wait-for-input-internal for
+    * SBCL 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.
+
+- Add INET6 support.
+
+For more TODO items, see http://trac.common-lisp.net/usocket/report.


From ehuelsmann at common-lisp.net  Sun Jul 27 10:07:49 2008
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Sun, 27 Jul 2008 06:07:49 -0400 (EDT)
Subject: [usocket-cvs] r389 - usocket/trunk/backend
Message-ID: <20080727100749.8A02D75187@common-lisp.net>

Author: ehuelsmann
Date: Sun Jul 27 06:07:49 2008
New Revision: 389

Modified:
   usocket/trunk/backend/scl.lisp
Log:
Minimally change SCL backend to comply to new W-F-I protocol.

Modified: usocket/trunk/backend/scl.lisp
==============================================================================
--- usocket/trunk/backend/scl.lisp	(original)
+++ usocket/trunk/backend/scl.lisp	Sun Jul 27 06:07:49 2008
@@ -138,10 +138,27 @@
 (defun get-host-name ()
   (unix:unix-gethostname))
 
-(defun wait-for-input-internal (sockets &key timeout)
-  (let* ((pollfd-size (alien:alien-size (alien:struct unix::pollfd) :bytes))
-        (nfds (length sockets))
-        (bytes (* nfds pollfd-size)))
+
+;;
+;;
+;;  WAIT-LIST part
+;;
+
+
+(defun %add-waiter (wl waiter)
+  (declare (ignore wl waiter)))
+
+(defun %remove-waiter (wl waiter)
+  (declare (ignore wl waiter)))
+
+(defun %setup-wait-list (wl)
+  (declare (ignore wl)))
+
+(defun wait-for-input-internal (wait-list &key timeout)
+  (let* ((sockets (wait-list-waiters wait-list))
+         (pollfd-size (alien:alien-size (alien:struct unix::pollfd) :bytes))
+         (nfds (length sockets))
+         (bytes (* nfds pollfd-size)))
     (alien:with-bytes (fds-sap bytes)
       (do ((sockets sockets (rest sockets))
           (base 0 (+ base 8)))
@@ -163,11 +180,9 @@
                      (unix:get-unix-error-msg errno)))
              (t
               (do ((sockets sockets (rest sockets))
-                   (base 0 (+ base 8))
-                   (ready nil))
-                  ((endp sockets)
-                   (nreverse ready))
+                   (base 0 (+ base 8)))
+                  ((endp sockets))
                 (let ((flags (sys:sap-ref-16 fds-sap (+ base 6))))
                   (unless (zerop (logand flags unix::pollin))
-                    (push (first sockets) ready))))))))))
+                    (setf (state socket) :READ))))))))))
 


From ehuelsmann at common-lisp.net  Sun Jul 27 10:09:21 2008
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Sun, 27 Jul 2008 06:09:21 -0400 (EDT)
Subject: [usocket-cvs] r390 - usocket/trunk/backend
Message-ID: <20080727100921.B8A593108@common-lisp.net>

Author: ehuelsmann
Date: Sun Jul 27 06:09:20 2008
New Revision: 390

Modified:
   usocket/trunk/backend/scl.lisp
Log:
Followup commit for SCL protocol compliance.

Modified: usocket/trunk/backend/scl.lisp
==============================================================================
--- usocket/trunk/backend/scl.lisp	(original)
+++ usocket/trunk/backend/scl.lisp	Sun Jul 27 06:09:20 2008
@@ -184,5 +184,5 @@
                   ((endp sockets))
                 (let ((flags (sys:sap-ref-16 fds-sap (+ base 6))))
                   (unless (zerop (logand flags unix::pollin))
-                    (setf (state socket) :READ))))))))))
+                    (setf (state (first sockets)) :READ))))))))))
 


From ehuelsmann at common-lisp.net  Sun Jul 27 16:24:50 2008
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Sun, 27 Jul 2008 12:24:50 -0400 (EDT)
Subject: [usocket-cvs] r391 - usocket/trunk
Message-ID: <20080727162450.0F9D83F019@common-lisp.net>

Author: ehuelsmann
Date: Sun Jul 27 12:24:48 2008
New Revision: 391

Modified:
   usocket/trunk/usocket.lisp
Log:
SBCL bug with HOST-TO-HBO.

Found by: Chun Tian (binge.lisp at gmail.com)


Modified: usocket/trunk/usocket.lisp
==============================================================================
--- usocket/trunk/usocket.lisp	(original)
+++ usocket/trunk/usocket.lisp	Sun Jul 27 12:24:48 2008
@@ -403,17 +403,21 @@
   "Translate a string or vector quad to a stringified hostname."
   (etypecase host
     (string host)
-    ((vector t 4) (vector-quad-to-dotted-quad host))
+    ((or (vector t 4)
+         (array (unsigned-byte 8) (4)))
+     (vector-quad-to-dotted-quad host))
     (integer (hbo-to-dotted-quad host))))
 
 (defun ip= (ip1 ip2)
   (etypecase ip1
     (string (string= ip1 (host-to-hostname ip2)))
-    ((vector t 4) (or (eq ip1 ip2)
-                      (and (= (aref ip1 0) (aref ip2 0))
-                           (= (aref ip1 1) (aref ip2 1))
-                           (= (aref ip1 2) (aref ip2 2))
-                           (= (aref ip1 3) (aref ip2 3)))))
+    ((or (vector t 4)
+         (array (unsigned-byte 8) (4)))
+     (or (eq ip1 ip2)
+         (and (= (aref ip1 0) (aref ip2 0))
+              (= (aref ip1 1) (aref ip2 1))
+              (= (aref ip1 2) (aref ip2 2))
+              (= (aref ip1 3) (aref ip2 3)))))
     (integer (= ip1 (host-byte-order ip2)))))
 
 (defun ip/= (ip1 ip2)
@@ -444,7 +448,9 @@
                     ;; valid IP dotted quad?
                     ip
                   (get-random-host-by-name host))))
-      ((vector t 4) host)
+      ((or (vector t 4)
+           (array (unsigned-byte 8) (4)))
+       host)
       (integer (hbo-to-vector-quad host))))
 
   (defun host-to-hbo (host)
@@ -454,10 +460,12 @@
                 (if (and ip (= 4 (length ip)))
                     (host-byte-order ip)
             (host-to-hbo (get-host-by-name host)))))
-      ((vector t 4) (host-byte-order host))
+      ((or (vector t 4)
+           (array (unsigned-byte 8) (4)))
+       (host-byte-order host))
       (integer host))))
 
-;;ready-
+;;
 ;; Other utility functions
 ;;
 


From ehuelsmann at common-lisp.net  Sun Jul 27 16:59:37 2008
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Sun, 27 Jul 2008 12:59:37 -0400 (EDT)
Subject: [usocket-cvs] r392 - usocket/trunk
Message-ID: <20080727165937.1C3CC1A0C2@common-lisp.net>

Author: ehuelsmann
Date: Sun Jul 27 12:59:36 2008
New Revision: 392

Modified:
   usocket/trunk/condition.lisp
   usocket/trunk/package.lisp
Log:
Conditions soon to be used (not only for backward compat).

Modified: usocket/trunk/condition.lisp
==============================================================================
--- usocket/trunk/condition.lisp	(original)
+++ usocket/trunk/condition.lisp	Sun Jul 27 12:59:36 2008
@@ -5,12 +5,34 @@
 
 (in-package :usocket)
 
-;; Condition raised by operations with unsupported arguments
+;; Condition signalled by operations with unsupported arguments
 ;; For trivial-sockets compatibility.
 
-(define-condition unsupported (error)
-  ((feature :initarg :feature :reader unsupported-feature)))
+(define-condition insufficient-implementation (error)
+  ((feature :initarg :feature :reader feature)
+   (function :initarg :function :reader function))
+  (:documentation "The ancestor of all errors usocket may generate
+because of insufficient support from the underlying implementation
+with respect to the arguments given to `function'.
+
+One call may signal several errors, if the caller allows processing
+to continue.
+"))
+
+(define-condition unsupported (insufficient-implementation)
+  ((minimum :initarg :minimum :reader minimum
+            :documentation "Indicates the minimal version of the
+implementation required to support the requested feature."))
+  (:documentation "Signalled when the underlying implementation
+doesn't allow supporting the requested feature.
 
+When you see this error, go bug your vendor/implementation developer!"))
+
+(define-condition unimplemented (insufficient-implementation)
+  ()
+  (:documentation "Signalled if a certain feature might be implemented,
+based on the features of the underlying implementation, but hasn't
+been implemented yet."))
 
 ;; Conditions raised by sockets operations
 

Modified: usocket/trunk/package.lisp
==============================================================================
--- usocket/trunk/package.lisp	(original)
+++ usocket/trunk/package.lisp	Sun Jul 27 12:59:36 2008
@@ -56,6 +56,7 @@
              #:ip-from-octet-buffer
 
              #:with-mapped-conditions
+
              #:socket-condition ; conditions
              #:ns-condition
              #:socket-error ; errors
@@ -63,5 +64,10 @@
              #:unknown-condition
              #:ns-unknown-condition
              #:unknown-error
-             #:ns-unknown-error)))
+             #:ns-unknown-error
+
+             #:insufficient-implementation ; conditions regarding usocket support level
+             #:unsupported
+             #:unimplemented
+             )))
 


From ehuelsmann at common-lisp.net  Sun Jul 27 17:57:42 2008
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Sun, 27 Jul 2008 13:57:42 -0400 (EDT)
Subject: [usocket-cvs] r393 - usocket/trunk
Message-ID: <20080727175742.1BF971135@common-lisp.net>

Author: ehuelsmann
Date: Sun Jul 27 13:57:41 2008
New Revision: 393

Modified:
   usocket/trunk/condition.lisp
Log:
Fix slot name.

Modified: usocket/trunk/condition.lisp
==============================================================================
--- usocket/trunk/condition.lisp	(original)
+++ usocket/trunk/condition.lisp	Sun Jul 27 13:57:41 2008
@@ -10,7 +10,9 @@
 
 (define-condition insufficient-implementation (error)
   ((feature :initarg :feature :reader feature)
-   (function :initarg :function :reader function))
+   (context :initarg :context :reader context
+    :documentation "String designator of the public API function which
+the feature belongs to."))
   (:documentation "The ancestor of all errors usocket may generate
 because of insufficient support from the underlying implementation
 with respect to the arguments given to `function'.


From ehuelsmann at common-lisp.net  Sun Jul 27 18:10:20 2008
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Sun, 27 Jul 2008 14:10:20 -0400 (EDT)
Subject: [usocket-cvs] r394 - in usocket: branches/0.4.x trunk
Message-ID: <20080727181020.51B1E47005@common-lisp.net>

Author: ehuelsmann
Date: Sun Jul 27 14:10:20 2008
New Revision: 394

Modified:
   usocket/branches/0.4.x/usocket.lisp
   usocket/trunk/usocket.lisp
Log:
Fix call to %remove-waiter with too few arguments.

Found by: Chun Tian



Modified: usocket/branches/0.4.x/usocket.lisp
==============================================================================
--- usocket/branches/0.4.x/usocket.lisp	(original)
+++ usocket/branches/0.4.x/usocket.lisp	Sun Jul 27 14:10:20 2008
@@ -253,7 +253,7 @@
 
 (defun remove-all-waiters (wait-list)
   (dolist (waiter (wait-list-waiters wait-list))
-    (%remove-waiter waiter))
+    (%remove-waiter wait-list waiter))
   (setf (wait-list-waiters wait-list) nil)
   (clrhash (wait-list-map wait-list)))
 

Modified: usocket/trunk/usocket.lisp
==============================================================================
--- usocket/trunk/usocket.lisp	(original)
+++ usocket/trunk/usocket.lisp	Sun Jul 27 14:10:20 2008
@@ -259,7 +259,7 @@
 
 (defun remove-all-waiters (wait-list)
   (dolist (waiter (wait-list-waiters wait-list))
-    (%remove-waiter waiter))
+    (%remove-waiter wait-list waiter))
   (setf (wait-list-waiters wait-list) nil)
   (clrhash (wait-list-map wait-list)))
 


From ehuelsmann at common-lisp.net  Sun Jul 27 19:36:10 2008
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Sun, 27 Jul 2008 15:36:10 -0400 (EDT)
Subject: [usocket-cvs] r395 - in usocket: branches/0.4.x
	branches/0.4.x/backend trunk trunk/backend
Message-ID: <20080727193610.B671547193@common-lisp.net>

Author: ehuelsmann
Date: Sun Jul 27 15:36:10 2008
New Revision: 395

Modified:
   usocket/branches/0.4.x/backend/cmucl.lisp
   usocket/branches/0.4.x/usocket.lisp
   usocket/trunk/backend/cmucl.lisp
   usocket/trunk/usocket.lisp
Log:
Fix CMUCL: 1) remove premature optimization (inline declaration)
 2) Remove ignore declaration of used parameters

Found by: Chun Tian

Modified: usocket/branches/0.4.x/backend/cmucl.lisp
==============================================================================
--- usocket/branches/0.4.x/backend/cmucl.lisp	(original)
+++ usocket/branches/0.4.x/backend/cmucl.lisp	Sun Jul 27 15:36:10 2008
@@ -170,11 +170,9 @@
   (declare (ignore wait-list)))
 
 (defun %add-waiter (wait-list waiter)
-  (declare (ignore wait-list waiter))
   (push (socket waiter) (wait-list-%wait wait-list)))
 
 (defun %remove-waiter (wait-list waiter)
-  (declare (ignore wait-list waiter))
   (setf (wait-list-%wait wait-list)
         (remove (socket waiter) (wait-list-%wait waiter))))
 

Modified: usocket/branches/0.4.x/usocket.lisp
==============================================================================
--- usocket/branches/0.4.x/usocket.lisp	(original)
+++ usocket/branches/0.4.x/usocket.lisp	Sun Jul 27 15:36:10 2008
@@ -226,10 +226,6 @@
 ;;  %add-waiter
 ;;  %remove-waiter
 
-(declaim (inline %setup-wait-list
-                 %add-waiter
-                 %remove-waiter))
-
 (defun make-wait-list (waiters)
   (let ((wl (%make-wait-list)))
     (setf (wait-list-map wl) (make-hash-table))

Modified: usocket/trunk/backend/cmucl.lisp
==============================================================================
--- usocket/trunk/backend/cmucl.lisp	(original)
+++ usocket/trunk/backend/cmucl.lisp	Sun Jul 27 15:36:10 2008
@@ -172,11 +172,9 @@
   (declare (ignore wait-list)))
 
 (defun %add-waiter (wait-list waiter)
-  (declare (ignore wait-list waiter))
   (push (socket waiter) (wait-list-%wait wait-list)))
 
 (defun %remove-waiter (wait-list waiter)
-  (declare (ignore wait-list waiter))
   (setf (wait-list-%wait wait-list)
         (remove (socket waiter) (wait-list-%wait waiter))))
 

Modified: usocket/trunk/usocket.lisp
==============================================================================
--- usocket/trunk/usocket.lisp	(original)
+++ usocket/trunk/usocket.lisp	Sun Jul 27 15:36:10 2008
@@ -232,10 +232,6 @@
 ;;  %add-waiter
 ;;  %remove-waiter
 
-(declaim (inline %setup-wait-list
-                 %add-waiter
-                 %remove-waiter))
-
 (defun make-wait-list (waiters)
   (let ((wl (%make-wait-list)))
     (setf (wait-list-map wl) (make-hash-table))


From ehuelsmann at common-lisp.net  Sun Jul 27 20:22:48 2008
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Sun, 27 Jul 2008 16:22:48 -0400 (EDT)
Subject: [usocket-cvs] r396 - in usocket: branches/0.4.x/backend
	trunk/backend
Message-ID: <20080727202248.6D5BE5301C@common-lisp.net>

Author: ehuelsmann
Date: Sun Jul 27 16:22:48 2008
New Revision: 396

Modified:
   usocket/branches/0.4.x/backend/cmucl.lisp
   usocket/trunk/backend/cmucl.lisp
Log:
More CMUCL fixes.

Modified: usocket/branches/0.4.x/backend/cmucl.lisp
==============================================================================
--- usocket/branches/0.4.x/backend/cmucl.lisp	(original)
+++ usocket/branches/0.4.x/backend/cmucl.lisp	Sun Jul 27 16:22:48 2008
@@ -174,7 +174,7 @@
 
 (defun %remove-waiter (wait-list waiter)
   (setf (wait-list-%wait wait-list)
-        (remove (socket waiter) (wait-list-%wait waiter))))
+        (remove (socket waiter) (wait-list-%wait wait-list))))
 
 (defun wait-for-input-internal (wait-list &key timeout)
   (with-mapped-conditions ()

Modified: usocket/trunk/backend/cmucl.lisp
==============================================================================
--- usocket/trunk/backend/cmucl.lisp	(original)
+++ usocket/trunk/backend/cmucl.lisp	Sun Jul 27 16:22:48 2008
@@ -176,7 +176,7 @@
 
 (defun %remove-waiter (wait-list waiter)
   (setf (wait-list-%wait wait-list)
-        (remove (socket waiter) (wait-list-%wait waiter))))
+        (remove (socket waiter) (wait-list-%wait wait-list))))
 
 (defun wait-for-input-internal (wait-list &key timeout)
   (with-mapped-conditions ()


From ehuelsmann at common-lisp.net  Mon Jul 28 21:33:20 2008
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Mon, 28 Jul 2008 17:33:20 -0400 (EDT)
Subject: [usocket-cvs] r397 - usocket/trunk/backend
Message-ID: <20080728213320.48DB8702EF@common-lisp.net>

Author: ehuelsmann
Date: Mon Jul 28 17:33:19 2008
New Revision: 397

Modified:
   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
   usocket/trunk/backend/scl.lisp
Log:
Merge hans/ branch into trunk.

Modified: usocket/trunk/backend/allegro.lisp
==============================================================================
--- usocket/trunk/backend/allegro.lisp	(original)
+++ usocket/trunk/backend/allegro.lisp	Mon Jul 28 17:33:19 2008
@@ -49,7 +49,10 @@
       :text
     :binary))
 
-(defun socket-connect (host port &key (element-type 'character) timeout)
+(defun socket-connect (host port &key (element-type 'character) timeout nodelay)
+  (declare (ignore nodelay))
+  (when timeout
+    (warn "SOCKET-CONNECT timeout not supported in Allegro CL"))
   (let ((socket))
     (setf socket
           (with-mapped-conditions (socket)

Modified: usocket/trunk/backend/armedbear.lisp
==============================================================================
--- usocket/trunk/backend/armedbear.lisp	(original)
+++ usocket/trunk/backend/armedbear.lisp	Mon Jul 28 17:33:19 2008
@@ -186,7 +186,8 @@
   (typecase condition
     (error (error 'unknown-error :socket socket :real-error condition))))
 
-(defun socket-connect (host port &key (element-type 'character) timeout)
+(defun socket-connect (host port &key (element-type 'character) timeout nodelay)
+  (declare (ignore nodelay))
   (when timeout
     (warn "SOCKET-CONNECT timeout not supported in ABCL"))
   (let ((usock))

Modified: usocket/trunk/backend/clisp.lisp
==============================================================================
--- usocket/trunk/backend/clisp.lisp	(original)
+++ usocket/trunk/backend/clisp.lisp	Mon Jul 28 17:33:19 2008
@@ -55,7 +55,10 @@
                  (error usock-err :socket socket)
                (signal usock-err :socket socket)))))))
 
-(defun socket-connect (host port &key (element-type 'character) timeout)
+(defun socket-connect (host port &key (element-type 'character) timeout nodelay)
+  (declare (ignore nodelay))
+  (when timeout
+    (warn "SOCKET-CONNECT timeout not supported in CLISP"))
   (let ((socket)
         (hostname (host-to-hostname host)))
     (with-mapped-conditions (socket)
@@ -239,7 +242,7 @@
     (when (wait-list usocket)
        (remove-waiter (wait-list usocket) usocket))
     (rawsock:sock-close (socket usocket)))
-
+  
   )
 
 #-rawsock
@@ -248,4 +251,4 @@
 To enable UDP socket support, please be sure to use the -Kfull parameter
 at startup, or to enable RAWSOCK support during compilation.")
 
-  )
\ No newline at end of file
+  )

Modified: usocket/trunk/backend/cmucl.lisp
==============================================================================
--- usocket/trunk/backend/cmucl.lisp	(original)
+++ usocket/trunk/backend/cmucl.lisp	Mon Jul 28 17:33:19 2008
@@ -50,7 +50,8 @@
                                                :socket socket
                                                :condition condition))))
 
-(defun socket-connect (host port &key (element-type 'character) timeout)
+(defun socket-connect (host port &key (element-type 'character) timeout nodelay)
+  (declare (ignore nodelay))
   (when timeout
     (warn "SOCKET-CONNECT timeout not supported in CMUCL"))
   (let* ((socket))

Modified: usocket/trunk/backend/lispworks.lisp
==============================================================================
--- usocket/trunk/backend/lispworks.lisp	(original)
+++ usocket/trunk/backend/lispworks.lisp	Mon Jul 28 17:33:19 2008
@@ -73,7 +73,8 @@
                     (declare (ignore host port err-msg))
                     (raise-usock-err errno socket condition)))))
 
-(defun socket-connect (host port &key (element-type 'base-char) timeout)
+(defun socket-connect (host port &key (element-type 'base-char) timeout nodelay)
+  (declare (ignore nodelay))
   (when timeout
     (warn "SOCKET-CONNECT timeout not supported in Lispworks"))
   (let ((hostname (host-to-hostname host))

Modified: usocket/trunk/backend/openmcl.lisp
==============================================================================
--- usocket/trunk/backend/openmcl.lisp	(original)
+++ usocket/trunk/backend/openmcl.lisp	Mon Jul 28 17:33:19 2008
@@ -61,6 +61,8 @@
     (openmcl-socket:socket-error
        (raise-error-from-id (openmcl-socket:socket-error-identifier condition)
                             socket condition))
+    (ccl:input-timeout
+       (error 'timeout-error :socket socket :real-error condition))
     (ccl:communication-deadline-expired
        (error 'timeout-error :socket socket :real-error condition))
     (ccl::socket-creation-error #| ugh! |#
@@ -72,13 +74,14 @@
       :text
     :binary))
 
-(defun socket-connect (host port &key (element-type 'character) timeout deadline)
+(defun socket-connect (host port &key (element-type 'character) timeout deadline nodelay)
   (with-mapped-conditions ()
     (let ((mcl-sock
            (openmcl-socket:make-socket :remote-host (host-to-hostname host)
                                        :remote-port port
                                        :format (to-format element-type)
                                        :deadline deadline
+                                       :nodelay nodelay
                                        :connect-timeout (and timeout
                                                              (* timeout internal-time-units-per-second)))))
       (openmcl-socket:socket-connect mcl-sock)

Modified: usocket/trunk/backend/sbcl.lisp
==============================================================================
--- usocket/trunk/backend/sbcl.lisp	(original)
+++ usocket/trunk/backend/sbcl.lisp	Mon Jul 28 17:33:19 2008
@@ -130,7 +130,7 @@
           }
         @(return) = select(#3 + 1, (fd_set*)#2, NULL, NULL,
                            (#0 != Cnil) ? &tv : NULL);
-")))
+" :one-liner nil)))
         (cond
           ((= 0 count)
            (values nil nil))
@@ -199,7 +199,8 @@
                      (signal usock-cond :socket socket))))))
 
 
-(defun socket-connect (host port &key (element-type 'character) timeout deadline)
+(defun socket-connect (host port &key (element-type 'character) timeout deadline nodelay)
+  (declare (ignore nodelay))
   (declare (ignore deadline))
   (when timeout
     (warn "SOCKET-CONNECT timeout not supported in SBCL"))

Modified: usocket/trunk/backend/scl.lisp
==============================================================================
--- usocket/trunk/backend/scl.lisp	(original)
+++ usocket/trunk/backend/scl.lisp	Mon Jul 28 17:33:19 2008
@@ -28,7 +28,8 @@
                :socket socket
                :condition condition))))
 
-(defun socket-connect (host port &key (element-type 'character) timeout)
+(defun socket-connect (host port &key (element-type 'character) timeout nodelay)
+  (declare (ignore nodelay))
   (when timeout
     (warn "SOCKET-CONNECT timeout not supported in SCL"))
   (let* ((socket (with-mapped-conditions ()


From ehuelsmann at common-lisp.net  Mon Jul 28 21:34:04 2008
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Mon, 28 Jul 2008 17:34:04 -0400 (EDT)
Subject: [usocket-cvs] r398 - usocket/branches/hans
Message-ID: <20080728213404.8253A74345@common-lisp.net>

Author: ehuelsmann
Date: Mon Jul 28 17:34:04 2008
New Revision: 398

Removed:
   usocket/branches/hans/
Log:
Remove now-obsolete branch.


From ehuelsmann at common-lisp.net  Mon Jul 28 21:57:25 2008
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Mon, 28 Jul 2008 17:57:25 -0400 (EDT)
Subject: [usocket-cvs] r399 - in usocket/trunk: . backend
Message-ID: <20080728215725.BE51F1411A@common-lisp.net>

Author: ehuelsmann
Date: Mon Jul 28 17:57:23 2008
New Revision: 399

Modified:
   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/sbcl.lisp
   usocket/trunk/backend/scl.lisp
   usocket/trunk/condition.lisp
Log:
Signal to the caller whenever a certain feature is unavailable.

Modified: usocket/trunk/backend/allegro.lisp
==============================================================================
--- usocket/trunk/backend/allegro.lisp	(original)
+++ usocket/trunk/backend/allegro.lisp	Mon Jul 28 17:57:23 2008
@@ -49,10 +49,11 @@
       :text
     :binary))
 
-(defun socket-connect (host port &key (element-type 'character) timeout nodelay)
-  (declare (ignore nodelay))
-  (when timeout
-    (warn "SOCKET-CONNECT timeout not supported in Allegro CL"))
+(defun socket-connect (host port &key (element-type 'character) timeout
+                       (nodelay t)) ;; nodelay == t is the ACL default
+  (declare (ignorable timeout))
+  (unsupported 'timeout 'socket-connect)
+
   (let ((socket))
     (setf socket
           (with-mapped-conditions (socket)
@@ -60,10 +61,12 @@
                 (mp:with-timeout (timeout nil)
                   (socket:make-socket :remote-host (host-to-hostname host)
                                       :remote-port port
-                                      :format (to-format element-type)))
+                                      :format (to-format element-type)
+                                      :nodelay nodelay))
                 (socket:make-socket :remote-host (host-to-hostname host)
                                     :remote-port port
-                                    :format (to-format element-type)))))
+                                    :format (to-format element-type)
+                                    :nodelay nodelay))))
     (make-stream-socket :socket socket :stream socket)))
 
 

Modified: usocket/trunk/backend/armedbear.lisp
==============================================================================
--- usocket/trunk/backend/armedbear.lisp	(original)
+++ usocket/trunk/backend/armedbear.lisp	Mon Jul 28 17:57:23 2008
@@ -187,9 +187,10 @@
     (error (error 'unknown-error :socket socket :real-error condition))))
 
 (defun socket-connect (host port &key (element-type 'character) timeout nodelay)
-  (declare (ignore nodelay))
-  (when timeout
-    (warn "SOCKET-CONNECT timeout not supported in ABCL"))
+  (declare (ignore nodelay timeout))
+  (unsupported 'timeout 'socket-connect)
+  (unimplemented 'nodelay 'socket-connect)
+
   (let ((usock))
     (with-mapped-conditions (usock)
       (let* ((sock-addr (jdi:jcoerce

Modified: usocket/trunk/backend/clisp.lisp
==============================================================================
--- usocket/trunk/backend/clisp.lisp	(original)
+++ usocket/trunk/backend/clisp.lisp	Mon Jul 28 17:57:23 2008
@@ -56,9 +56,10 @@
                (signal usock-err :socket socket)))))))
 
 (defun socket-connect (host port &key (element-type 'character) timeout nodelay)
-  (declare (ignore nodelay))
-  (when timeout
-    (warn "SOCKET-CONNECT timeout not supported in CLISP"))
+  (declare (ignore nodelay timeout))
+  (unsupported 'nodelay 'socket-connect)
+  (unsupported 'timeout 'socket-connect)
+
   (let ((socket)
         (hostname (host-to-hostname host)))
     (with-mapped-conditions (socket)

Modified: usocket/trunk/backend/cmucl.lisp
==============================================================================
--- usocket/trunk/backend/cmucl.lisp	(original)
+++ usocket/trunk/backend/cmucl.lisp	Mon Jul 28 17:57:23 2008
@@ -51,9 +51,10 @@
                                                :condition condition))))
 
 (defun socket-connect (host port &key (element-type 'character) timeout nodelay)
-  (declare (ignore nodelay))
-  (when timeout
-    (warn "SOCKET-CONNECT timeout not supported in CMUCL"))
+  (declare (ignore nodelay timeout))
+  (unsupported 'nodelay 'socket-connect)
+  (unsupported 'timeout 'socket-connect)
+
   (let* ((socket))
     (setf socket
           (with-mapped-conditions (socket)

Modified: usocket/trunk/backend/lispworks.lisp
==============================================================================
--- usocket/trunk/backend/lispworks.lisp	(original)
+++ usocket/trunk/backend/lispworks.lisp	Mon Jul 28 17:57:23 2008
@@ -75,8 +75,8 @@
 
 (defun socket-connect (host port &key (element-type 'base-char) timeout nodelay)
   (declare (ignore nodelay))
-  (when timeout
-    (warn "SOCKET-CONNECT timeout not supported in Lispworks"))
+  (unsupported 'timeout 'socket-connect)
+  (unimplemented 'nodelay 'socket-connect)
   (let ((hostname (host-to-hostname host))
         (stream))
     (setf stream
@@ -93,6 +93,10 @@
                            (reuse-address nil reuse-address-supplied-p)
                            (backlog 5)
                            (element-type 'base-char))
+  #+lispworks4.1
+  (unsupported 'host 'socket-listen)
+  #+lispworks4.1
+  (unsupported 'backlog 'socket-listen)
   (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress))
          (comm::*use_so_reuseaddr* reuseaddress)
          (hostname (host-to-hostname host))

Modified: usocket/trunk/backend/sbcl.lisp
==============================================================================
--- usocket/trunk/backend/sbcl.lisp	(original)
+++ usocket/trunk/backend/sbcl.lisp	Mon Jul 28 17:57:23 2008
@@ -204,6 +204,9 @@
   (declare (ignore deadline))
   (when timeout
     (warn "SOCKET-CONNECT timeout not supported in SBCL"))
+  (unsupported 'deadline 'socket-connect)
+  (unsupported 'timeout 'socket-connect)
+  (unimplemented 'nodelay 'socket-connect)
   (let* ((socket (make-instance 'sb-bsd-sockets:inet-socket
                                 :type :stream :protocol :tcp))
          (stream (sb-bsd-sockets:socket-make-stream socket

Modified: usocket/trunk/backend/scl.lisp
==============================================================================
--- usocket/trunk/backend/scl.lisp	(original)
+++ usocket/trunk/backend/scl.lisp	Mon Jul 28 17:57:23 2008
@@ -29,9 +29,10 @@
                :condition condition))))
 
 (defun socket-connect (host port &key (element-type 'character) timeout nodelay)
-  (declare (ignore nodelay))
-  (when timeout
-    (warn "SOCKET-CONNECT timeout not supported in SCL"))
+  (declare (ignore nodelay timeout))
+  (unsupported 'nodelay 'socket-connect)
+  (unsupported 'timeout 'socket-connect)
+
   (let* ((socket (with-mapped-conditions ()
                   (ext:connect-to-inet-socket (host-to-hbo host) port
                                               :kind :stream)))

Modified: usocket/trunk/condition.lisp
==============================================================================
--- usocket/trunk/condition.lisp	(original)
+++ usocket/trunk/condition.lisp	Mon Jul 28 17:57:23 2008
@@ -190,3 +190,11 @@
     (2 . ns-try-again-condition)
     (3 . ns-no-recovery-error)))
 
+
+
+(defmacro unsupported (feature context &key minimum)
+  `(signal 'unsupported :feature ,feature
+    :context ,context :minimum ,minimum))
+
+(defmacro unimplemented (feature context)
+  `(signal 'unimplemented :feature ,feature :context ,context))
\ No newline at end of file


From ehuelsmann at common-lisp.net  Mon Jul 28 22:10:19 2008
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Mon, 28 Jul 2008 18:10:19 -0400 (EDT)
Subject: [usocket-cvs] r400 - usocket/trunk/backend
Message-ID: <20080728221019.17B165C189@common-lisp.net>

Author: ehuelsmann
Date: Mon Jul 28 18:10:18 2008
New Revision: 400

Modified:
   usocket/trunk/backend/sbcl.lisp
Log:
Implement some of the 'new hot stuff': nodelay.

Modified: usocket/trunk/backend/sbcl.lisp
==============================================================================
--- usocket/trunk/backend/sbcl.lisp	(original)
+++ usocket/trunk/backend/sbcl.lisp	Mon Jul 28 18:10:18 2008
@@ -199,14 +199,12 @@
                      (signal usock-cond :socket socket))))))
 
 
-(defun socket-connect (host port &key (element-type 'character) timeout deadline nodelay)
-  (declare (ignore nodelay))
-  (declare (ignore deadline))
-  (when timeout
-    (warn "SOCKET-CONNECT timeout not supported in SBCL"))
+(defun socket-connect (host port &key (element-type 'character)
+                       timeout deadline (nodelay t nodelay-specified))
+  (declare (ignore deadline timeout))
   (unsupported 'deadline 'socket-connect)
   (unsupported 'timeout 'socket-connect)
-  (unimplemented 'nodelay 'socket-connect)
+
   (let* ((socket (make-instance 'sb-bsd-sockets:inet-socket
                                 :type :stream :protocol :tcp))
          (stream (sb-bsd-sockets:socket-make-stream socket
@@ -217,6 +215,8 @@
          ;;###FIXME: The above line probably needs an :external-format
          (usocket (make-stream-socket :stream stream :socket socket))
          (ip (host-to-vector-quad host)))
+    (when nodelay-specified
+      (setf (sb-bsd-sockets:sockopt-tcp-nodelay socket) nodelay))
     (with-mapped-conditions (usocket)
       (sb-bsd-sockets:socket-connect socket ip port))
     usocket))


From ehuelsmann at common-lisp.net  Mon Jul 28 22:16:53 2008
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Mon, 28 Jul 2008 18:16:53 -0400 (EDT)
Subject: [usocket-cvs] r401 - usocket/trunk/backend
Message-ID: <20080728221653.58EF37E0B1@common-lisp.net>

Author: ehuelsmann
Date: Mon Jul 28 18:16:52 2008
New Revision: 401

Modified:
   usocket/trunk/backend/armedbear.lisp
Log:
Implement some of the 'new hot stuff': nodelay (ABCL).

Modified: usocket/trunk/backend/armedbear.lisp
==============================================================================
--- usocket/trunk/backend/armedbear.lisp	(original)
+++ usocket/trunk/backend/armedbear.lisp	Mon Jul 28 18:16:52 2008
@@ -186,26 +186,32 @@
   (typecase condition
     (error (error 'unknown-error :socket socket :real-error condition))))
 
-(defun socket-connect (host port &key (element-type 'character) timeout nodelay)
+(defun socket-connect (host port &key (element-type 'character)
+                       timeout deadline (nodelay nil nodelay-specified))
   (declare (ignore nodelay timeout))
   (unsupported 'timeout 'socket-connect)
-  (unimplemented 'nodelay 'socket-connect)
+  (unimplemented 'deadline 'socket-connect)
 
   (let ((usock))
     (with-mapped-conditions (usock)
       (let* ((sock-addr (jdi:jcoerce
                          (jdi:do-jnew-call "java.net.InetSocketAddress"
-                                           (host-to-hostname host)
-                                           (jdi:jcoerce port :int))
+                           (host-to-hostname host)
+                           (jdi:jcoerce port :int))
                          "java.net.SocketAddress"))
              (jchan (jdi:do-jstatic-call "java.nio.channels.SocketChannel"
-                                         "open" sock-addr))
+                      "open" sock-addr))
              (sock (jdi:do-jmethod-call jchan "socket")))
-         (setf usock
-               (make-stream-socket
-                :socket jchan
-                :stream (ext:get-socket-stream (jdi:jop-deref sock)
-                                               :element-type element-type)))))))
+        (when nodelay-specified
+          (jdi:do-jmethod-call sock "setTcpNoDelay"
+                               (if nodelay
+                                   (java:make-immediate-object t :boolean)
+                                   (java:make-immediate-object nil :boolean))))
+        (setf usock
+              (make-stream-socket
+               :socket jchan
+               :stream (ext:get-socket-stream (jdi:jop-deref sock)
+                                              :element-type element-type)))))))
 
 (defun socket-listen (host port
                            &key reuseaddress


From ehuelsmann at common-lisp.net  Tue Jul 29 06:08:39 2008
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Tue, 29 Jul 2008 02:08:39 -0400 (EDT)
Subject: [usocket-cvs] r402 - usocket/trunk/backend
Message-ID: <20080729060839.B29EA7E011@common-lisp.net>

Author: ehuelsmann
Date: Tue Jul 29 02:08:34 2008
New Revision: 402

Modified:
   usocket/trunk/backend/allegro.lisp
   usocket/trunk/backend/clisp.lisp
   usocket/trunk/backend/cmucl.lisp
   usocket/trunk/backend/lispworks.lisp
   usocket/trunk/backend/scl.lisp
Log:
Add DEADLINE everywhere.

Modified: usocket/trunk/backend/allegro.lisp
==============================================================================
--- usocket/trunk/backend/allegro.lisp	(original)
+++ usocket/trunk/backend/allegro.lisp	Tue Jul 29 02:08:34 2008
@@ -49,10 +49,12 @@
       :text
     :binary))
 
-(defun socket-connect (host port &key (element-type 'character) timeout
+(defun socket-connect (host port &key (element-type 'character)
+                       timeout deadline
                        (nodelay t)) ;; nodelay == t is the ACL default
   (declare (ignorable timeout))
   (unsupported 'timeout 'socket-connect)
+  (unsupported 'deadline 'socket-connect)
 
   (let ((socket))
     (setf socket

Modified: usocket/trunk/backend/clisp.lisp
==============================================================================
--- usocket/trunk/backend/clisp.lisp	(original)
+++ usocket/trunk/backend/clisp.lisp	Tue Jul 29 02:08:34 2008
@@ -55,10 +55,12 @@
                  (error usock-err :socket socket)
                (signal usock-err :socket socket)))))))
 
-(defun socket-connect (host port &key (element-type 'character) timeout nodelay)
+(defun socket-connect (host port &key (element-type 'character)
+                       timeout deadline nodelay)
   (declare (ignore nodelay timeout))
-  (unsupported 'nodelay 'socket-connect)
   (unsupported 'timeout 'socket-connect)
+  (unsupported 'deadline 'socket-connect)
+  (unsupported 'nodelay 'socket-connect)
 
   (let ((socket)
         (hostname (host-to-hostname host)))

Modified: usocket/trunk/backend/cmucl.lisp
==============================================================================
--- usocket/trunk/backend/cmucl.lisp	(original)
+++ usocket/trunk/backend/cmucl.lisp	Tue Jul 29 02:08:34 2008
@@ -50,10 +50,12 @@
                                                :socket socket
                                                :condition condition))))
 
-(defun socket-connect (host port &key (element-type 'character) timeout nodelay)
+(defun socket-connect (host port &key (element-type 'character)
+                       timeout deadline nodelay)
   (declare (ignore nodelay timeout))
-  (unsupported 'nodelay 'socket-connect)
   (unsupported 'timeout 'socket-connect)
+  (unsupported 'deadline 'socket-connect)
+  (unsupported 'nodelay 'socket-connect)
 
   (let* ((socket))
     (setf socket

Modified: usocket/trunk/backend/lispworks.lisp
==============================================================================
--- usocket/trunk/backend/lispworks.lisp	(original)
+++ usocket/trunk/backend/lispworks.lisp	Tue Jul 29 02:08:34 2008
@@ -73,9 +73,11 @@
                     (declare (ignore host port err-msg))
                     (raise-usock-err errno socket condition)))))
 
-(defun socket-connect (host port &key (element-type 'base-char) timeout nodelay)
+(defun socket-connect (host port &key (element-type 'base-char)
+                       timeout deadline nodelay)
   (declare (ignore nodelay))
   (unsupported 'timeout 'socket-connect)
+  (unsupported 'deadline 'socket-connect)
   (unimplemented 'nodelay 'socket-connect)
   (let ((hostname (host-to-hostname host))
         (stream))

Modified: usocket/trunk/backend/scl.lisp
==============================================================================
--- usocket/trunk/backend/scl.lisp	(original)
+++ usocket/trunk/backend/scl.lisp	Tue Jul 29 02:08:34 2008
@@ -28,9 +28,11 @@
                :socket socket
                :condition condition))))
 
-(defun socket-connect (host port &key (element-type 'character) timeout nodelay)
+(defun socket-connect (host port &key (element-type 'character)
+                       timeout deadline nodelay)
   (declare (ignore nodelay timeout))
   (unsupported 'nodelay 'socket-connect)
+  (unsupported 'deadline 'socket-connect)
   (unsupported 'timeout 'socket-connect)
 
   (let* ((socket (with-mapped-conditions ()


From ehuelsmann at common-lisp.net  Tue Jul 29 21:13:44 2008
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Tue, 29 Jul 2008 17:13:44 -0400 (EDT)
Subject: [usocket-cvs] r403 - usocket/trunk/backend
Message-ID: <20080729211344.4E6A84507D@common-lisp.net>

Author: ehuelsmann
Date: Tue Jul 29 17:13:43 2008
New Revision: 403

Modified:
   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/sbcl.lisp
   usocket/trunk/backend/scl.lisp
Log:
Make reporting of unimplemented and unsupported features dependent on their use.

Modified: usocket/trunk/backend/allegro.lisp
==============================================================================
--- usocket/trunk/backend/allegro.lisp	(original)
+++ usocket/trunk/backend/allegro.lisp	Tue Jul 29 17:13:43 2008
@@ -52,9 +52,8 @@
 (defun socket-connect (host port &key (element-type 'character)
                        timeout deadline
                        (nodelay t)) ;; nodelay == t is the ACL default
-  (declare (ignorable timeout))
-  (unsupported 'timeout 'socket-connect)
-  (unsupported 'deadline 'socket-connect)
+  (when timeout (unsupported 'timeout 'socket-connect))
+  (when deadline (unsupported 'deadline 'socket-connect))
 
   (let ((socket))
     (setf socket

Modified: usocket/trunk/backend/armedbear.lisp
==============================================================================
--- usocket/trunk/backend/armedbear.lisp	(original)
+++ usocket/trunk/backend/armedbear.lisp	Tue Jul 29 17:13:43 2008
@@ -189,8 +189,7 @@
 (defun socket-connect (host port &key (element-type 'character)
                        timeout deadline (nodelay nil nodelay-specified))
   (declare (ignore nodelay timeout))
-  (unsupported 'timeout 'socket-connect)
-  (unimplemented 'deadline 'socket-connect)
+  (when deadline (unsupported 'deadline 'socket-connect))
 
   (let ((usock))
     (with-mapped-conditions (usock)
@@ -207,6 +206,9 @@
                                (if nodelay
                                    (java:make-immediate-object t :boolean)
                                    (java:make-immediate-object nil :boolean))))
+        (when timeout
+          (jdi:do-jmethod-call sock "setSoTimeout"
+                                    (truncate (* 1000 timeout))))
         (setf usock
               (make-stream-socket
                :socket jchan

Modified: usocket/trunk/backend/clisp.lisp
==============================================================================
--- usocket/trunk/backend/clisp.lisp	(original)
+++ usocket/trunk/backend/clisp.lisp	Tue Jul 29 17:13:43 2008
@@ -56,11 +56,11 @@
                (signal usock-err :socket socket)))))))
 
 (defun socket-connect (host port &key (element-type 'character)
-                       timeout deadline nodelay)
-  (declare (ignore nodelay timeout))
-  (unsupported 'timeout 'socket-connect)
-  (unsupported 'deadline 'socket-connect)
-  (unsupported 'nodelay 'socket-connect)
+                       timeout deadline (nodelay t nodelay-specified))
+  (declare (ignore nodelay))
+  (when timeout (unsupported 'timeout 'socket-connect))
+  (when deadline (unsupported 'deadline 'socket-connect))
+  (when nodelay-specified (unsupported 'nodelay 'socket-connect))
 
   (let ((socket)
         (hostname (host-to-hostname host)))

Modified: usocket/trunk/backend/cmucl.lisp
==============================================================================
--- usocket/trunk/backend/cmucl.lisp	(original)
+++ usocket/trunk/backend/cmucl.lisp	Tue Jul 29 17:13:43 2008
@@ -51,11 +51,11 @@
                                                :condition condition))))
 
 (defun socket-connect (host port &key (element-type 'character)
-                       timeout deadline nodelay)
-  (declare (ignore nodelay timeout))
-  (unsupported 'timeout 'socket-connect)
-  (unsupported 'deadline 'socket-connect)
-  (unsupported 'nodelay 'socket-connect)
+                       timeout deadline (nodelay t nodelay-specified))
+  (declare (ignore nodelay))
+  (when timeout (unsupported 'timeout 'socket-connect))
+  (when deadline (unsupported 'deadline 'socket-connect))
+  (when nodelay-specified (unsupported 'nodelay 'socket-connect))
 
   (let* ((socket))
     (setf socket

Modified: usocket/trunk/backend/lispworks.lisp
==============================================================================
--- usocket/trunk/backend/lispworks.lisp	(original)
+++ usocket/trunk/backend/lispworks.lisp	Tue Jul 29 17:13:43 2008
@@ -74,17 +74,23 @@
                     (raise-usock-err errno socket condition)))))
 
 (defun socket-connect (host port &key (element-type 'base-char)
-                       timeout deadline nodelay)
-  (declare (ignore nodelay))
-  (unsupported 'timeout 'socket-connect)
-  (unsupported 'deadline 'socket-connect)
-  (unimplemented 'nodelay 'socket-connect)
+                       timeout deadline (nodelay t nodelay-specified))
+  (declare (ignorable nodelay))
+  (when timeout (unimplemented 'timeout 'socket-connect))
+  (when deadline (unsupported 'deadline 'socket-connect "LispWorks 5.1"))
+  
+  #+(and (not lispworks4) (not lispworks5.0))
+  (when nodelay-specified (unimplemented 'nodelay 'socket-connect))
+
   (let ((hostname (host-to-hostname host))
         (stream))
     (setf stream
           (with-mapped-conditions ()
              (comm:open-tcp-stream hostname port
-                                   :element-type element-type)))
+                                   :element-type element-type
+                                   #+(and (not lispworks4) (not lispworks5.0))
+                                   #+(and (not lispworks4) (not lispworks5.0))
+                                   :nodelay nodelay)))
     (if stream
         (make-stream-socket :socket (comm:socket-stream-socket stream)
                             :stream stream)
@@ -96,9 +102,10 @@
                            (backlog 5)
                            (element-type 'base-char))
   #+lispworks4.1
-  (unsupported 'host 'socket-listen)
+  (unsupported 'host 'socket-listen "LispWorks 4.0 or newer than 4.1")
   #+lispworks4.1
-  (unsupported 'backlog 'socket-listen)
+  (unsupported 'backlog 'socket-listen "LispWorks 4.0 or newer than 4.1")
+
   (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress))
          (comm::*use_so_reuseaddr* reuseaddress)
          (hostname (host-to-hostname host))

Modified: usocket/trunk/backend/sbcl.lisp
==============================================================================
--- usocket/trunk/backend/sbcl.lisp	(original)
+++ usocket/trunk/backend/sbcl.lisp	Tue Jul 29 17:13:43 2008
@@ -201,9 +201,8 @@
 
 (defun socket-connect (host port &key (element-type 'character)
                        timeout deadline (nodelay t nodelay-specified))
-  (declare (ignore deadline timeout))
-  (unsupported 'deadline 'socket-connect)
-  (unsupported 'timeout 'socket-connect)
+  (when deadline (unsupported 'deadline 'socket-connect))
+  (when timeout (unsupported 'timeout 'socket-connect))
 
   (let* ((socket (make-instance 'sb-bsd-sockets:inet-socket
                                 :type :stream :protocol :tcp))

Modified: usocket/trunk/backend/scl.lisp
==============================================================================
--- usocket/trunk/backend/scl.lisp	(original)
+++ usocket/trunk/backend/scl.lisp	Tue Jul 29 17:13:43 2008
@@ -29,11 +29,11 @@
                :condition condition))))
 
 (defun socket-connect (host port &key (element-type 'character)
-                       timeout deadline nodelay)
-  (declare (ignore nodelay timeout))
-  (unsupported 'nodelay 'socket-connect)
-  (unsupported 'deadline 'socket-connect)
-  (unsupported 'timeout 'socket-connect)
+                       timeout deadline (nodelay t nodelay-specified))
+  (declare (ignore nodelay))
+  (when nodelay-specified (unsupported 'nodelay 'socket-connect))
+  (when deadline (unsupported 'deadline 'socket-connect))
+  (when timeout (unsupported 'timeout 'socket-connect))
 
   (let* ((socket (with-mapped-conditions ()
                   (ext:connect-to-inet-socket (host-to-hbo host) port


From ehuelsmann at common-lisp.net  Tue Jul 29 21:18:10 2008
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Tue, 29 Jul 2008 17:18:10 -0400 (EDT)
Subject: [usocket-cvs] r404 - usocket/trunk/backend
Message-ID: <20080729211810.B20C25C18D@common-lisp.net>

Author: ehuelsmann
Date: Tue Jul 29 17:18:10 2008
New Revision: 404

Modified:
   usocket/trunk/backend/armedbear.lisp
Log:
Remove invalid IGNORE declaration.

Modified: usocket/trunk/backend/armedbear.lisp
==============================================================================
--- usocket/trunk/backend/armedbear.lisp	(original)
+++ usocket/trunk/backend/armedbear.lisp	Tue Jul 29 17:18:10 2008
@@ -188,7 +188,6 @@
 
 (defun socket-connect (host port &key (element-type 'character)
                        timeout deadline (nodelay nil nodelay-specified))
-  (declare (ignore nodelay timeout))
   (when deadline (unsupported 'deadline 'socket-connect))
 
   (let ((usock))


From ehuelsmann at common-lisp.net  Wed Jul 30 19:26:56 2008
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Wed, 30 Jul 2008 15:26:56 -0400 (EDT)
Subject: [usocket-cvs] r405 - usocket/trunk/backend
Message-ID: <20080730192656.2C0B512064@common-lisp.net>

Author: ehuelsmann
Date: Wed Jul 30 15:26:46 2008
New Revision: 405

Modified:
   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
   usocket/trunk/backend/scl.lisp
Log:
Implement local-host and local-port binding for SOCKET-CONNECT.

Modified: usocket/trunk/backend/allegro.lisp
==============================================================================
--- usocket/trunk/backend/allegro.lisp	(original)
+++ usocket/trunk/backend/allegro.lisp	Wed Jul 30 15:26:46 2008
@@ -51,7 +51,8 @@
 
 (defun socket-connect (host port &key (element-type 'character)
                        timeout deadline
-                       (nodelay t)) ;; nodelay == t is the ACL default
+                       (nodelay t) ;; nodelay == t is the ACL default
+                       local-host local-port)
   (when timeout (unsupported 'timeout 'socket-connect))
   (when deadline (unsupported 'deadline 'socket-connect))
 
@@ -62,10 +63,14 @@
                 (mp:with-timeout (timeout nil)
                   (socket:make-socket :remote-host (host-to-hostname host)
                                       :remote-port port
+                                      :local-host (when local-host (host-to-hostname local-host))
+                                      :local-port local-port
                                       :format (to-format element-type)
                                       :nodelay nodelay))
                 (socket:make-socket :remote-host (host-to-hostname host)
                                     :remote-port port
+                                    :local-host local-host
+                                    :local-port local-port
                                     :format (to-format element-type)
                                     :nodelay nodelay))))
     (make-stream-socket :socket socket :stream socket)))

Modified: usocket/trunk/backend/armedbear.lisp
==============================================================================
--- usocket/trunk/backend/armedbear.lisp	(original)
+++ usocket/trunk/backend/armedbear.lisp	Wed Jul 30 15:26:46 2008
@@ -187,8 +187,12 @@
     (error (error 'unknown-error :socket socket :real-error condition))))
 
 (defun socket-connect (host port &key (element-type 'character)
-                       timeout deadline (nodelay nil nodelay-specified))
+                       timeout deadline (nodelay nil nodelay-specified)
+                       local-host local-port)
   (when deadline (unsupported 'deadline 'socket-connect))
+  (when (or local-host local-port)
+    (unimplemented 'local-host 'socket-connect)
+    (unimplemented 'local-port 'socket-connect))
 
   (let ((usock))
     (with-mapped-conditions (usock)

Modified: usocket/trunk/backend/clisp.lisp
==============================================================================
--- usocket/trunk/backend/clisp.lisp	(original)
+++ usocket/trunk/backend/clisp.lisp	Wed Jul 30 15:26:46 2008
@@ -56,11 +56,15 @@
                (signal usock-err :socket socket)))))))
 
 (defun socket-connect (host port &key (element-type 'character)
-                       timeout deadline (nodelay t nodelay-specified))
+                       timeout deadline (nodelay t nodelay-specified)
+                       local-host local-port)
   (declare (ignore nodelay))
   (when timeout (unsupported 'timeout 'socket-connect))
   (when deadline (unsupported 'deadline 'socket-connect))
   (when nodelay-specified (unsupported 'nodelay 'socket-connect))
+  (when (or local-host local-port)
+     (unsupported 'local-host 'socket-connect)
+     (unsupported 'local-port 'socket-connect))
 
   (let ((socket)
         (hostname (host-to-hostname host)))

Modified: usocket/trunk/backend/cmucl.lisp
==============================================================================
--- usocket/trunk/backend/cmucl.lisp	(original)
+++ usocket/trunk/backend/cmucl.lisp	Wed Jul 30 15:26:46 2008
@@ -51,11 +51,15 @@
                                                :condition condition))))
 
 (defun socket-connect (host port &key (element-type 'character)
-                       timeout deadline (nodelay t nodelay-specified))
+                       timeout deadline (nodelay t nodelay-specified)
+                       local-host local-port)
   (declare (ignore nodelay))
   (when timeout (unsupported 'timeout 'socket-connect))
   (when deadline (unsupported 'deadline 'socket-connect))
   (when nodelay-specified (unsupported 'nodelay 'socket-connect))
+  (when (or local-host local-port)
+     (unsupported 'local-host 'socket-connect)
+     (unsupported 'local-port 'socket-connect))
 
   (let* ((socket))
     (setf socket

Modified: usocket/trunk/backend/lispworks.lisp
==============================================================================
--- usocket/trunk/backend/lispworks.lisp	(original)
+++ usocket/trunk/backend/lispworks.lisp	Wed Jul 30 15:26:46 2008
@@ -81,6 +81,10 @@
   
   #+(and (not lispworks4) (not lispworks5.0))
   (when nodelay-specified (unimplemented 'nodelay 'socket-connect))
+  #+lispworks4
+  (when (or local-host local-port)
+     (unsupported 'local-host 'socket-connect "LispWorks 5.0+ (verified)")
+     (unsupported 'local-port 'socket-connect "LispWorks 5.0+ (verified)"))
 
   (let ((hostname (host-to-hostname host))
         (stream))
@@ -88,6 +92,10 @@
           (with-mapped-conditions ()
              (comm:open-tcp-stream hostname port
                                    :element-type element-type
+                                   #-lispworks4 #-lispworks4
+                                   #-lispworks4 #-lispworks4
+                                   :local-address (when local-host (host-to-hostname local-host))
+                                   :local-port local-port
                                    #+(and (not lispworks4) (not lispworks5.0))
                                    #+(and (not lispworks4) (not lispworks5.0))
                                    :nodelay nodelay)))

Modified: usocket/trunk/backend/openmcl.lisp
==============================================================================
--- usocket/trunk/backend/openmcl.lisp	(original)
+++ usocket/trunk/backend/openmcl.lisp	Wed Jul 30 15:26:46 2008
@@ -74,11 +74,14 @@
       :text
     :binary))
 
-(defun socket-connect (host port &key (element-type 'character) timeout deadline nodelay)
+(defun socket-connect (host port &key (element-type 'character) timeout deadline nodelay
+                       local-host local-port)
   (with-mapped-conditions ()
     (let ((mcl-sock
            (openmcl-socket:make-socket :remote-host (host-to-hostname host)
                                        :remote-port port
+                                       :local-host (when local-host (host-to-hostname local-host))
+                                       :local-port local-port
                                        :format (to-format element-type)
                                        :deadline deadline
                                        :nodelay nodelay

Modified: usocket/trunk/backend/sbcl.lisp
==============================================================================
--- usocket/trunk/backend/sbcl.lisp	(original)
+++ usocket/trunk/backend/sbcl.lisp	Wed Jul 30 15:26:46 2008
@@ -200,7 +200,8 @@
 
 
 (defun socket-connect (host port &key (element-type 'character)
-                       timeout deadline (nodelay t nodelay-specified))
+                       timeout deadline (nodelay t nodelay-specified)
+                       local-host local-port)
   (when deadline (unsupported 'deadline 'socket-connect))
   (when timeout (unsupported 'timeout 'socket-connect))
 
@@ -216,6 +217,9 @@
          (ip (host-to-vector-quad host)))
     (when nodelay-specified
       (setf (sb-bsd-sockets:sockopt-tcp-nodelay socket) nodelay))
+    (when (or local-host local-port)
+      (sb-bsd-sockets:bind socket (host-to-vector-quad (or local-host *wildcard-host*))
+                           (or local-port *auto-port*)))
     (with-mapped-conditions (usocket)
       (sb-bsd-sockets:socket-connect socket ip port))
     usocket))

Modified: usocket/trunk/backend/scl.lisp
==============================================================================
--- usocket/trunk/backend/scl.lisp	(original)
+++ usocket/trunk/backend/scl.lisp	Wed Jul 30 15:26:46 2008
@@ -29,11 +29,15 @@
                :condition condition))))
 
 (defun socket-connect (host port &key (element-type 'character)
-                       timeout deadline (nodelay t nodelay-specified))
+                       timeout deadline (nodelay t nodelay-specified)
+                       local-host local-port)
   (declare (ignore nodelay))
   (when nodelay-specified (unsupported 'nodelay 'socket-connect))
   (when deadline (unsupported 'deadline 'socket-connect))
   (when timeout (unsupported 'timeout 'socket-connect))
+  (when (or local-host local-port)
+     (unsupported 'local-host 'socket-connect)
+     (unsupported 'local-port 'socket-connect))
 
   (let* ((socket (with-mapped-conditions ()
                   (ext:connect-to-inet-socket (host-to-hbo host) port


From ehuelsmann at common-lisp.net  Wed Jul 30 20:56:50 2008
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Wed, 30 Jul 2008 16:56:50 -0400 (EDT)
Subject: [usocket-cvs] r406 - usocket/trunk/backend
Message-ID: <20080730205650.9AA2C47147@common-lisp.net>

Author: ehuelsmann
Date: Wed Jul 30 16:56:49 2008
New Revision: 406

Modified:
   usocket/trunk/backend/lispworks.lisp
Log:
Fix LispWorks local-host/-port.

Modified: usocket/trunk/backend/lispworks.lisp
==============================================================================
--- usocket/trunk/backend/lispworks.lisp	(original)
+++ usocket/trunk/backend/lispworks.lisp	Wed Jul 30 16:56:49 2008
@@ -74,17 +74,18 @@
                     (raise-usock-err errno socket condition)))))
 
 (defun socket-connect (host port &key (element-type 'base-char)
-                       timeout deadline (nodelay t nodelay-specified))
+                       timeout deadline (nodelay t nodelay-specified)
+                       local-host local-port)
   (declare (ignorable nodelay))
   (when timeout (unimplemented 'timeout 'socket-connect))
-  (when deadline (unsupported 'deadline 'socket-connect "LispWorks 5.1"))
+  (when deadline (unsupported 'deadline 'socket-connect :minimum "LispWorks 5.1"))
   
   #+(and (not lispworks4) (not lispworks5.0))
   (when nodelay-specified (unimplemented 'nodelay 'socket-connect))
   #+lispworks4
   (when (or local-host local-port)
-     (unsupported 'local-host 'socket-connect "LispWorks 5.0+ (verified)")
-     (unsupported 'local-port 'socket-connect "LispWorks 5.0+ (verified)"))
+     (unsupported 'local-host 'socket-connect :minimum "LispWorks 5.0+ (verified)")
+     (unsupported 'local-port 'socket-connect :minimum "LispWorks 5.0+ (verified)"))
 
   (let ((hostname (host-to-hostname host))
         (stream))
@@ -110,9 +111,9 @@
                            (backlog 5)
                            (element-type 'base-char))
   #+lispworks4.1
-  (unsupported 'host 'socket-listen "LispWorks 4.0 or newer than 4.1")
+  (unsupported 'host 'socket-listen :minimum "LispWorks 4.0 or newer than 4.1")
   #+lispworks4.1
-  (unsupported 'backlog 'socket-listen "LispWorks 4.0 or newer than 4.1")
+  (unsupported 'backlog 'socket-listen :minimum "LispWorks 4.0 or newer than 4.1")
 
   (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress))
          (comm::*use_so_reuseaddr* reuseaddress)


From hhubner at common-lisp.net  Sat Jul 19 12:00:08 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Sat, 19 Jul 2008 08:00:08 -0400 (EDT)
Subject: [usocket-cvs] r370 - in usocket/branches/hans: . backend doc notes
	test
Message-ID: <20080719120008.B79987A000@common-lisp.net>

Author: hhubner
Date: Sat Jul 19 08:00:01 2008
New Revision: 370

Added:
   usocket/branches/hans/   (props changed)
   usocket/branches/hans/LICENSE
   usocket/branches/hans/Makefile
   usocket/branches/hans/README
   usocket/branches/hans/TODO
   usocket/branches/hans/backend/
   usocket/branches/hans/backend/allegro.lisp
   usocket/branches/hans/backend/armedbear.lisp
   usocket/branches/hans/backend/clisp.lisp
   usocket/branches/hans/backend/cmucl.lisp
   usocket/branches/hans/backend/lispworks.lisp
   usocket/branches/hans/backend/openmcl.lisp
   usocket/branches/hans/backend/sbcl.lisp
   usocket/branches/hans/backend/scl.lisp
   usocket/branches/hans/condition.lisp
   usocket/branches/hans/doc/
   usocket/branches/hans/doc/backends.txt
   usocket/branches/hans/doc/design.txt
   usocket/branches/hans/notes/
   usocket/branches/hans/notes/abcl-socket.txt
   usocket/branches/hans/notes/active-sockets-apis.txt
   usocket/branches/hans/notes/address-apis.txt
   usocket/branches/hans/notes/allegro-socket.txt
   usocket/branches/hans/notes/clisp-sockets.txt
   usocket/branches/hans/notes/cmucl-sockets.txt
   usocket/branches/hans/notes/errors.txt
   usocket/branches/hans/notes/lw-sockets.txt
   usocket/branches/hans/notes/openmcl-sockets.txt
   usocket/branches/hans/notes/sb-bsd-sockets.txt
   usocket/branches/hans/notes/usock-sockets.txt
   usocket/branches/hans/package.lisp
   usocket/branches/hans/run-usocket-tests.sh   (contents, props changed)
   usocket/branches/hans/test/
   usocket/branches/hans/test/abcl.conf.in
   usocket/branches/hans/test/allegro.conf.in
   usocket/branches/hans/test/clisp.conf.in
   usocket/branches/hans/test/cmucl.conf.in
   usocket/branches/hans/test/package.lisp
   usocket/branches/hans/test/sbcl.conf.in
   usocket/branches/hans/test/test-usocket.lisp
   usocket/branches/hans/test/usocket-test.asd
   usocket/branches/hans/test/your-lisp.conf.in
   usocket/branches/hans/usocket.asd
   usocket/branches/hans/usocket.lisp
Log:
Update from bknr repository.


Added: usocket/branches/hans/LICENSE
==============================================================================
--- (empty file)
+++ usocket/branches/hans/LICENSE	Sat Jul 19 08:00:01 2008
@@ -0,0 +1,24 @@
+(This is the MIT / X Consortium license as taken from 
+ http://www.opensource.org/licenses/mit-license.html)
+
+Copyright (c) 2003 Erik Enge
+Copyright (c) 2006-2007 Erik Huelsmann
+
+Permission is hereby granted, free of charge, to any person obtaining
+a copy of this software and associated documentation files (the
+"Software"), to deal in the Software without restriction, including
+without limitation the rights to use, copy, modify, merge, publish,
+distribute, sublicense, and/or sell copies of the Software, and to
+permit persons to whom the Software is furnished to do so, subject to
+the following conditions:
+
+The above copyright notice and this permission notice shall be
+included in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

Added: usocket/branches/hans/Makefile
==============================================================================
--- (empty file)
+++ usocket/branches/hans/Makefile	Sat Jul 19 08:00:01 2008
@@ -0,0 +1,9 @@
+# $Id: Makefile 80 2006-02-12 10:09:49Z ehuelsmann $
+# $URL: svn://common-lisp.net/project/usocket/svn/usocket/branches/hans/Makefile $
+
+clean:
+	find -name -o -name "*~" -o -name "*.err" -o -name "*.x86f" -o -name "*.lib" -o -name "*.fas" -o -name "*.fasl" -o -name "*.faslmt" -o -name "*.ufsl" -o -name "*.abcl" | xargs rm
+
+commit:
+	make clean; svn up; svn ci
+

Added: usocket/branches/hans/README
==============================================================================
--- (empty file)
+++ usocket/branches/hans/README	Sat Jul 19 08:00:01 2008
@@ -0,0 +1,175 @@
+                                                                -*- text -*-
+
+$Id: README 334 2008-04-23 21:24:15Z hhubner $
+
+Content
+=======
+
+ * Introduction
+ * Remarks on licensing
+ * Non-support for :external-format
+ * API definition
+ * Test suite
+ * Known problems
+
+Introduction
+============
+This is the usocket Common Lisp sockets library: a library to bring
+sockets access to the broadest of common lisp implementations as possible.
+
+
+The library currently supports:
+
+ - SBCL
+ - CMUCL
+ - ArmedBear (post feb 11th, 2006 CVS or 0.0.10 and higher)
+ - clisp
+ - Allegro Common Lisp
+ - LispWorks
+ - OpenMCL
+ - ECL
+ - Scieneer Common Lisp
+ - <Your favorite Common Lisp here?>
+
+If your favorite common lisp misses in the list above, please contact
+usocket-devel at common-lisp.net and submit a request.  Please include
+references to available sockets functions in your lisp implementation.
+
+The library has been ASDF (http://cliki.net/ASDF) enabled, meaning
+that you can tar up a checkout and use that to ASDF-INSTALL:INSTALL
+the package in your system package site.  (Or use your usual ASDF
+tricks to use the checkout directly.)
+
+
+Remarks on licensing
+====================
+
+Even though the source code has an MIT style license attached to it,
+when compiling this code with some of the supported lisp implementations
+you may not end up with an MIT style binary version due to the licensing
+of the implementations themselves.  ECL is such an example and - when
+it will become supported - GCL is like that too.
+
+
+Non-support of :external-format
+===============================
+
+Because of its definition in the hyperspec, there's no common
+external-format between lisp implementations: every vendor has chosen
+a different way to solve the problem of newline translation or
+character set recoding.
+
+Because there's no way to avoid platform specific code in the application
+when using external-format, the purpose of a portability layer gets
+defeated.  So, for now, usocket doesn't support external-format.
+
+The workaround to get reasonably portable external-format support is to
+layer a flexi-stream (from flexi-streams) on top of a usocket stream.
+
+
+API definition
+==============
+
+ - usocket (class)
+ - stream-usocket (class; usocket derivative)
+ - stream-server-usocket (class; usocket derivative)
+ - socket-connect (function) [ to create an active/connected socket ]
+    socket-connect host port &key element-type
+      where `host' is a vectorized ip
+                      or a string representation of a dotted ip address
+                      or a hostname for lookup in the DNS system
+ - socket-listen (function) [ to create a passive/listening socket ]
+     socket-listen host port &key reuseaddress backlog element-type
+       where `host' has the same definition as above
+ - socket-accept (method) [ to create an active/connected socket ]
+     socket-accept socket &key element-type
+       returns (server side) a connected socket derived from a
+       listening/passive socket.
+ - socket-close (method)
+    socket-close socket
+      where socket a previously returned socket
+ - socket (usocket slot accessor),
+      the internal/implementation defined socket representation
+ - socket-stream (usocket slot accessor),
+    socket-stream socket
+      the return value of which satisfies the normal stream interface
+
+
+Errors:
+ - address-in-use-error
+ - address-not-available-error
+ - bad-file-descriptor-error
+ - connection-refused-error
+ - connection-aborted-error
+ - connection-reset-error
+ - invalid-argument-error
+ - no-buffers-error
+ - operation-not-supported-error
+ - operation-not-permitted-error
+ - protocol-not-supported-error
+ - socket-type-not-supported-error
+ - network-unreachable-error
+ - network-down-error
+ - network-reset-error
+ - host-down-error
+ - host-unreachable-error
+ - shutdown-error
+ - timeout-error
+ - unkown-error
+
+Non-fatal conditions:
+ - interrupted-condition
+ - unkown-condition
+
+(for a description of the API methods and functions see
+  http://common-lisp.net/project/usocket/api-docs.shtml.)
+
+Test suite
+==========
+
+The test suite unfortunately isn't mature enough yet to run without
+some manual configuration.  Several elements are required which are
+hard to programatically detect.  Please adjust the test file before
+running the tests, for these variables:
+
+- +non-existing-host+: The stringified IP address of a host on the
+     same subnet.  No physical host may be present.
+- +unused-local-port+: A port number of a port not in use on the
+     machine the tests run on.
+- +common-lisp-net+: A vector with 4 integer elements which make up
+     an IP address. This must be the IP "common-lisp.net" resolves to.
+
+
+Known problems
+==============
+- CMUCL error reporting wrt sockets raises only simple-errors
+  meaning there's no way to tell different error conditions apart.
+  All errors are mapped to unknown-error on CMUCL.
+
+- The ArmedBear backend doesn't do any error mapping (yet). Java
+  defines exceptions at the wrong level (IMO), since the exception
+  reported bares a relation to the function failing, not the actual
+  error that occurred: for example 'Address already in use' (when
+  creating a passive socket) is reported as a BindException with
+  an error text of 'Address already in use'. There's no way to sanely
+  map 'BindException' to a meaningfull error in usocket. [This does not
+  mean the backend should not at least map to 'unknown-error'!]
+
+- When using the library with ECL, you need the C compiler installed
+  to be able to compile and load the Foreign Function Interface.
+  Not all ECL targets support DFFI yet, so on some targets this would
+  be the case anyway.  By depending on this technique, usocket can
+  reuse the FFI code on all platforms (including Windows).  This benefit
+  currently outweighs the additional requirement. (hey, it's *Embeddable*
+  Common Lisp, so, you probably wanted to embed it all along, right?)
+
+- LispWorks has a bug(?) in wait-for-input-streams which make it
+  unsuited for waiting for input on stream socket servers, making it
+  necessary to resort to different  means.  With the absence of notice-fd
+  on Windows, that currenty leaves Windows unsupported.
+
+- SBCL can't use select() on Windows because it would mean porting
+  the FD_* macros and the select structures which I'm not sure
+  is the right way yet (if I need to write custom Win32 code anyway...)
+  The alternative is to use WSAEventSelect() and friends (which don't
+  have a limited number of sockets).

Added: usocket/branches/hans/TODO
==============================================================================
--- (empty file)
+++ usocket/branches/hans/TODO	Sat Jul 19 08:00:01 2008
@@ -0,0 +1,18 @@
+
+- 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.
+
+- Add INET6 support.
+
+For more TODO items, see http://trac.common-lisp.net/usocket/report.

Added: usocket/branches/hans/backend/allegro.lisp
==============================================================================
--- (empty file)
+++ usocket/branches/hans/backend/allegro.lisp	Sat Jul 19 08:00:01 2008
@@ -0,0 +1,147 @@
+;;;; $Id: allegro.lisp 335 2008-04-23 21:29:50Z hhubner $
+;;;; $URL: svn://common-lisp.net/project/usocket/svn/usocket/branches/hans/backend/allegro.lisp $
+
+;;;; See LICENSE for licensing information.
+
+(in-package :usocket)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (require :sock)
+  ;; for wait-for-input:
+  (require :process)
+  ;; note: the line below requires ACL 6.2+
+  (require :osi))
+
+(defun get-host-name ()
+  ;; note: the line below requires ACL 7.0+ to actually *work* on windows
+  (excl.osi:gethostname))
+
+(defparameter +allegro-identifier-error-map+
+  '((:address-in-use . address-in-use-error)
+    (:address-not-available . address-not-available-error)
+    (:network-down . network-down-error)
+    (:network-reset . network-reset-error)
+    (:network-unreachable . network-unreachable-error)
+    (:connection-aborted . connection-aborted-error)
+    (:connection-reset . connection-reset-error)
+    (:no-buffer-space . no-buffers-error)
+    (:shutdown . shutdown-error)
+    (:connection-timed-out . timeout-error)
+    (:connection-refused . connection-refused-error)
+    (:host-down . host-down-error)
+    (:host-unreachable . host-unreachable-error)))
+
+(defun handle-condition (condition &optional (socket nil))
+  "Dispatch correct usocket condition."
+  (typecase condition
+    (excl:socket-error
+     (let ((usock-err
+            (cdr (assoc (excl:stream-error-identifier condition)
+                        +allegro-identifier-error-map+))))
+       (if usock-err
+           (error usock-err :socket socket)
+         (error 'unknown-error
+                :real-error condition
+                :socket socket))))))
+
+(defun to-format (element-type)
+  (if (subtypep element-type 'character)
+      :text
+    :binary))
+
+(defun socket-connect (host port &key (element-type 'character) timeout nodelay)
+  (declare (ignore nodelay))
+  (when timeout
+    (warn "SOCKET-CONNECT timeout not supported in Allegro CL"))
+  (let ((socket))
+    (setf socket
+          (with-mapped-conditions (socket)
+             (socket:make-socket :remote-host (host-to-hostname host)
+                                 :remote-port port
+                                 :format (to-format element-type))))
+    (make-stream-socket :socket socket :stream socket)))
+
+
+;; One socket close method is sufficient,
+;; because socket-streams are also sockets.
+(defmethod socket-close ((usocket usocket))
+  "Close socket."
+  (with-mapped-conditions (usocket)
+    (close (socket usocket))))
+
+(defun socket-listen (host port
+                           &key reuseaddress
+                           (reuse-address nil reuse-address-supplied-p)
+                           (backlog 5)
+                           (element-type 'character))
+  ;; Allegro and OpenMCL socket interfaces bear very strong resemblence
+  ;; whatever you change here, change it also for OpenMCL
+  (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress))
+         (sock (with-mapped-conditions ()
+                 (apply #'socket:make-socket
+                        (append (list :connect :passive
+                                      :reuse-address reuseaddress
+                                      :local-port port
+                                      :backlog backlog
+                                      :format (to-format element-type)
+                                      ;; allegro now ignores :format
+                                      )
+                                (when (ip/= host *wildcard-host*)
+                                  (list :local-host host)))))))
+    (make-stream-server-socket sock :element-type element-type)))
+
+(defmethod socket-accept ((socket stream-server-usocket) &key element-type)
+  (declare (ignore element-type)) ;; allegro streams are multivalent
+  (let ((stream-sock
+         (with-mapped-conditions (socket)
+            (socket:accept-connection (socket socket)))))
+    (make-stream-socket :socket stream-sock :stream stream-sock)))
+
+(defmethod get-local-address ((usocket usocket))
+  (hbo-to-vector-quad (socket:local-host (socket usocket))))
+
+(defmethod get-peer-address ((usocket stream-usocket))
+  (hbo-to-vector-quad (socket:remote-host (socket usocket))))
+
+(defmethod get-local-port ((usocket usocket))
+  (socket:local-port (socket usocket)))
+
+(defmethod get-peer-port ((usocket stream-usocket))
+  (socket:remote-port (socket usocket)))
+
+(defmethod get-local-name ((usocket usocket))
+  (values (get-local-address usocket)
+          (get-local-port usocket)))
+
+(defmethod get-peer-name ((usocket stream-usocket))
+  (values (get-peer-address usocket)
+          (get-peer-port usocket)))
+
+
+(defun get-host-by-address (address)
+  (with-mapped-conditions ()
+    (socket:ipaddr-to-hostname (host-to-hbo address))))
+
+(defun get-hosts-by-name (name)
+  ;;###FIXME: ACL has the acldns module which returns all A records
+  ;; only problem: it doesn't fall back to tcp (from udp) if the returned
+  ;; structure is too long.
+  (with-mapped-conditions ()
+    (list (hbo-to-vector-quad (socket:lookup-hostname
+                               (host-to-hostname name))))))
+
+(defun wait-for-input-internal (sockets &key timeout)
+  (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))))

Added: usocket/branches/hans/backend/armedbear.lisp
==============================================================================
--- (empty file)
+++ usocket/branches/hans/backend/armedbear.lisp	Sat Jul 19 08:00:01 2008
@@ -0,0 +1,420 @@
+;;;; $Id: armedbear.lisp 335 2008-04-23 21:29:50Z hhubner $
+;;;; $URL: svn://common-lisp.net/project/usocket/svn/usocket/branches/hans/backend/armedbear.lisp $
+
+;;;; See LICENSE for licensing information.
+
+(in-package :usocket)
+
+
+;;;;; Proposed contribution to the JAVA package
+
+(defpackage :jdi
+  (:use :cl)
+  (:export #:jcoerce
+           #:jop-deref
+           #:do-jmethod-call
+           #:do-jmethod
+           #:do-jstatic-call
+           #:do-jstatic
+           #:do-jnew-call
+           #:do-jfield
+           #:jequals))
+;; but still requires the :java package.
+
+(in-package :jdi)
+
+(defstruct (java-object-proxy (:conc-name :jop-)
+                              :copier)
+  value
+  class)
+
+(defvar *jm-get-return-type*
+  (java:jmethod "java.lang.reflect.Method" "getReturnType"))
+
+(defvar *jf-get-type*
+  (java:jmethod "java.lang.reflect.Field" "getType"))
+
+(defvar *jc-get-declaring-class*
+  (java:jmethod "java.lang.reflect.Constructor" "getDeclaringClass"))
+
+(declaim (inline make-return-type-proxy))
+(defun make-return-type-proxy (jmethod jreturned-value)
+  (if (java:java-object-p jreturned-value)
+      (let ((rt (java:jcall *jm-get-return-type* jmethod)))
+        (make-java-object-proxy :value jreturned-value
+                                :class rt))
+    jreturned-value))
+
+(defun make-field-type-proxy (jfield jreturned-value)
+  (if (java:java-object-p jreturned-value)
+      (let ((rt (java:jcall *jf-get-type* jfield)))
+        (make-java-object-proxy :value jreturned-value
+                                :class rt))
+    jreturned-value))
+
+(defun make-constructor-type-proxy (jconstructor jreturned-value)
+  (if (java:java-object-p jreturned-value)
+      (let ((rt (java:jcall *jc-get-declaring-class* jconstructor)))
+        (make-java-object-proxy :value jreturned-value
+                                :class rt))
+    jreturned-value))
+
+(defun jcoerce (instance &optional output-type-spec)
+  (cond
+   ((java-object-proxy-p instance)
+    (let ((new-instance (copy-structure (the java-object-proxy instance))))
+      (setf (jop-class new-instance)
+            (java:jclass output-type-spec))
+      new-instance))
+   ((java:java-object-p instance)
+    (make-java-object-proxy :class (java:jclass output-type-spec)
+                            :value instance))
+   ((stringp instance)
+    (make-java-object-proxy :class "java.lang.String"
+                            :value instance))
+   ((keywordp output-type-spec)
+    ;; all that remains is creating an immediate type...
+    (let ((jval (java:make-immediate-object instance output-type-spec)))
+      (make-java-object-proxy :class output-type-spec
+                              :value jval)))
+   ))
+
+(defun jtype-of (instance) ;;instance must be a jop
+  (cond
+   ((stringp instance)
+    "java.lang.String")
+   ((keywordp (jop-class instance))
+    (string-downcase (symbol-name (jop-class instance))))
+   (t
+    (java:jclass-name (jop-class instance)))))
+
+(defun jop-deref (instance)
+  (if (java-object-proxy-p instance)
+      (jop-value instance)
+    instance))
+
+(defun java-value-and-class (object)
+  (values (jop-deref object)
+          (jtype-of object)))
+
+(defun do-jmethod-call (object method-name &rest arguments)
+  (multiple-value-bind
+      (instance class-name)
+      (java-value-and-class object)
+    (let* ((argument-types (mapcar #'jtype-of arguments))
+           (jm (apply #'java:jmethod class-name method-name argument-types))
+           (rv (apply #'java:jcall jm instance
+                      (mapcar #'jop-deref arguments))))
+      (make-return-type-proxy jm rv))))
+
+(defun do-jstatic-call (class-name method-name &rest arguments)
+  (let* ((argument-types (mapcar #'jtype-of arguments))
+         (jm (apply #'java:jmethod class-name method-name argument-types))
+         (rv (apply #'java:jstatic jm (java:jclass class-name)
+                    (mapcar #'jop-deref arguments))))
+    (make-return-type-proxy jm rv)))
+
+(defun do-jnew-call (class-name &rest arguments)
+  (let* ((argument-types (mapcar #'jtype-of arguments))
+         (jm (apply #'java:jconstructor class-name argument-types))
+         (rv (apply #'java:jnew jm (mapcar #'jop-deref arguments))))
+    (make-constructor-type-proxy jm rv)))
+
+(defun do-jfield (class-or-instance-or-name field-name)
+  (let* ((class (cond
+                 ((stringp class-or-instance-or-name)
+                  (java:jclass class-or-instance-or-name))
+                 ((java:java-object-p class-or-instance-or-name)
+                  (java:jclass-of class-or-instance-or-name))
+                 ((java-object-proxy-p class-or-instance-or-name)
+                  (java:jclass (jtype-of class-or-instance-or-name)))))
+         (jf (java:jcall (java:jmethod "java.lang.Class" "getField"
+                                       "java.lang.String")
+                         class field-name)))
+    (make-field-type-proxy jf
+                           (java:jfield class field-name)))) ;;class))))
+
+(defmacro do-jstatic (&rest arguments)
+  `(do-jstatic-call , at arguments))
+
+(defmacro do-jmethod (&rest arguments)
+  `(do-jmethod-call , at arguments))
+
+;;
+
+(defmacro jstatic-call (class-name (method-name &rest arg-spec)
+                                   &rest args)
+  (let ((class-sym (gensym)))
+    `(let ((,class-sym ,class-name))
+       (java:jstatic
+        (java:jmethod ,class-sym ,method-name , at arg-spec)
+        (java:jclass ,class-sym) , at args))))
+
+(defmacro jmethod-call (instance-and-class (method &rest arg-spec) &rest args)
+  (let ((isym (gensym)))
+    (multiple-value-bind
+        (instance class-name)
+        (if (listp instance-and-class)
+            (values (first instance-and-class)
+                    (second instance-and-class))
+          (values instance-and-class))
+      (when (null class-name)
+        (setf class-name `(java:jclass-name (java:jclass-of ,isym))))
+      `(let* ((,isym ,instance))
+         (java:jcall (java:jmethod ,class-name ,method , at arg-spec)
+                     ,isym , at args)))))
+
+(defun jequals (x y)
+  (do-jmethod-call (jcoerce x "java.lang.Object") "equals"
+                   (jcoerce y "java.lang.Object")))
+
+(defmacro jnew-call ((class &rest arg-spec) &rest args)
+  `(java:jnew (java:jconstructor ,class , at arg-spec)
+         , at args))
+
+
+
+(in-package :usocket)
+
+(defun get-host-name ()
+  (jdi:do-jmethod-call (jdi:do-jstatic-call "java.net.InetAddress"
+                                            "getLocalHost")
+                       "getHostName"))
+
+(defun handle-condition (condition &optional socket)
+  (typecase condition
+    (error (error 'unknown-error :socket socket :real-error condition))))
+
+(defun socket-connect (host port &key (element-type 'character) timeout nodelay)
+  (declare (ignore nodelay))
+  (when timeout
+    (warn "SOCKET-CONNECT timeout not supported in ABCL"))
+  (let ((usock))
+    (with-mapped-conditions (usock)
+      (let* ((sock-addr (jdi:jcoerce
+                         (jdi:do-jnew-call "java.net.InetSocketAddress"
+                                           (host-to-hostname host)
+                                           (jdi:jcoerce port :int))
+                         "java.net.SocketAddress"))
+             (jchan (jdi:do-jstatic-call "java.nio.channels.SocketChannel"
+                                         "open" sock-addr))
+             (sock (jdi:do-jmethod-call jchan "socket")))
+        (describe sock)
+         (setf usock
+               (make-stream-socket
+                :socket jchan
+                :stream (ext:get-socket-stream (jdi:jop-deref sock)
+                                               :element-type element-type)))))))
+
+(defun socket-listen (host port
+                           &key reuseaddress
+                           (reuse-address nil reuse-address-supplied-p)
+                           (backlog 5)
+                           (element-type 'character))
+  (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress))
+         (sock-addr (jdi:do-jnew-call "java.net.InetSocketAddress"
+                                      (host-to-hostname host)
+                                      (jdi:jcoerce port :int)))
+         (chan (jdi:do-jstatic-call "java.nio.channels.ServerSocketChannel"
+                                    "open"))
+         (sock (jdi:do-jmethod-call chan "socket")))
+    (when reuseaddress
+      (with-mapped-conditions ()
+        (jdi:do-jmethod-call sock
+                             "setReuseAddress"
+                             (jdi:jcoerce reuseaddress :boolean))))
+    (with-mapped-conditions ()
+      (jdi:do-jmethod-call sock
+                           "bind"
+                           (jdi:jcoerce sock-addr
+                                        "java.net.SocketAddress")
+                           (jdi:jcoerce backlog :int)))
+    (make-stream-server-socket chan :element-type element-type)))
+
+(defmethod socket-accept ((socket stream-server-usocket) &key element-type)
+  (let* ((jsock (socket socket))
+         (jacc-chan (with-mapped-conditions (socket)
+                       (jdi:do-jmethod-call jsock "accept")))
+         (jacc-stream
+          (ext:get-socket-stream (jdi:jop-deref
+                                  (jdi:do-jmethod-call jacc-chan "socket"))
+                                 :element-type (or element-type
+                                                   (element-type socket)))))
+    (make-stream-socket :socket jacc-chan
+                        :stream jacc-stream)))
+
+;;(defun print-java-exception (e)
+;;  (let* ((native-exception (java-exception-cause e)))
+;;    (print (jcall (jmethod "java.net.BindException" "getMessage") native-exception))))
+
+(defmethod socket-close ((usocket usocket))
+  (with-mapped-conditions (usocket)
+    (jdi:do-jmethod (socket usocket) "close")))
+
+;; Socket streams are different objects than
+;; socket streams. Closing the stream flushes
+;; its buffers *and* closes the socket.
+(defmethod socket-close ((usocket stream-usocket))
+  (with-mapped-conditions (usocket)
+    (close (socket-stream usocket))))
+
+(defmethod get-local-address ((usocket usocket))
+  (dotted-quad-to-vector-quad (ext:socket-local-address (socket usocket))))
+
+(defmethod get-peer-address ((usocket stream-usocket))
+  (dotted-quad-to-vector-quad (ext:socket-peer-address (socket usocket))))
+
+(defmethod get-local-port ((usocket usocket))
+  (ext:socket-local-port (socket usocket)))
+
+(defmethod get-peer-port ((usocket stream-usocket))
+  (ext:socket-peer-port (socket usocket)))
+
+(defmethod get-local-name ((usocket usocket))
+  (values (get-local-address usocket)
+          (get-local-port usocket)))
+
+(defmethod get-peer-name ((usocket stream-usocket))
+  (values (get-peer-address usocket)
+          (get-peer-port usocket)))
+
+
+#|
+Pseudo code version of what we're trying to do:
+
+We're being called with 2 args:
+
+  - sockets (list)
+  - timeout (non-negative real)
+
+Selector := java.nio.channels.Selector.open()
+
+For all usockets
+  get the java socket
+  get its channel
+  register the channel with the selector
+    with ops (operations) OP_READ and OP_ACCEPT
+
+make the selector wait trunc(timeout*1000) miliseconds,
+  unless (null timeout), because then:
+  selectNow()
+
+retrieve the selectedKeys() set from the selector
+  unless select() returned 0 selected keys.
+
+for set-iterator.hasNextKey()
+  with that key
+    retrieve the channel
+    retrieve the channel's socket
+    add the retrieved socket to the list of ready sockets
+
+for all usockets
+  check if the associated java object
+    is in the list of ready sockets
+  it is? add it to the function result list
+
+close() the selector
+
+return the function result list.
+
+|#
+
+(defun op-read ()
+  (jdi:do-jfield "java.nio.channels.SelectionKey"
+                 "OP_READ"))
+
+(defun op-accept ()
+  (jdi:do-jfield "java.nio.channels.SelectionKey"
+                 "OP_ACCEPT"))
+
+(defun op-connect ()
+  (jdi:do-jfield "java.nio.channels.SelectionKey"
+                 "OP_CONNECT"))
+
+(defun valid-ops (jchannel)
+  (jdi:do-jmethod-call jchannel "validOps"))
+
+(defun channel-class (jchannel)
+  (let ((valid-ops (valid-ops jchannel)))
+    (cond ((/= 0 (logand valid-ops (op-connect)))
+           "java.nio.channels.SocketChannel")
+          ((/= 0 (logand valid-ops (op-accept)))
+           "java.nio.channels.ServerSocketChannel")
+          (t
+           "java.nio.channels.DatagramChannel"))))
+
+(defun socket-channel-class (socket)
+  (cond
+   ((stream-usocket-p socket)
+    "java.nio.channels.SocketChannel")
+   ((stream-server-usocket-p socket)
+    "java.nio.channels.ServerSocketChannel")
+   ((datagram-usocket-p socket)
+    "java.nio.channels.DatagramChannel")))
+
+(defun wait-for-input-internal (sockets &key timeout)
+  (let* ((ops (logior (op-read) (op-accept)))
+         (selector (jdi:do-jstatic "java.nio.channels.Selector" "open"))
+         (channels (mapcar #'socket sockets)))
+    (unwind-protect
+        (with-mapped-conditions ()
+          (let ((jfalse (java:make-immediate-object nil :boolean))
+                (sel (jdi:jop-deref selector)))
+            (dolist (channel channels)
+              (let ((chan (jdi:jop-deref channel)))
+                (java:jcall (java:jmethod "java.nio.channels.SelectableChannel"
+                                          "configureBlocking"
+                                          "boolean")
+                            chan jfalse)
+                (java:jcall (java:jmethod "java.nio.channels.SelectableChannel"
+                                          "register"
+                                          "java.nio.channels.Selector" "int")
+                            chan sel (logand ops (valid-ops channel)))))
+            (let ((ready-count
+                   (java:jcall (java:jmethod "java.nio.channels.Selector"
+                                             "select"
+                                             "long")
+                               sel (truncate (* timeout 1000)))))
+              (when (< 0 ready-count)
+                ;; we actually have work to do
+                (let* ((selkeys (jdi:do-jmethod selector "selectedKeys"))
+                       (selkey-iterator (jdi:do-jmethod selkeys "iterator"))
+                       ready-sockets)
+                  (loop while (java:jcall
+                               (java:jmethod "java.util.Iterator" "hasNext")
+                               (jdi:jop-deref selkey-iterator))
+                        do (let* ((key (jdi:jcoerce
+                                        (jdi:do-jmethod selkey-iterator "next")
+                                        "java.nio.channels.SelectionKey"))
+                                  (chan (jdi:jop-deref
+                                         (jdi:do-jmethod key "channel"))))
+                             (push chan ready-sockets)))
+                  (remove-if #'(lambda (s)
+                                 (not (member (jdi:jop-deref (socket s))
+                                              ready-sockets
+                                              :test #'(lambda (x y)
+                                                        (java:jcall (java:jmethod "java.lang.Object"
+                                                                             "equals"
+                                                                             "java.lang.Object")
+                                                                    x y)))))
+                             sockets))))))
+      ;; cancel all Selector registrations
+      (let* ((keys (jdi:do-jmethod selector "keys"))
+             (iter (jdi:do-jmethod keys "iterator")))
+        (loop while (java:jcall (java:jmethod "java.util.Iterator" "hasNext")
+                                (jdi:jop-deref iter))
+              do (java:jcall
+                  (java:jmethod "java.nio.channels.SelectionKey" "cancel")
+                  (java:jcall (java:jmethod "java.util.Iterator" "next")
+                              (jdi:jop-deref iter)))))
+      ;; close the selector
+      (java:jcall (java:jmethod "java.nio.channels.Selector" "close")
+                  (jdi:jop-deref selector))
+      ;; make all sockets blocking again.
+      (let ((jtrue (java:make-immediate-object t :boolean)))
+        (dolist (chan channels)
+          (java:jcall (java:jmethod "java.nio.channels.SelectableChannel"
+                                          "configureBlocking"
+                                          "boolean")
+                      (jdi:jop-deref chan) jtrue))))))
+

Added: usocket/branches/hans/backend/clisp.lisp
==============================================================================
--- (empty file)
+++ usocket/branches/hans/backend/clisp.lisp	Sat Jul 19 08:00:01 2008
@@ -0,0 +1,232 @@
+;;;; $Id: clisp.lisp 335 2008-04-23 21:29:50Z hhubner $
+;;;; $URL: svn://common-lisp.net/project/usocket/svn/usocket/branches/hans/backend/clisp.lisp $
+
+;;;; See LICENSE for licensing information.
+
+(in-package :usocket)
+
+
+;; utility routine for looking up the current host name
+(FFI:DEF-CALL-OUT get-host-name-internal
+         (:name "gethostname")
+         (:arguments (name (FFI:C-PTR (FFI:C-ARRAY-MAX ffi:character 256))
+                           :OUT :ALLOCA)
+                     (len ffi:int))
+         #+win32 (:library "WS2_32")
+         (:language #-win32 :stdc
+                    #+win32 :stdc-stdcall)
+         (:return-type ffi:int))
+
+
+(defun get-host-name ()
+  (multiple-value-bind (retcode name)
+      (get-host-name-internal 256)
+    (when (= retcode 0)
+      name)))
+
+
+#+win32
+(defun remap-maybe-for-win32 (z)
+  (mapcar #'(lambda (x)
+              (cons (mapcar #'(lambda (y)
+                                (+ 10000 y))
+                            (car x))
+                    (cdr x)))
+          z))
+
+(defparameter +clisp-error-map+
+  #+win32
+  (append (remap-maybe-for-win32 +unix-errno-condition-map+)
+          (remap-maybe-for-win32 +unix-errno-error-map+))
+  #-win32
+  (append +unix-errno-condition-map+
+          +unix-errno-error-map+))
+
+(defun handle-condition (condition &optional (socket nil))
+  "Dispatch correct usocket condition."
+  (typecase condition
+    (system::simple-os-error
+       (let ((usock-err
+              (cdr (assoc (car (simple-condition-format-arguments condition))
+                          +clisp-error-map+ :test #'member))))
+         (when usock-err ;; don't claim the error if we don't know
+	   ;; it's actually a socket error ...
+             (if (subtypep usock-err 'error)
+                 (error usock-err :socket socket)
+               (signal usock-err :socket socket)))))))
+
+(defun socket-connect (host port &key (element-type 'character) timeout nodelay)
+  (declare (ignore nodelay))
+  (when timeout
+    (warn "SOCKET-CONNECT timeout not supported in CLISP"))
+  (let ((socket)
+        (hostname (host-to-hostname host)))
+    (with-mapped-conditions (socket)
+       (setf socket
+             (socket:socket-connect port hostname
+                                    :element-type element-type
+                                    :buffered t)))
+    (make-stream-socket :socket socket
+                        :stream socket))) ;; the socket is a stream too
+
+(defun socket-listen (host port
+                           &key reuseaddress
+                           (reuse-address nil reuse-address-supplied-p)
+                           (backlog 5)
+                           (element-type 'character))
+  ;; clisp 2.39 sets SO_REUSEADDRESS to 1 by default; no need to
+  ;; to explicitly turn it on; unfortunately, there's no way to turn it off...
+  (declare (ignore reuseaddress reuse-address reuse-address-supplied-p))
+  (let ((sock (apply #'socket:socket-server
+                     (append (list port
+                                   :backlog backlog)
+                             (when (ip/= host *wildcard-host*)
+                               (list :interface host))))))
+    (with-mapped-conditions ()
+        (make-stream-server-socket sock :element-type element-type))))
+
+(defmethod socket-accept ((socket stream-server-usocket) &key element-type)
+  (let ((stream
+         (with-mapped-conditions (socket)
+           (socket:socket-accept (socket socket)
+                                 :element-type (or element-type
+                                                   (element-type socket))))))
+    (make-stream-socket :socket stream
+                        :stream stream)))
+
+;; Only one close method required:
+;; sockets and their associated streams
+;; are the same object
+(defmethod socket-close ((usocket usocket))
+  "Close socket."
+  (with-mapped-conditions (usocket)
+    (close (socket usocket))))
+
+(defmethod socket-close ((usocket stream-server-usocket))
+  (socket:socket-server-close (socket usocket)))
+
+(defmethod get-local-name ((usocket usocket))
+  (multiple-value-bind
+      (address port)
+      (socket:socket-stream-local (socket usocket) t)
+    (values (dotted-quad-to-vector-quad address) port)))
+
+(defmethod get-peer-name ((usocket stream-usocket))
+  (multiple-value-bind
+      (address port)
+      (socket:socket-stream-peer (socket usocket) t)
+    (values (dotted-quad-to-vector-quad address) port)))
+
+(defmethod get-local-address ((usocket usocket))
+  (nth-value 0 (get-local-name usocket)))
+
+(defmethod get-peer-address ((usocket stream-usocket))
+  (nth-value 0 (get-peer-name usocket)))
+
+(defmethod get-local-port ((usocket usocket))
+  (nth-value 1 (get-local-name usocket)))
+
+(defmethod get-peer-port ((usocket stream-usocket))
+  (nth-value 1 (get-peer-name usocket)))
+
+
+(defmethod wait-for-input-internal (sockets &key timeout)
+  (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))))))
+
+
+;;
+;; UDP/Datagram sockets!
+;;
+
+#+rawsock
+(progn
+
+  (defun make-sockaddr_in ()
+    (make-array 16 :element-type '(unsigned-byte 8) :initial-element 0))
+
+  (declaim (inline fill-sockaddr_in))
+  (defun fill-sockaddr_in (sockaddr_in ip port)
+    (port-to-octet-buffer sockaddr_in port)
+    (ip-to-octet-buffer sockaddr_in ip :start 2)
+    sockaddr_in)
+
+  (defun socket-create-datagram (local-port
+                                 &key (local-host *wildcard-host*)
+                                      remote-host
+                                      remote-port)
+    (let ((sock (rawsock:socket :inet :dgram 0))
+          (lsock_addr (fill-sockaddr_in (make-sockaddr_in)
+                                        local-host local-port))
+          (rsock_addr (when remote-host
+                        (fill-sockaddr_in (make-sockaddr_in)
+                                          remote-host (or remote-port
+                                                          local-port)))))
+      (bind sock lsock_addr)
+      (when rsock_addr
+        (connect sock rsock_addr))
+      (make-datagram-socket sock :connected-p (if rsock_addr t nil))))
+
+  (defun socket-receive (socket buffer &key (size (length buffer)))
+    "Returns the buffer, the number of octets copied into the buffer (received)
+and the address of the sender as values."
+    (let* ((sock (socket socket))
+           (sockaddr (when (not (connected-p socket))
+                       (rawsock:make-sockaddr)))
+           (rv (if sockaddr
+                   (rawsock:recvfrom sock buffer sockaddr
+                                     :start 0
+                                     :end size)
+                   (rawsock:recv sock buffer
+                                 :start 0
+                                 :end size))))
+      (values buffer
+              rv
+              (list (ip-from-octet-buffer (sockaddr-data sockaddr) 4)
+                    (port-from-octet-buffer (sockaddr-data sockaddr) 2)))))
+
+  (defun socket-send (socket buffer &key address (size (length buffer)))
+    "Returns the number of octets sent."
+    (let* ((sock (socket socket))
+           (sockaddr (when address
+                       (rawsock:make-sockaddr :INET
+                                              (fill-sockaddr_in
+                                               (make-sockaddr_in)
+                                               (host-byte-order
+                                                (second address))
+                                               (first address)))))
+           (rv (if address
+                   (rawsock:sendto sock buffer sockaddr
+                                   :start 0
+                                   :end size)
+                   (rawsock:send sock buffer
+                                 :start 0
+                                 :end size))))
+      rv))
+
+  (defmethod socket-close ((usocket datagram-usocket))
+    (rawsock:sock-close (socket usocket)))
+  
+  )
+
+#-rawsock
+(progn
+  (warn "This image doesn't contain the RAWSOCK package.
+To enable UDP socket support, please be sure to use the -Kfull parameter
+at startup, or to enable RAWSOCK support during compilation.")
+
+  )

Added: usocket/branches/hans/backend/cmucl.lisp
==============================================================================
--- (empty file)
+++ usocket/branches/hans/backend/cmucl.lisp	Sat Jul 19 08:00:01 2008
@@ -0,0 +1,190 @@
+;;;; $Id: cmucl.lisp 335 2008-04-23 21:29:50Z hhubner $
+;;;; $URL: svn://common-lisp.net/project/usocket/svn/usocket/branches/hans/backend/cmucl.lisp $
+
+;;;; See LICENSE for licensing information.
+
+(in-package :usocket)
+
+#+win32
+(defun remap-for-win32 (z)
+  (mapcar #'(lambda (x)
+              (cons (mapcar #'(lambda (y)
+                                (+ 10000 y))
+                            (car x))
+                    (cdr x)))
+          z))
+
+(defparameter +cmucl-error-map+
+  #+win32
+  (append (remap-for-win32 +unix-errno-condition-map+)
+          (remap-for-win32 +unix-errno-error-map+))
+  #-win32
+  (append +unix-errno-condition-map+
+          +unix-errno-error-map+))
+
+(defun cmucl-map-socket-error (err &key condition socket)
+  (let ((usock-err
+         (cdr (assoc err +cmucl-error-map+ :test #'member))))
+    (if usock-err
+        (if (subtypep usock-err 'error)
+            (error usock-err :socket socket)
+          (signal usock-err :socket socket))
+      (error 'unknown-error
+             :socket socket
+             :real-error condition))))
+
+;; CMUCL error handling is brain-dead: it doesn't preserve any
+;; information other than the OS error string from which the
+;; error can be determined. The OS error string isn't good enough
+;; given that it may have been localized (l10n).
+;;
+;; The above applies to versions pre 19b; 19d and newer are expected to
+;; contain even better error reporting.
+;;
+;;
+;; Just catch the errors and encapsulate them in an unknown-error
+(defun handle-condition (condition &optional (socket nil))
+  "Dispatch correct usocket condition."
+  (typecase condition
+    (ext::socket-error (cmucl-map-socket-error (ext::socket-errno condition)
+                                               :socket socket
+                                               :condition condition))))
+
+(defun socket-connect (host port &key (element-type 'character) timeout nodelay)
+  (declare (ignore nodelay))
+  (when timeout
+    (warn "SOCKET-CONNECT timeout not supported in CMUCL"))
+  (let* ((socket))
+    (setf socket
+          (with-mapped-conditions (socket)
+             (ext:connect-to-inet-socket (host-to-hbo host) port :stream)))
+    (if socket
+        (let* ((stream (sys:make-fd-stream socket :input t :output t
+                                           :element-type element-type
+                                           :buffering :full))
+               ;;###FIXME the above line probably needs an :external-format
+               (usocket (make-stream-socket :socket socket
+                                            :stream stream)))
+          usocket)
+      (let ((err (unix:unix-errno)))
+        (when err (cmucl-map-socket-error err))))))
+
+(defun socket-listen (host port
+                           &key reuseaddress
+                           (reuse-address nil reuse-address-supplied-p)
+                           (backlog 5)
+                           (element-type 'character))
+ (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress))
+        (server-sock
+         (with-mapped-conditions ()
+           (apply #'ext:create-inet-listener
+                  (append (list port :stream
+                                :backlog backlog
+                                :reuse-address reuseaddress)
+                          (when (ip/= host *wildcard-host*)
+                            (list :host
+                                  (host-to-hbo host))))))))
+   (make-stream-server-socket server-sock :element-type element-type)))
+
+(defmethod socket-accept ((usocket stream-server-usocket) &key element-type)
+  (with-mapped-conditions (usocket)
+    (let* ((sock (ext:accept-tcp-connection (socket usocket)))
+           (stream (sys:make-fd-stream sock :input t :output t
+                                       :element-type (or element-type
+                                                         (element-type usocket))
+                                       :buffering :full)))
+      (make-stream-socket :socket sock :stream stream))))
+
+;; Sockets and socket streams are represented
+;; by different objects. Be sure to close the
+;; socket stream when closing a stream socket.
+(defmethod socket-close ((usocket stream-usocket))
+  "Close socket."
+  (with-mapped-conditions (usocket)
+    (close (socket-stream usocket))))
+
+(defmethod socket-close ((usocket usocket))
+  "Close socket."
+  (with-mapped-conditions (usocket)
+    (ext:close-socket (socket usocket))))
+
+(defmethod get-local-name ((usocket usocket))
+  (multiple-value-bind
+      (address port)
+      (ext:get-socket-host-and-port (socket usocket))
+    (values (hbo-to-vector-quad address) port)))
+
+(defmethod get-peer-name ((usocket stream-usocket))
+  (multiple-value-bind
+      (address port)
+      (ext:get-peer-host-and-port (socket usocket))
+    (values (hbo-to-vector-quad address) port)))
+
+(defmethod get-local-address ((usocket usocket))
+  (nth-value 0 (get-local-name usocket)))
+
+(defmethod get-peer-address ((usocket stream-usocket))
+  (nth-value 0 (get-peer-name usocket)))
+
+(defmethod get-local-port ((usocket usocket))
+  (nth-value 1 (get-local-name usocket)))
+
+(defmethod get-peer-port ((usocket stream-usocket))
+  (nth-value 1 (get-peer-name usocket)))
+
+
+(defun lookup-host-entry (host)
+  (multiple-value-bind
+      (entry errno)
+      (ext:lookup-host-entry host)
+    (if entry
+        entry
+      ;;###The constants below work on *most* OSes, but are defined as the
+      ;; constants mentioned in C
+      (let ((exception
+             (second (assoc errno
+                            '((1 ns-host-not-found-error) ;; HOST_NOT_FOUND
+                              (2 ns-no-recovery-error)    ;; NO_DATA
+                              (3 ns-no-recovery-error)    ;; NO_RECOVERY
+                              (4 ns-try-again))))))       ;; TRY_AGAIN
+        (when exception
+          (error exception))))))
+
+
+(defun get-host-by-address (address)
+  (handler-case (ext:host-entry-name
+                 (lookup-host-entry (host-byte-order address)))
+    (condition (condition) (handle-condition condition))))
+
+(defun get-hosts-by-name (name)
+  (handler-case (mapcar #'hbo-to-vector-quad
+                        (ext:host-entry-addr-list
+                         (lookup-host-entry name)))
+    (condition (condition) (handle-condition condition))))
+
+(defun get-host-name ()
+  (unix:unix-gethostname))
+
+(defun wait-for-input-internal (sockets &key timeout)
+  (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
+           (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
+               )))))))

Added: usocket/branches/hans/backend/lispworks.lisp
==============================================================================
--- (empty file)
+++ usocket/branches/hans/backend/lispworks.lisp	Sat Jul 19 08:00:01 2008
@@ -0,0 +1,353 @@
+;;;; $Id: lispworks.lisp 335 2008-04-23 21:29:50Z hhubner $
+;;;; $URL: svn://common-lisp.net/project/usocket/svn/usocket/branches/hans/backend/lispworks.lisp $
+
+;;;; See LICENSE for licensing information.
+
+(in-package :usocket)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (require "comm"))
+
+#+win32
+(fli:register-module "ws2_32")
+
+(fli:define-foreign-function (get-host-name-internal "gethostname" :source)
+      ((return-string (:reference-return (:ef-mb-string :limit 257)))
+       (namelen :int))
+      :lambda-list (&aux (namelen 256) return-string)
+      :result-type :int
+      #+win32 :module
+      #+win32 "ws2_32")
+
+(defun get-host-name ()
+  (multiple-value-bind (retcode name)
+      (get-host-name-internal)
+    (when (= 0 retcode)
+      name)))
+
+#+win32
+(defun remap-maybe-for-win32 (z)
+  (mapcar #'(lambda (x)
+              (cons (mapcar #'(lambda (y)
+                                (+ 10000 y))
+                            (car x))
+                    (cdr x)))
+          z))
+
+(defparameter +lispworks-error-map+
+  #+win32
+  (append (remap-maybe-for-win32 +unix-errno-condition-map+)
+          (remap-maybe-for-win32 +unix-errno-error-map+))
+  #-win32
+  (append +unix-errno-condition-map+
+          +unix-errno-error-map+))
+
+(defun raise-or-signal-socket-error (errno socket)
+  (let ((usock-err
+         (cdr (assoc errno +lispworks-error-map+ :test #'member))))
+    (if usock-err
+        (if (subtypep usock-err 'error)
+            (error usock-err :socket socket)
+          (signal usock-err :socket))
+      (error 'unknown-error
+             :socket socket
+             :real-condition nil))))
+
+(defun raise-usock-err (errno socket &optional condition)
+  (let* ((usock-err
+          (cdr (assoc errno +lispworks-error-map+
+                      :test #'member))))
+    (if usock-err
+        (if (subtypep usock-err 'error)
+            (error usock-err :socket socket)
+          (signal usock-err :socket))
+      (error 'unknown-error
+             :socket socket
+             :real-error condition))))
+
+(defun handle-condition (condition &optional (socket nil))
+  "Dispatch correct usocket condition."
+  (typecase condition
+    (simple-error (destructuring-bind (&optional host port err-msg errno)
+                      (simple-condition-format-arguments condition)
+                    (declare (ignore host port err-msg))
+                    (raise-usock-err errno socket condition)))))
+
+(defun socket-connect (host port &key (element-type 'base-char) timeout nodelay)
+  (declare (ignore nodelay))
+  (when timeout
+    (warn "SOCKET-CONNECT timeout not supported in Lispworks"))
+  (let ((hostname (host-to-hostname host))
+        (stream))
+    (setf stream
+          (with-mapped-conditions ()
+             (comm:open-tcp-stream hostname port
+                                   :element-type element-type)))
+    (if stream
+        (make-stream-socket :socket (comm:socket-stream-socket stream)
+                            :stream stream)
+      (error 'unknown-error))))
+
+(defun socket-listen (host port
+                           &key reuseaddress
+                           (reuse-address nil reuse-address-supplied-p)
+                           (backlog 5)
+                           (element-type 'base-char))
+  (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress))
+         (comm::*use_so_reuseaddr* reuseaddress)
+         (hostname (host-to-hostname host))
+         (sock (with-mapped-conditions ()
+                  #-lispworks4.1 (comm::create-tcp-socket-for-service
+                                  port :address hostname :backlog backlog)
+                  #+lispworks4.1 (comm::create-tcp-socket-for-service port))))
+    (make-stream-server-socket sock :element-type element-type)))
+
+(defmethod socket-accept ((usocket stream-server-usocket) &key element-type)
+  (let* ((sock (with-mapped-conditions (usocket)
+                 (comm::get-fd-from-socket (socket usocket))))
+         (stream (make-instance 'comm:socket-stream
+                                :socket sock
+                                :direction :io
+                                :element-type (or element-type
+                                                  (element-type usocket)))))
+    #+win32
+    (when sock
+      (setf (%ready-p usocket) nil))
+    (make-stream-socket :socket sock :stream stream)))
+
+;; Sockets and their streams are different objects
+;; close the stream in order to make sure buffers
+;; are correctly flushed and the socket closed.
+(defmethod socket-close ((usocket stream-usocket))
+  "Close socket."
+  (close (socket-stream usocket)))
+
+(defmethod socket-close ((usocket usocket))
+  (with-mapped-conditions (usocket)
+     (comm::close-socket (socket usocket))))
+
+(defmethod get-local-name ((usocket usocket))
+  (multiple-value-bind
+      (address port)
+      (comm:get-socket-address (socket usocket))
+    (values (hbo-to-vector-quad address) port)))
+
+(defmethod get-peer-name ((usocket stream-usocket))
+  (multiple-value-bind
+      (address port)
+      (comm:get-socket-peer-address (socket usocket))
+    (values (hbo-to-vector-quad address) port)))
+
+(defmethod get-local-address ((usocket usocket))
+  (nth-value 0 (get-local-name usocket)))
+
+(defmethod get-peer-address ((usocket stream-usocket))
+  (nth-value 0 (get-peer-name usocket)))
+
+(defmethod get-local-port ((usocket usocket))
+  (nth-value 1 (get-local-name usocket)))
+
+(defmethod get-peer-port ((usocket stream-usocket))
+  (nth-value 1 (get-peer-name usocket)))
+
+(defun get-hosts-by-name (name)
+  (with-mapped-conditions ()
+     (mapcar #'hbo-to-vector-quad
+             (comm:get-host-entry name :fields '(:addresses)))))
+
+(defun os-socket-handle (usocket)
+  (socket usocket))
+
+(defun usocket-listen (usocket)
+  (if (stream-usocket-p usocket)
+      (when (listen (socket usocket))
+        usocket)
+    (when (comm::socket-listen (socket usocket))
+      usocket)))
+
+;;;
+;;; Non Windows implementation
+;;;   The Windows implementation needs to resort to the Windows API in order
+;;;   to achieve what we want (what we want is waiting without busy-looping)
+;;;
+
+#-win32
+(defun wait-for-input-internal (sockets &key timeout)
+  (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))))
+
+
+;;;
+;;;  The Windows side of the story
+;;;    We want to wait without busy looping
+;;;    This code only works in threads which don't have (hidden)
+;;;    windows which need to receive messages. There are workarounds in the Windows API
+;;;    but are those available to 'us'.
+;;;
+
+
+#+win32
+(progn
+
+  ;; LispWorks doesn't provide an interface to wait for a socket
+  ;; to become ready (under Win32, that is) meaning that we need
+  ;; to resort to system calls to achieve the same thing.
+  ;; Luckily, it provides us access to the raw socket handles (as we 
+  ;; wrote the code above.
+  (defconstant fd-read 1)
+  (defconstant fd-read-bit 0)
+  (defconstant fd-write 2)
+  (defconstant fd-write-bit 1)
+  (defconstant fd-oob 4)
+  (defconstant fd-oob-bit 2)
+  (defconstant fd-accept 8)
+  (defconstant fd-accept-bit 3)
+  (defconstant fd-connect 16)
+  (defconstant fd-connect-bit 4)
+  (defconstant fd-close 32)
+  (defconstant fd-close-bit 5)
+  (defconstant fd-qos 64)
+  (defconstant fd-qos-bit 6)
+  (defconstant fd-group-qos 128)
+  (defconstant fd-group-qos-bit 7)
+  (defconstant fd-routing-interface 256)
+  (defconstant fd-routing-interface-bit 8)
+  (defconstant fd-address-list-change 512)
+  (defconstant fd-address-list-change-bit 9)
+  
+  (defconstant fd-max-events 10)
+
+  (defconstant fionread 1074030207)
+
+  (fli:define-foreign-type ws-socket () '(:unsigned :int))
+  (fli:define-foreign-type win32-handle () '(:unsigned :int))
+  (fli:define-c-struct wsa-network-events (network-events :long)
+    (error-code (:c-array :int 10)))
+
+  (fli:define-foreign-function (wsa-event-create "WSACreateEvent" :source)
+      ()
+      :lambda-list nil
+    :result-type :int
+    :module "ws2_32")
+  (fli:define-foreign-function (wsa-event-close "WSACloseEvent" :source)
+      ((event-object win32-handle))
+    :result-type :int
+    :module "ws2_32")
+  (fli:define-foreign-function (wsa-enum-network-events "WSAEnumNetworkEvents" :source)
+      ((socket ws-socket)
+       (event-object win32-handle)
+       (network-events (:reference-return wsa-network-events)))
+    :result-type :int
+    :module "ws2_32")
+  
+  (fli:define-foreign-function (wsa-event-select "WSAEventSelect" :source)
+      ((socket ws-socket)
+       (event-object win32-handle)
+       (network-events :long))
+    :result-type :int
+    :module "ws2_32")
+
+  (fli:define-foreign-function (wsa-get-last-error "WSAGetLastError" :source)
+      ()
+    :result-type :int
+    :module "ws2_32")
+
+  (fli:define-foreign-function (wsa-ioctlsocket "ioctlsocket" :source)
+      ((socket :long) (cmd :long) (argp (:ptr :long)))
+    :result-type :int
+    :module "ws2_32")
+
+
+  ;; The Windows system 
+
+
+  ;; Now that we have access to the system calls, this is the plan:
+
+  ;; 1. Receive a list of sockets to listen to
+  ;; 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
+  ;;    (this step is different from Unix, where we can have only one error)
+  ;; 5. If so, raise one of them
+  ;; 6. If not so, return the sockets which have input waiting for them
+
+
+  (defun maybe-wsa-error (rv &optional socket)
+    (unless (zerop rv)
+      (raise-usock-err (wsa-get-last-error) socket)))
+
+  (defun bytes-available-for-read (socket)
+    (fli:with-dynamic-foreign-objects ((int-ptr :long))
+      (let ((rv (wsa-ioctlsocket (os-socket-handle socket) fionread int-ptr)))
+        (if (= 0 rv)
+            (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))
+       (%ready-p socket)))
+
+  (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 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))
+	      (funcall func (fli:foreign-aref error-array i)))))))
+
+  (defun update-ready-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)
+                 (map-network-events #'(lambda (err-code)
+                                          (if (zerop err-code)
+                                             (setf (%ready-p socket) t)
+                                             (raise-usock-err err-code socket)))
+                                     network-events)
+                 (maybe-wsa-error rv socket))))))
+
+  (defun sockets-ready (sockets)
+    (remove-if-not #'socket-ready-p sockets))
+  
+  );; end of WIN32-block

Added: usocket/branches/hans/backend/openmcl.lisp
==============================================================================
--- (empty file)
+++ usocket/branches/hans/backend/openmcl.lisp	Sat Jul 19 08:00:01 2008
@@ -0,0 +1,162 @@
+;;;; $Id: openmcl.lisp 335 2008-04-23 21:29:50Z hhubner $
+;;;; $URL: svn://common-lisp.net/project/usocket/svn/usocket/branches/hans/backend/openmcl.lisp $
+
+;;;; See LICENSE for licensing information.
+
+(in-package :usocket)
+
+(defun get-host-name ()
+  (ccl::%stack-block ((resultbuf 256))
+    (when (zerop (#_gethostname resultbuf 256))
+      (ccl::%get-cstring resultbuf))))
+
+(defparameter +openmcl-error-map+
+  '((:address-in-use . address-in-use-error)
+    (:connection-aborted . connection-aborted-error)
+    (:no-buffer-space . no-buffers-error)
+    (:connection-timed-out . timeout-error)
+    (:connection-refused . connection-refused-error)
+    (:host-unreachable . host-unreachable-error)
+    (:host-down . host-down-error)
+    (:network-down . network-down-error)
+    (:address-not-available . address-not-available-error)
+    (:network-reset . network-reset-error)
+    (:connection-reset . connection-reset-error)
+    (:shutdown . shutdown-error)
+    (:access-denied . operation-not-permitted-error)))
+
+
+;; we need something which the openmcl implementors 'forgot' to do:
+;; wait for more than one socket-or-fd
+
+(defun input-available-p (sockets &optional ticks-to-wait)
+  (ccl::rletZ ((tv :timeval))
+    (ccl::ticks-to-timeval ticks-to-wait tv)
+    (ccl::%stack-block ((infds ccl::*fd-set-size*))
+      (ccl::fd-zero infds)
+      (let ((max-fd -1))
+        (dolist (sock sockets)
+          (let ((fd (openmcl-socket:socket-os-fd sock)))
+            (setf max-fd (max max-fd fd))
+            (ccl::fd-set fd infds)))
+        (let* ((res (#_select (1+ max-fd)
+                              infds (ccl::%null-ptr) (ccl::%null-ptr)
+                              (if ticks-to-wait tv (ccl::%null-ptr)))))
+          (when (> res 0)
+            (remove-if #'(lambda (x)
+                           (not (ccl::fd-is-set (openmcl-socket:socket-os-fd x)
+                                                infds)))
+                       sockets)))))))
+
+(defun raise-error-from-id (condition-id socket real-condition)
+  (let ((usock-err (cdr (assoc condition-id +openmcl-error-map+))))
+    (if usock-err
+        (error usock-err :socket socket)
+      (error 'unknown-error :socket socket :real-error real-condition))))
+
+(defun handle-condition (condition &optional socket)
+  (typecase condition
+    (openmcl-socket:socket-error
+       (raise-error-from-id (openmcl-socket:socket-error-identifier condition)
+                            socket condition))
+    (ccl:input-timeout
+       (error 'timeout-error :socket socket :real-error condition))
+    (ccl:communication-deadline-expired
+       (error 'timeout-error :socket socket :real-error condition))
+    (ccl::socket-creation-error #| ugh! |#
+       (raise-error-from-id (ccl::socket-creation-error-identifier condition)
+                            socket condition))))
+
+(defun to-format (element-type)
+  (if (subtypep element-type 'character)
+      :text
+    :binary))
+
+(defun socket-connect (host port &key (element-type 'character) timeout deadline nodelay)
+  (with-mapped-conditions ()
+    (let ((mcl-sock
+           (openmcl-socket:make-socket :remote-host (host-to-hostname host)
+                                       :remote-port port
+                                       :format (to-format element-type)
+                                       :deadline deadline
+                                       :nodelay nodelay
+                                       :connect-timeout (and timeout
+                                                             (* timeout internal-time-units-per-second)))))
+      (openmcl-socket:socket-connect mcl-sock)
+      (make-stream-socket :stream mcl-sock :socket mcl-sock))))
+
+(defun socket-listen (host port
+                           &key reuseaddress
+                           (reuse-address nil reuse-address-supplied-p)
+                           (backlog 5)
+                           (element-type 'character))
+  (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress))
+         (sock (with-mapped-conditions ()
+                  (apply #'openmcl-socket:make-socket
+                         (append (list :connect :passive
+                                       :reuse-address reuseaddress
+                                       :local-port port
+                                       :backlog backlog
+                                       :format (to-format element-type))
+                                 (when (ip/= host *wildcard-host*)
+                                   (list :local-host host)))))))
+    (make-stream-server-socket sock :element-type element-type)))
+
+(defmethod socket-accept ((usocket stream-server-usocket) &key element-type)
+  (declare (ignore element-type)) ;; openmcl streams are bi/multivalent
+  (let ((sock (with-mapped-conditions (usocket)
+                 (openmcl-socket:accept-connection (socket usocket)))))
+    (make-stream-socket :socket sock :stream sock)))
+
+;; One close method is sufficient because sockets
+;; and their associated objects are represented
+;; by the same object.
+(defmethod socket-close ((usocket usocket))
+  (with-mapped-conditions (usocket)
+    (close (socket usocket))))
+
+(defmethod get-local-address ((usocket usocket))
+  (hbo-to-vector-quad (openmcl-socket:local-host (socket usocket))))
+
+(defmethod get-peer-address ((usocket stream-usocket))
+  (hbo-to-vector-quad (openmcl-socket:remote-host (socket usocket))))
+
+(defmethod get-local-port ((usocket usocket))
+  (openmcl-socket:local-port (socket usocket)))
+
+(defmethod get-peer-port ((usocket stream-usocket))
+  (openmcl-socket:remote-port (socket usocket)))
+
+(defmethod get-local-name ((usocket usocket))
+  (values (get-local-address usocket)
+          (get-local-port usocket)))
+
+(defmethod get-peer-name ((usocket stream-usocket))
+  (values (get-peer-address usocket)
+          (get-peer-port usocket)))
+
+(defun get-host-by-address (address)
+  (with-mapped-conditions ()
+     (openmcl-socket:ipaddr-to-hostname (host-to-hbo address))))
+
+(defun get-hosts-by-name (name)
+  (with-mapped-conditions ()
+     (list (hbo-to-vector-quad (openmcl-socket:lookup-hostname
+                                (host-to-hostname name))))))
+
+(defun wait-for-input-internal (sockets &key timeout)
+  (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))))
+
+

Added: usocket/branches/hans/backend/sbcl.lisp
==============================================================================
--- (empty file)
+++ usocket/branches/hans/backend/sbcl.lisp	Sat Jul 19 08:00:01 2008
@@ -0,0 +1,332 @@
+;;;; $Id: sbcl.lisp 335 2008-04-23 21:29:50Z hhubner $
+;;;; $URL: svn://common-lisp.net/project/usocket/svn/usocket/branches/hans/backend/sbcl.lisp $
+
+;;;; See LICENSE for licensing information.
+
+(in-package :usocket)
+
+;; There's no way to preload the sockets library other than by requiring it
+;;
+;; ECL sockets has been forked off sb-bsd-sockets and implements the
+;; same interface. We use the same file for now.
+#+ecl
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (require :sockets))
+
+#+sbcl
+(progn
+  #-win32
+  (defun get-host-name ()
+    (sb-unix:unix-gethostname))
+
+  ;; we assume winsock has already been loaded, after all,
+  ;; we already loaded sb-bsd-sockets and sb-alien
+  #+win32
+  (defun get-host-name ()
+    (sb-alien:with-alien ((buf (sb-alien:array sb-alien:char 256)))
+       (let ((result (sb-alien:alien-funcall
+                      (sb-alien:extern-alien "gethostname"
+                                             (sb-alien:function sb-alien:int
+                                                                (* sb-alien:char)
+                                                                sb-alien:int))
+                      (sb-alien:cast buf (* sb-alien:char))
+                      256)))
+         (when (= result 0)
+           (sb-alien:cast buf sb-alien:c-string))))))
+
+
+#+ecl
+(progn
+  #-:wsock
+  (ffi:clines
+   "#include <errno.h>"
+   "#include <sys/socket.h>")
+  #+:wsock
+  (ffi:clines
+   "#ifndef FD_SETSIZE"
+   "#define FD_SETSIZE 1024"
+   "#endif"
+   "#include <winsock2.h>")
+
+  (ffi:clines
+   "#include <ecl/ecl-inl.h>")
+
+  #+:prefixed-api
+  (ffi:clines
+   "#define CONS(x, y) ecl_cons((x), (y))"
+   "#define MAKE_INTEGER(x) ecl_make_integer((x))")
+  #-:prefixed-api
+  (ffi:clines
+   "#define CONS(x, y) make_cons((x), (y))"
+   "#define MAKE_INTEGER(x) make_integer((x))")
+
+  (defun fd-setsize ()
+    (ffi:c-inline () () :fixnum
+     "FD_SETSIZE" :one-liner t))
+
+  (defun get-host-name ()
+    (ffi:c-inline
+     () () :object
+     "{ char *buf = GC_malloc(256);
+
+        if (gethostname(buf,256) == 0)
+          @(return) = make_simple_base_string(buf);
+        else
+          @(return) = Cnil;
+      }" :one-liner nil :side-effects nil))
+
+  (defun read-select (read-fds to-secs &optional (to-musecs 0))
+    (ffi:c-inline (read-fds to-secs to-musecs) (t t :unsigned-int) (values t t)
+      "{
+          fd_set rfds;
+          cl_object cur_fd = #0;
+          int count;
+          int max_fd = -1;
+          struct timeval tv;
+
+          FD_ZERO(&rfds);
+          while (CONSP(cur_fd)) {
+            int fd = fixint(CAR(cur_fd));
+            max_fd = (max_fd > fd) ? max_fd : fd;
+            FD_SET(fd, &rfds);
+            cur_fd = CDR(cur_fd);
+          }
+
+          if (#1 != Cnil) {
+            tv.tv_sec = fixnnint(#1);
+            tv.tv_usec = #2;
+          }
+          count = select(max_fd + 1, &rfds, NULL, NULL,
+                         (#1 != Cnil) ? &tv : NULL);
+
+          if (count == 0) {
+            @(return 0) = Cnil;
+            @(return 1) = Cnil;
+          } else if (count < 0) {
+            /*###FIXME: We should be raising an error here...
+
+              except, ofcourse in case of EINTR or EAGAIN */
+
+            @(return 0) = Cnil;
+            @(return 1) = MAKE_INTEGER(errno);
+          } else
+            {
+              cl_object rv = Cnil;
+              cur_fd = #0;
+
+              /* when we're going to use the same code on Windows,
+                 as well as unix, we can't be sure it'll fit into
+                 a fixnum: these aren't unix filehandle bitmaps sets on
+                 Windows... */
+
+              while (CONSP(cur_fd)) {
+                int fd = fixint(CAR(cur_fd));
+                if (FD_ISSET(fd, &rfds))
+                  rv = CONS(MAKE_INTEGER(fd), rv);
+
+                cur_fd = CDR(cur_fd);
+              }
+              @(return 0) = rv;
+              @(return 1) = Cnil;
+            }
+}"))
+
+)
+
+(defun map-socket-error (sock-err)
+  (map-errno-error (sb-bsd-sockets::socket-error-errno sock-err)))
+
+(defparameter +sbcl-condition-map+
+  '((interrupted-error . interrupted-condition)))
+
+(defparameter +sbcl-error-map+
+  `((sb-bsd-sockets:address-in-use-error . address-in-use-error)
+    (sb-bsd-sockets::no-address-error . address-not-available-error)
+    (sb-bsd-sockets:bad-file-descriptor-error . bad-file-descriptor-error)
+    (sb-bsd-sockets:connection-refused-error . connection-refused-error)
+    (sb-bsd-sockets:invalid-argument-error . invalid-argument-error)
+    (sb-bsd-sockets:no-buffers-error . no-buffers-error)
+    (sb-bsd-sockets:operation-not-supported-error
+     . operation-not-supported-error)
+    (sb-bsd-sockets:operation-not-permitted-error
+     . operation-not-permitted-error)
+    (sb-bsd-sockets:protocol-not-supported-error
+     . protocol-not-supported-error)
+    #-ecl
+    (sb-bsd-sockets:unknown-protocol
+     . protocol-not-supported-error)
+    (sb-bsd-sockets:socket-type-not-supported-error
+     . socket-type-not-supported-error)
+    (sb-bsd-sockets:network-unreachable-error . network-unreachable-error)
+    (sb-bsd-sockets:operation-timeout-error . timeout-error)
+    (sb-bsd-sockets:socket-error . ,#'map-socket-error)
+
+    ;; Nameservice errors: mapped to unknown-error
+    #-ecl #-ecl #-ecl
+    (sb-bsd-sockets:no-recovery-error . ns-no-recovery-error)
+    (sb-bsd-sockets:try-again-error . ns-try-again-condition)
+    (sb-bsd-sockets:host-not-found-error . ns-host-not-found-error)))
+
+(defun handle-condition (condition &optional (socket nil))
+  "Dispatch correct usocket condition."
+  (typecase condition
+    (error (let* ((usock-error (cdr (assoc (type-of condition)
+                                           +sbcl-error-map+)))
+                  (usock-error (if (functionp usock-error)
+                                   (funcall usock-error condition)
+                                 usock-error)))
+             (when usock-error
+                 (error usock-error :socket socket))))
+    (condition (let* ((usock-cond (cdr (assoc (type-of condition)
+                                              +sbcl-condition-map+)))
+                      (usock-cond (if (functionp usock-cond)
+                                      (funcall usock-cond condition)
+                                    usock-cond)))
+                 (if usock-cond
+                     (signal usock-cond :socket socket))))))
+
+
+(defun socket-connect (host port &key (element-type 'character) timeout deadline nodelay)
+  (declare (ignore nodelay))
+  (declare (ignore deadline))
+  (when timeout
+    (warn "SOCKET-CONNECT timeout not supported in SBCL"))
+  (let* ((socket (make-instance 'sb-bsd-sockets:inet-socket
+                                :type :stream :protocol :tcp))
+         (stream (sb-bsd-sockets:socket-make-stream socket
+                                                    :input t
+                                                    :output t
+                                                    :buffering :full
+                                                    :element-type element-type))
+         ;;###FIXME: The above line probably needs an :external-format
+         (usocket (make-stream-socket :stream stream :socket socket))
+         (ip (host-to-vector-quad host)))
+    (with-mapped-conditions (usocket)
+      (sb-bsd-sockets:socket-connect socket ip port))
+    usocket))
+
+(defun socket-listen (host port
+                           &key reuseaddress
+                           (reuse-address nil reuse-address-supplied-p)
+                           (backlog 5)
+                           (element-type 'character))
+  (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress))
+         (ip (host-to-vector-quad host))
+         (sock (make-instance 'sb-bsd-sockets:inet-socket
+                              :type :stream :protocol :tcp)))
+    (with-mapped-conditions ()
+       (setf (sb-bsd-sockets:sockopt-reuse-address sock) reuseaddress)
+       (sb-bsd-sockets:socket-bind sock ip port)
+       (sb-bsd-sockets:socket-listen sock backlog)
+       (make-stream-server-socket sock :element-type element-type))))
+
+(defmethod socket-accept ((socket stream-server-usocket) &key element-type)
+  (with-mapped-conditions (socket)
+     (let ((sock (sb-bsd-sockets:socket-accept (socket socket))))
+       (make-stream-socket
+        :socket sock
+        :stream (sb-bsd-sockets:socket-make-stream
+                 sock
+                 :input t :output t :buffering :full
+                 :element-type (or element-type
+                                   (element-type socket)))))))
+
+;; Sockets and their associated streams are modelled as
+;; different objects. Be sure to close the stream (which
+;; closes the socket too) when closing a stream-socket.
+(defmethod socket-close ((usocket usocket))
+  (with-mapped-conditions (usocket)
+    (sb-bsd-sockets:socket-close (socket usocket))))
+
+(defmethod socket-close ((usocket stream-usocket))
+  (with-mapped-conditions (usocket)
+    (close (socket-stream usocket))))
+
+(defmethod get-local-name ((usocket usocket))
+  (sb-bsd-sockets:socket-name (socket usocket)))
+
+(defmethod get-peer-name ((usocket stream-usocket))
+  (sb-bsd-sockets:socket-peername (socket usocket)))
+
+(defmethod get-local-address ((usocket usocket))
+  (nth-value 0 (get-local-name usocket)))
+
+(defmethod get-peer-address ((usocket stream-usocket))
+  (nth-value 0 (get-peer-name usocket)))
+
+(defmethod get-local-port ((usocket usocket))
+  (nth-value 1 (get-local-name usocket)))
+
+(defmethod get-peer-port ((usocket stream-usocket))
+  (nth-value 1 (get-peer-name usocket)))
+
+
+(defun get-host-by-address (address)
+  (with-mapped-conditions ()
+    (sb-bsd-sockets::host-ent-name
+        (sb-bsd-sockets:get-host-by-address address))))
+
+(defun get-hosts-by-name (name)
+  (with-mapped-conditions ()
+     (sb-bsd-sockets::host-ent-addresses
+         (sb-bsd-sockets:get-host-by-name name))))
+
+#+sbcl
+(progn
+  #-win32
+  (defun wait-for-input-internal (sockets &key timeout)
+    (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 (null count)
+		 (unless (= err sb-unix:EINTR)
+		   (error (map-errno-error err)))
+		 (when (< 0 count)
+		   ;; process the result...
+		   (remove-if
+		    #'(lambda (x)
+			(not (sb-unix:fd-isset
+			      (sb-bsd-sockets:socket-file-descriptor (socket x))
+			      rfds)))
+		    sockets))))))))
+
+  #+win32
+  (warn "wait-for-input not (yet!) supported...")
+  )
+
+#+ecl
+(progn
+  (defun wait-for-input-internal (sockets &key timeout)
+    (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))))
+	  (multiple-value-bind
+		(result-fds err)
+	      (read-select sock-fds (when timeout secs) usecs)
+	    (if (null err)
+		(remove-if #'(lambda (s)
+			       (not
+				(member
+				 (sb-bsd-sockets:socket-file-descriptor
+				  (socket s))
+				 result-fds)))
+			   sockets)
+		(error (map-errno-error err))))))))
+  )

Added: usocket/branches/hans/backend/scl.lisp
==============================================================================
--- (empty file)
+++ usocket/branches/hans/backend/scl.lisp	Sat Jul 19 08:00:01 2008
@@ -0,0 +1,170 @@
+;;;; $Id: scl.lisp 335 2008-04-23 21:29:50Z hhubner $
+;;;; $URL: svn://common-lisp.net/project/usocket/svn/usocket/branches/hans/backend/scl.lisp $
+
+;;;; See LICENSE for licensing information.
+
+(in-package :usocket)
+
+(defparameter +scl-error-map+
+  (append +unix-errno-condition-map+
+          +unix-errno-error-map+))
+
+(defun scl-map-socket-error (err &key condition socket)
+  (let ((usock-err (cdr (assoc err +scl-error-map+ :test #'member))))
+    (cond (usock-err
+       (if (subtypep usock-err 'error)
+           (error usock-err :socket socket)
+           (signal usock-err :socket socket)))
+      (t
+       (error 'unknown-error
+          :socket socket
+          :real-error condition)))))
+
+(defun handle-condition (condition &optional (socket nil))
+  "Dispatch correct usocket condition."
+  (etypecase condition
+    (ext::socket-error
+     (scl-map-socket-error (ext::socket-errno condition)
+               :socket socket
+               :condition condition))))
+
+(defun socket-connect (host port &key (element-type 'character) timeout nodelay)
+  (declare (ignore nodelay))
+  (when timeout
+    (warn "SOCKET-CONNECT timeout not supported in SCL"))
+  (let* ((socket (with-mapped-conditions ()
+                  (ext:connect-to-inet-socket (host-to-hbo host) port
+                                              :kind :stream)))
+         (stream (sys:make-fd-stream socket :input t :output t
+                                     :element-type element-type
+                                     :buffering :full)))
+    (make-stream-socket :socket socket :stream stream)))
+
+(defun socket-listen (host port
+                           &key reuseaddress
+                           (reuse-address nil reuse-address-supplied-p)
+                           (backlog 5)
+                           (element-type 'character))
+  (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress))
+         (host (if (ip= host *wildcard-host*)
+                   0
+                 (host-to-hbo host)))
+         (server-sock
+          (with-mapped-conditions ()
+            (ext:create-inet-listener port :stream
+                                      :host host
+                                      :reuse-address reuseaddress
+                                      :backlog backlog))))
+   (make-stream-server-socket server-sock :element-type element-type)))
+
+(defmethod socket-accept ((usocket stream-server-usocket) &key element-type)
+  (with-mapped-conditions (usocket)
+    (let* ((sock (ext:accept-tcp-connection (socket usocket)))
+           (stream (sys:make-fd-stream sock :input t :output t
+                                      :element-type (or element-type
+                                                        (element-type usocket))
+                                      :buffering :full)))
+      (make-stream-socket :socket sock :stream stream))))
+
+;; Sockets and their associated streams are modelled as
+;; different objects. Be sure to close the socket stream
+;; when closing stream-sockets; it makes sure buffers
+;; are flushed and the socket is closed correctly afterwards.
+(defmethod socket-close ((usocket usocket))
+  "Close socket."
+  (with-mapped-conditions (usocket)
+    (ext:close-socket (socket usocket))))
+
+(defmethod socket-close ((usocket stream-usocket))
+  "Close socket."
+  (with-mapped-conditions (usocket)
+    (close (socket-stream usocket))))
+
+(defmethod get-local-name ((usocket usocket))
+  (multiple-value-bind (address port)
+      (with-mapped-conditions (usocket)
+        (ext:get-socket-host-and-port (socket usocket)))
+    (values (hbo-to-vector-quad address) port)))
+
+(defmethod get-peer-name ((usocket stream-usocket))
+  (multiple-value-bind (address port)
+      (with-mapped-conditions (usocket)
+        (ext:get-peer-host-and-port (socket usocket)))
+    (values (hbo-to-vector-quad address) port)))
+
+(defmethod get-local-address ((usocket usocket))
+  (nth-value 0 (get-local-name usocket)))
+
+(defmethod get-peer-address ((usocket stream-usocket))
+  (nth-value 0 (get-peer-name usocket)))
+
+(defmethod get-local-port ((usocket usocket))
+  (nth-value 1 (get-local-name usocket)))
+
+(defmethod get-peer-port ((usocket stream-usocket))
+  (nth-value 1 (get-peer-name usocket)))
+
+
+(defun get-host-by-address (address)
+  (multiple-value-bind (host errno)
+      (ext:lookup-host-entry (host-byte-order address))
+    (cond (host
+           (ext:host-entry-name host))
+          (t
+           (let ((condition (cdr (assoc errno +unix-ns-error-map+))))
+             (cond (condition
+                    (error condition :host-or-ip address))
+                   (t
+                    (error 'ns-unknown-error :host-or-ip address
+                           :real-error errno))))))))
+
+(defun get-hosts-by-name (name)
+  (multiple-value-bind (host errno)
+      (ext:lookup-host-entry name)
+    (cond (host
+           (mapcar #'hbo-to-vector-quad
+                   (ext:host-entry-addr-list host)))
+          (t
+           (let ((condition (cdr (assoc errno +unix-ns-error-map+))))
+             (cond (condition
+                    (error condition :host-or-ip name))
+                   (t
+                    (error 'ns-unknown-error :host-or-ip name
+                           :real-error errno))))))))
+
+(defun get-host-name ()
+  (unix:unix-gethostname))
+
+(defun wait-for-input-internal (sockets &key timeout)
+  (let* ((pollfd-size (alien:alien-size (alien:struct unix::pollfd) :bytes))
+        (nfds (length sockets))
+        (bytes (* nfds pollfd-size)))
+    (alien:with-bytes (fds-sap bytes)
+      (do ((sockets sockets (rest sockets))
+          (base 0 (+ base 8)))
+         ((endp sockets))
+       (let ((fd (socket (first sockets))))
+         (setf (sys:sap-ref-32 fds-sap base) fd)
+         (setf (sys:sap-ref-16 fds-sap (+ base 4)) unix::pollin)))
+      (multiple-value-bind (result errno)
+         (let ((thread:*thread-whostate* "Poll wait")
+               (timeout (if timeout
+                            (truncate (* timeout 1000))
+                            -1)))
+           (declare (inline unix:unix-poll))
+           (unix:unix-poll (alien:sap-alien fds-sap
+                                            (* (alien:struct unix::pollfd)))
+                           nfds timeout))
+       (cond ((not result)
+              (error "~@<Polling error: ~A~:@>"
+                     (unix:get-unix-error-msg errno)))
+             (t
+              (do ((sockets sockets (rest sockets))
+                   (base 0 (+ base 8))
+                   (ready nil))
+                  ((endp sockets)
+                   (nreverse ready))
+                (let ((flags (sys:sap-ref-16 fds-sap (+ base 6))))
+                  (unless (zerop (logand flags unix::pollin))
+                    (push (first sockets) ready))))))))))
+

Added: usocket/branches/hans/condition.lisp
==============================================================================
--- (empty file)
+++ usocket/branches/hans/condition.lisp	Sat Jul 19 08:00:01 2008
@@ -0,0 +1,168 @@
+;;;; $Id: condition.lisp 325 2008-04-11 21:12:29Z ehuelsmann $
+;;;; $URL: svn://common-lisp.net/project/usocket/svn/usocket/branches/hans/condition.lisp $
+
+;;;; See LICENSE for licensing information.
+
+(in-package :usocket)
+
+;; Condition raised by operations with unsupported arguments
+;; For trivial-sockets compatibility.
+
+(define-condition unsupported (error)
+  ((feature :initarg :feature :reader unsupported-feature)))
+
+
+;; Conditions raised by sockets operations
+
+(define-condition socket-condition (condition)
+  ((socket :initarg :socket
+           :accessor usocket-socket))
+  ;;###FIXME: no slots (yet); should at least be the affected usocket...
+  (:documentation "Parent condition for all socket related conditions."))
+
+(define-condition socket-error (socket-condition error)
+  () ;; no slots (yet)
+  (:documentation "Parent error for all socket related errors"))
+
+(define-condition ns-condition (condition)
+  ((host-or-ip :initarg :host-or-ip
+               :accessor host-or-ip))
+  (:documentation "Parent condition for all name resolution conditions."))
+
+(define-condition ns-error (ns-condition error)
+  ()
+  (:documentation "Parent error for all name resolution errors."))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defun define-usocket-condition-class (class &rest parents)
+    `(progn
+       (define-condition ,class ,parents ())
+       (export ',class))))
+
+(defmacro define-usocket-condition-classes (class-list parents)
+  `(progn ,@(mapcar #'(lambda (x)
+                        (apply #'define-usocket-condition-class
+                               x parents))
+                    class-list)))
+
+;; Mass define and export our conditions
+(define-usocket-condition-classes
+  (interrupted-condition)
+  (socket-condition))
+
+(define-condition unknown-condition (socket-condition)
+  ((real-condition :initarg :real-condition
+                   :accessor usocket-real-condition))
+  (:documentation "Condition raised when there's no other - more applicable -
+condition available."))
+
+
+;; Mass define and export our errors
+(define-usocket-condition-classes
+  (address-in-use-error
+   address-not-available-error
+   bad-file-descriptor-error
+   connection-refused-error
+   connection-aborted-error
+   connection-reset-error
+   invalid-argument-error
+   no-buffers-error
+   operation-not-supported-error
+   operation-not-permitted-error
+   protocol-not-supported-error
+   socket-type-not-supported-error
+   network-unreachable-error
+   network-down-error
+   network-reset-error
+   host-down-error
+   host-unreachable-error
+   shutdown-error
+   timeout-error
+   invalid-socket-error
+   invalid-socket-stream-error)
+  (socket-error))
+
+(define-condition unknown-error (socket-error)
+  ((real-error :initarg :real-error
+               :accessor usocket-real-error))
+  (:documentation "Error raised when there's no other - more applicable -
+error available."))
+
+
+(define-usocket-condition-classes
+  (ns-try-again)
+  (ns-condition))
+
+(define-condition ns-unknown-condition (ns-condition)
+  ((real-error :initarg :real-condition
+               :accessor ns-real-condition))
+  (:documentation "Condition raised when there's no other - more applicable -
+condition available."))
+
+(define-usocket-condition-classes
+  ;; the no-data error code in the Unix 98 api
+  ;; isn't really an error: there's just no data to return.
+  ;; with lisp, we just return NIL (indicating no data) instead of
+  ;; raising an exception...
+  (ns-host-not-found-error
+   ns-no-recovery-error)
+  (ns-error))
+
+(define-condition ns-unknown-error (ns-error)
+  ((real-error :initarg :real-error
+               :accessor ns-real-error))
+  (:documentation "Error raised when there's no other - more applicable -
+error available."))
+
+(defmacro with-mapped-conditions ((&optional socket) &body body)
+  `(handler-bind ((condition #'(lambda (c) (handle-condition c ,socket))))
+    , at body))
+
+(defparameter +unix-errno-condition-map+
+  `(((11) . retry-condition) ;; EAGAIN
+    ((35) . retry-condition) ;; EDEADLCK
+    ((4) . interrupted-condition))) ;; EINTR
+
+(defparameter +unix-errno-error-map+
+  ;;### the first column is for non-(linux or srv4) systems
+  ;; the second for linux
+  ;; the third for srv4
+  ;;###FIXME: How do I determine on which Unix we're running
+  ;;          (at least in clisp and sbcl; I know about cmucl...)
+  ;; The table below works under the assumption we'll *only* see
+  ;; socket associated errors...
+  `(((48 98) . address-in-use-error)
+    ((49 99) . address-not-available-error)
+    ((9) . bad-file-descriptor-error)
+    ((61 111) . connection-refused-error)
+    ((64 131) . connection-reset-error)
+    ((130) . connection-aborted-error)
+    ((22) . invalid-argument-error)
+    ((55 105) . no-buffers-error)
+    ((12) . out-of-memory-error)
+    ((45 95) . operation-not-supported-error)
+    ((1) . operation-not-permitted-error)
+    ((43 92) . protocol-not-supported-error)
+    ((44 93) . socket-type-not-supported-error)
+    ((51 101) . network-unreachable-error)
+    ((50 100) . network-down-error)
+    ((52 102) . network-reset-error)
+    ((58 108) . already-shutdown-error)
+    ((60 110) . timeout-error)
+    ((64 112) . host-down-error)
+    ((65 113) . host-unreachable-error)))
+
+
+(defun map-errno-condition (errno)
+  (cdr (assoc errno +unix-errno-error-map+ :test #'member)))
+
+
+(defun map-errno-error (errno)
+  (cdr (assoc errno +unix-errno-error-map+ :test #'member)))
+
+
+(defparameter +unix-ns-error-map+
+  `((1 . ns-host-not-found-error)
+    (2 . ns-try-again-condition)
+    (3 . ns-no-recovery-error)))
+

Added: usocket/branches/hans/doc/backends.txt
==============================================================================
--- (empty file)
+++ usocket/branches/hans/doc/backends.txt	Sat Jul 19 08:00:01 2008
@@ -0,0 +1,59 @@
+                                                                -*- text -*-
+
+$Id: backends.txt 182 2007-01-19 23:43:12Z ehuelsmann $
+
+A document to describe which APIs a backend should implement.
+
+
+Each backend should implement:
+
+Functions:
+
+ - handle-condition
+ - socket-connect
+ - socket-listen
+ - get-hosts-by-name [ optional ]
+ - get-host-by-address [ optional ]
+
+
+Methods:
+
+ - socket-close
+ - socket-accept
+ - get-local-name
+ - get-peer-name
+
+ and - for ip sockets - these methods:
+
+ - get-local-address
+ - get-local-port
+ - get-peer-address
+ - get-peer-port
+
+
+An error-handling function, resolving implementation specific errors
+to this list of errors:
+
+ - address-in-use-error
+ - address-not-available-error
+ - bad-file-descriptor-error
+ - connection-refused-error
+ - invalid-argument-error
+ - no-buffers-error
+ - operation-not-supported-error
+ - operation-not-permitted-error
+ - protocol-not-supported-error
+ - socket-type-not-supported-error
+ - network-unreachable-error
+ - network-down-error
+ - network-reset-error
+ - host-down-error
+ - host-unreachable-error
+ - shutdown-error
+ - timeout-error
+ - unkown-error
+
+and these conditions:
+
+ - interrupted-condition
+ - unkown-condition

Added: usocket/branches/hans/doc/design.txt
==============================================================================
--- (empty file)
+++ usocket/branches/hans/doc/design.txt	Sat Jul 19 08:00:01 2008
@@ -0,0 +1,136 @@
+
+                                                        -*- text -*-
+
+$Id: design.txt 122 2006-10-22 08:42:00Z ehuelsmann $
+
+
+                  usocket: Universal sockets library
+                  ==================================
+
+Contents
+========
+
+ * Motivation
+ * Design goal
+ * Functional requirements
+ * Class structure
+
+
+

+Motivation
+==========
+
+There are 2 other portability sockets packages [that I know of]
+out there:
+
+ 1) trivial-sockets
+ 2) acl-compat (which is a *lot* broader, but contains sockets too)
+
+The first misses some functionality which is fundamental when
+the requirements stop being 'trivial', such as finding out the
+addresses of either side connected to the tcp/ip stream.
+
+The second, being a complete compatibility library for Allegro,
+contains much more than only sockets.  Next to that, as the docs
+say, is it mainly directed at providing the functionality required
+to port portable-allegroserve - meaning it may be (very) incomplete
+on some platforms.
+
+So, that's why I decided to inherit Erik Enge's project to build
+a library with the intention to provide portability code in only
+1 area of programming, targeted at 'not so trivial' programming.
+
+Also, I need this library to extend cl-irc with full DCC functionality.
+
+
+

+Design goal
+===========
+
+To provide a portable TCP/IP socket interface for as many
+implementations as possible, while keeping the portability layer
+as thin as possible.
+
+
+

+Functional requirements
+=======================
+
+The interface provided should allow:
+ - 'client'/active sockets
+ - 'server'/listening sockets
+ - provide the usual stream methods to operate on the connection stream
+   (not necessarily the socket itself; maybe a socket slot too)
+
+For now, as long as there are no possibilities to have UDP sockets
+to write a DNS client library: (which in the end may work better,
+because in this respect all implementations are different...)
+ - retrieve IP addresses/ports for both sides of the connection
+
+Several relevant support functionalities will have to be provided too:
+ - long <-> quad-vector operators
+ - quad-vector <-> string operators
+ - hostname <-> quad-vector operators (hostname resolution)
+
+
+Minimally, I'd like to support:
+ - SBCL
+ - CMUCL
+ - ABCL (ArmedBear)
+ - clisp
+ - Allegro
+ - LispWorks
+ - OpenMCL
+
+
+Comments on the design above
+============================
+
+I don't think it's a good idea to implement name lookup in the
+very first of steps: we'll see if this is required to get the
+package accepted; not all implementations support it.
+
+Name resolution errors ...
+Since there is no name resolution library (yet), nor standardized
+hooks into the standard C library to do it the same way on
+all platforms, name resolution errors can manifest themselves
+in a lot of different ways.  How to marshall these to the
+library users?
+
+Several solutions come to mind:
+
+1) Map them to 'unknown-error
+2) Give them their own errors and map to those
+   ... which implies that they are actually supported atm.
+3) ...
+
+Given that the library doesn't now, but may in the future,
+include name resolution officially, I tend to think (1) is the
+right answer: it leaves it all undecided.
+
+These errors can be raised by the nameresolution service
+(netdb.h) as values for 'int h_errno':
+
+- HOST_NOT_FOUND (1)
+- TRY_AGAIN      (2) /* Server fail or non-authoritive Host not found */
+- NO_RECOVERY    (3) /* Failed permanently */
+- NO_DATA        (4) /* Valid address, no data for requested record */
+
+int *__h_errno_location(void) points to thread local h_errno on
+threaded glibc2 systems.
+
+

+Class structure
+===============
+
+ usocket
+  |
+  +- datagram-usocket
+  +- stream-usocket
+  \- stream-server-usocket
+
+The usocket class will have methods to query local properties, such
+as:
+
+ - get-local-name: to query to which interface the socket is bound
+ - <other socket and protocol options such as SO_REUSEADDRESS>

Added: usocket/branches/hans/notes/abcl-socket.txt
==============================================================================
--- (empty file)
+++ usocket/branches/hans/notes/abcl-socket.txt	Sat Jul 19 08:00:01 2008
@@ -0,0 +1,18 @@
+
+ABCL provides a callback interface to java objects, next to these calls:
+
+ - ext:make-socket
+ - ext:socket-close
+ - ext:make-server-socket
+ - ext:socket-accept
+ - ext:get-socket-stream (returning an io-stream)
+
+abcl-swank (see SLIME) shows how to call directly into java.
+
+
+See for the sockets implementation:
+
+ - src/org/armedbear/lisp
+   * socket.lisp
+   * socket_stream.java
+   * SocketStream.java

Added: usocket/branches/hans/notes/active-sockets-apis.txt
==============================================================================
--- (empty file)
+++ usocket/branches/hans/notes/active-sockets-apis.txt	Sat Jul 19 08:00:01 2008
@@ -0,0 +1,75 @@
+                                                          -*- text -*-
+
+A document to summarizing which API's of the different implementations
+are associated with 'Step 1'.
+
+Interface to be implemented in step 1:
+
+ - socket-connect
+ - socket-close
+ - get-host-by-address
+ - get-hosts-by-name
+
+(and something to do with errors; maybe move this to step 1a?)
+
+SBCL
+====
+
+  sockets:
+  - socket-bind
+  - make-instance 'inet-socket
+  - socket-make-stream
+  - socket-connect (ip vector-quad) port
+  - socket-close
+
+  DNS name resolution:
+  - get-host-by-name
+  - get-host-by-address
+  - ::host-ent-addresses
+  - host-ent-name
+
+
+CMUCL
+=====
+
+  sockets:
+  - ext:connect-to-inet-socket (ip integer) port
+  - sys:make-fd-stream
+  - ext:close-socket
+
+  DNS name resolution:
+  - ext:host-entry-name
+  - ext::lookup-host-entry
+  - ext:host-entry-addr-list
+  - ext:lookup-host-entry
+
+
+ABCL
+====
+
+  sockets
+  - ext:socket-connect (hostname string) port
+  - ext:get-socket-stream
+  - ext:socket-close
+
+
+clisp
+=====
+
+  sockets
+  - socket-connect port (hostname string)
+  - close (socket)
+
+
+Allegro
+=======
+
+  sockets
+  - make-socket
+  - socket-connect
+  - close
+
+  DNS resolution
+  - lookup-hostname
+  - ipaddr-to-hostname
+

Added: usocket/branches/hans/notes/address-apis.txt
==============================================================================
--- (empty file)
+++ usocket/branches/hans/notes/address-apis.txt	Sat Jul 19 08:00:01 2008
@@ -0,0 +1,73 @@
+
+                                                           -*- text -*-
+
+Step 2 of the master plan: Implementing (get-local-address sock) and
+(get-peer-address sock).
+
+
+Step 2 is about implementing:
+
+ (get-local-address sock) -> ip
+ (get-peer-address sock) -> ip
+ (get-local-port sock) -> port
+ (get-peer-port sock) -> port
+ (get-local-name sock) -> ip, port
+ (get-peer-name sock) -> ip, port
+
+
+ABCL
+====
+
+ FFI / J-calls to "getLocalAddress"+"getAddress", "getLocalPort" (local)
+ FFI / J-calls to "getInetAddress"+"getAddress", "getPort" (peer)
+
+ (see SLIME / swank-abcl.lisp for an example on how to do that)
+
+
+Allegro
+=======
+
+ (values (socket:remote-host sock)
+         (socket:remote-port)) -> 32bit ip, port
+
+ (values (socket:local-host sock)
+         (socket:local-port sock)) -> 32bit ip, port
+
+CLISP
+=====
+
+ (socket:socket-stream-local sock nil) -> address (as dotted quad), port
+ (socket:socket-stream-peer sock nil) -> address (as dotted quad), port
+
+
+CMUCL
+=====
+
+ (ext:get-peer-host-and-port sock-fd) -> 32-bit-addr, port (peer)
+ (ext:get-socket-host-and-port sock-fd) -> 32-bit-addr, port (local)
+
+
+LispWorks
+=========
+
+ (comm:socket-stream-address sock-stream) -> 32-bit-addr, port
+   or: (comm:get-socket-address sock) -> 32-bit-addr, port
+
+ (comm:socket-stream-peer-address sock-stream) -> 32-bit-addr, port
+   or: (comm:get-socket-peer-address sock) -> 32-bit-addr, port
+
+
+OpenMCL
+=======
+
+ (values (ccl:local-host sock) (ccl:local-port sock)) -> 32-bit ip, port
+ (values (ccl:remote-host sock) (ccl:remote-port sock)) -> 32-bit ip, port
+
+
+SBCL
+====
+
+ (sb-bsd-sockets:socket-name sock) -> vector-quad, port
+ (sb-bsd-sockets:socket-peer-name sock) -> vector-quad, port
+
+

Added: usocket/branches/hans/notes/allegro-socket.txt
==============================================================================
--- (empty file)
+++ usocket/branches/hans/notes/allegro-socket.txt	Sat Jul 19 08:00:01 2008
@@ -0,0 +1,46 @@
+
+
+(require :sock)
+
+accept-connection 	(sock passive-socket) &key wait 	Generic function. 
+dotted-to-ipaddr 	dotted &key errorp 	Function.
+ipaddr-to-dotted 	ipaddr &key values 	Function.
+ipaddr-to-hostname 	ipaddr 	Function.
+lookup-hostname 	hostname
+lookup-port 	portname protocol 	Function.
+make-socket 	&key type format address-family connect &allow-other-keys 	Function.
+with-pending-connect 	&body body 	Macro.
+receive-from 	(sock datagram-socket) size &key buffer extract 	Generic function.
+send-to 	sock &key
+shutdown 	sock &key direction 
+socket-control 	stream &key output-chunking output-chunking-eof input-chunking 
+socket-os-fd 	sock 	Generic function.
+
+remote-host 	socket 	Generic function.
+local-host 	socket 	Generic function.
+local-port 	socket
+
+remote-filename 	socket
+local-filename 	socket
+remote-port 	socket
+socket-address-family 	socket
+socket-connect 	socket
+socket-format 	socket
+socket-type 	socket
+
+errors
+
+:address-in-use 	Local socket address already in use
+:address-not-available 	Local socket address not available
+:network-down 	Network is down
+:network-reset 	Network has been reset
+:connection-aborted 	Connection aborted
+:connection-reset 	Connection reset by peer
+:no-buffer-space 	No buffer space
+:shutdown 	Connection shut down
+:connection-timed-out 	Connection timed out
+:connection-refused 	Connection refused
+:host-down 	Host is down
+:host-unreachable 	Host is unreachable
+:unknown 	Unknown error
+

Added: usocket/branches/hans/notes/clisp-sockets.txt
==============================================================================
--- (empty file)
+++ usocket/branches/hans/notes/clisp-sockets.txt	Sat Jul 19 08:00:01 2008
@@ -0,0 +1,38 @@
+http://clisp.cons.org/impnotes.html#socket
+
+(SOCKET:SOCKET-SERVER &OPTIONAL [port-or-socket])
+(SOCKET:SOCKET-SERVER-HOST socket-server)
+(SOCKET:SOCKET-SERVER-PORT socket-server)
+(SOCKET:SOCKET-WAIT socket-server &OPTIONAL [seconds [microseconds]])
+(SOCKET:SOCKET-ACCEPT socket-server &KEY :ELEMENT-TYPE :EXTERNAL-FORMAT :BUFFERED :TIMEOUT)
+(SOCKET:SOCKET-CONNECT port &OPTIONAL [host] &KEY :ELEMENT-TYPE :EXTERNAL-FORMAT :BUFFERED :TIMEOUT)
+(SOCKET:SOCKET-STATUS socket-stream-or-list &OPTIONAL [seconds [microseconds]])
+(SOCKET:SOCKET-STREAM-HOST socket-stream)
+(SOCKET:SOCKET-STREAM-PORT socket-stream)
+(SOCKET:SOCKET-SERVICE-PORT &OPTIONAL service-name (protocol "tcp"))
+(SOCKET:SOCKET-STREAM-PEER socket-stream [do-not-resolve-p])
+(SOCKET:SOCKET-STREAM-LOCAL socket-stream [do-not-resolve-p])
+(SOCKET:SOCKET-STREAM-SHUTDOWN socket-stream direction)
+(SOCKET:SOCKET-OPTIONS socket-server &REST {option}*)
+
+
+(posix:resolve-host-ipaddr &optional host)
+
+with the host-ent structure:
+
+  name      - host name
+  aliases   - LIST of aliases
+  addr-list - LIST of IPs as dotted quads (IPv4) or coloned octets (IPv6)
+  addrtype  - INTEGER address type IPv4 or IPv6
+
+
+Errors are of type
+
+SYSTEM::SIMPLE-OS-ERROR
+ with a 1 element (integer) SYSTEM::$FORMAT-ARGUMENTS list
+
+This integer stores the OS error reported; meaning WSA* codes on Win32
+and E* codes on *nix, only: unix.lisp in CMUCL shows
+BSD, Linux and SRV4 have different number assignments for the same
+E* constant names  :-(
+

Added: usocket/branches/hans/notes/cmucl-sockets.txt
==============================================================================
--- (empty file)
+++ usocket/branches/hans/notes/cmucl-sockets.txt	Sat Jul 19 08:00:01 2008
@@ -0,0 +1,69 @@
+http://cvs2.cons.org/ftp-area/cmucl/doc/cmu-user/internet.html
+
+$Id: cmucl-sockets.txt 91 2006-02-13 08:01:51Z ehuelsmann $
+
+extensions:lookup-host-entry host
+
+[structure]
+host-entry    
+
+    name aliases addr-type addr-list
+
+[Function]
+extensions:create-inet-listener port &optional kind &key :reuse-address :backlog :interface
+  => socket fd
+
+[Function]
+extensions:accept-tcp-connection unconnected
+  => socket fd, address
+
+[Function]
+extensions:connect-to-inet-socket host port &optional kind
+  => socket fd
+
+[Function]
+extensions:close-socket socket
+
+
+
+[Private function]
+extensions::get-peer-host-and-port socket-fd
+
+[Private function]
+extentsions::get-socket-host-and-port socket-fd
+
+
+
+There's currently only 1 condition to be raised:
+
+  SOCKET-ERROR (derived from SIMPLE-ERROR)
+    which has a SOCKET-ERRNO slot containing the unix error number.
+
+
+
+
+[Function]
+extensions:add-oob-handler fd char handler
+
+[Function]
+extensions:remove-oob-handler fd char
+
+[Function]
+extensions:remove-all-oob-handlers fd
+
+[Function]
+extensions:send-character-out-of-band fd char
+
+[Function]
+extensions:create-inet-socket &optional type
+  => socket fd
+
+[Function]
+extensions:get-socket-option socket level optname
+
+[Function]
+extensions:set-socket-option socket level optname optval
+
+[Function]
+extensions:ip-string addr    
+

Added: usocket/branches/hans/notes/errors.txt
==============================================================================
--- (empty file)
+++ usocket/branches/hans/notes/errors.txt	Sat Jul 19 08:00:01 2008
@@ -0,0 +1,20 @@
+EADDRINUSE 48 address-in-use-error
+EADDRNOTAVAIL 49 address-not-available-error
+EAGAIN interrupted-error  ;; not 1 error code: bsd == 11; non-bsd == 35
+EBADF 9 bad-file-descriptor-error
+ECONNREFUSED 61 connection-refused-error
+EINTR 4 interrupted-error
+EINVAL 22 invalid-argument-error
+ENOBUFS 55 no-buffers-error
+ENOMEM 12 out-of-memory-error
+EOPNOTSUPP 45 operation-not-supported-error
+EPERM 1 operation-not-permitted-error
+EPROTONOSUPPORT 43 protocol-not-supported-error
+ESOCKTNOSUPPORT 44 socket-type-not-supported-error
+ENETUNREACH 51 network-unreachable-error
+ENETDOWN 50 network-down-error
+ENETRESET 52 network-reset-error
+ESHUTDOWN 58 already-shutdown-error
+ETIMEDOUT 60 connection-timeout-error
+EHOSTDOWN 64 host-down-error
+EHOSTUNREACH 65 host-unreachable-error

Added: usocket/branches/hans/notes/lw-sockets.txt
==============================================================================
--- (empty file)
+++ usocket/branches/hans/notes/lw-sockets.txt	Sat Jul 19 08:00:01 2008
@@ -0,0 +1,41 @@
+
+$Id: lw-sockets.txt 91 2006-02-13 08:01:51Z ehuelsmann $
+
+http://www.lispworks.com/reference/lwu41/lwref/LWRM_37.HTM
+
+Package: COMM
+
+ip-address-string
+socket-stream-address
+socket-stream-peer-address
+start-up-server
+start-up-server-and-mp
+string-ip-address
+with-noticed-socket-stream
+
+Needed components for usocket:
+
+comm::get-fd-from-socket socket-fd
+  => socket-fd
+
+comm::accept-connection-to-socket socket-fd
+  => socket-fd
+
+comm::close-socket
+comm::create-tcp-socket-for-service
+  => socket-fd
+
+open-tcp-stream peer-host peer-port &key direction element-type
+  => socket-stream
+
+get-host-entry (see http://www.lispworks.com/documentation/lw445/LWRM/html/lwref-30.htm#pgfId-897837)
+get-socket-address
+
+get-socket-peer-address
+  => address, port
+
+socket-stream socket-fd
+  => stream
+
+socket socket-stream (guessed from http://www.lispworks.com/documentation/lw445/LWRM/html/lwref-43.htm)
+  => socket-fd

Added: usocket/branches/hans/notes/openmcl-sockets.txt
==============================================================================
--- (empty file)
+++ usocket/branches/hans/notes/openmcl-sockets.txt	Sat Jul 19 08:00:01 2008
@@ -0,0 +1,27 @@
+http://openmcl.clozure.com/Doc/sockets.html
+
+    make-socket [Function]
+    accept-connection [Function]
+    dotted-to-ipaddr [Function]
+    ipaddr-to-dotted [Function]
+    ipaddr-to-hostname [Function]
+    lookup-hostname [Function]
+    lookup-port [Function]
+    receive-from [Function]
+    send-to [Function]
+    shutdown [Function]
+    socket-os-fd [Function]
+    remote-port [Function]
+    local-host [Function]
+    local-port [Function]
+
+        socket-address-family [Function]
+
+    socket-connect [Function]
+    socket-format [Function]
+    socket-type [Function]
+    socket-error [Class]
+    socket-error-code [Function]
+    socket-error-identifier [Function]
+    socket-error-situation [Function]
+    close [method]

Added: usocket/branches/hans/notes/sb-bsd-sockets.txt
==============================================================================
--- (empty file)
+++ usocket/branches/hans/notes/sb-bsd-sockets.txt	Sat Jul 19 08:00:01 2008
@@ -0,0 +1,114 @@
+http://www.xach.com/sbcl/sb-bsd-sockets.html
+
+$Id: sb-bsd-sockets.txt 91 2006-02-13 08:01:51Z ehuelsmann $
+
+package: sb-bsd-sockets
+
+class: socket
+
+slots:
+
+    * file-descriptor :
+    * family :
+    * protocol :
+    * type :
+    * stream :
+
+operators:
+
+  (socket-bind (s socket) &rest address)	Generic Function
+  (socket-accept (socket socket))	Method
+  (socket-connect (s socket) &rest address)	Generic Function
+  (socket-peername (socket socket))	Method
+  (socket-name (socket socket))	Method
+  (socket-receive (socket socket) buffer length &key oob peek waitall (element-type 'character))	Method
+  (socket-listen (socket socket) backlog)	Method
+  (socket-close (socket socket))	Method
+  (socket-make-stream (socket socket) &rest args)	Method
+
+  (sockopt-reuse-address (socket socket) argument)	Accessor
+  (sockopt-keep-alive (socket socket) argument)	Accessor
+  (sockopt-oob-inline (socket socket) argument)	Accessor
+  (sockopt-bsd-compatible (socket socket) argument)	Accessor
+  (sockopt-pass-credentials (socket socket) argument)	Accessor
+  (sockopt-debug (socket socket) argument)	Accessor
+  (sockopt-dont-route (socket socket) argument)	Accessor
+  (sockopt-broadcast (socket socket) argument)	Accessor
+  (sockopt-tcp-nodelay (socket socket) argument)	Accessor
+
+inet-domain sockets
+
+class: inet-socket
+
+slots:
+
+    * family :
+
+operators:
+
+   (make-inet-address dotted-quads)	Function
+   (get-protocol-by-name name)	Function
+   (make-inet-socket type protocol)	Function
+
+file-domain sockets
+
+class: unix-socket
+
+slots:
+
+    * family :
+
+class: host-ent
+
+Slots:
+
+    * name :
+    * aliases :
+    * address-type :
+    * addresses :
+
+   (host-ent-address (host-ent host-ent))	Method
+   (get-host-by-name host-name)	Function
+   (get-host-by-address address)	Function
+   (name-service-error where)	Function
+   (non-blocking-mode (socket socket))	Method
+
+(define-socket-condition sockint::EADDRINUSE address-in-use-error)
+(define-socket-condition sockint::EAGAIN interrupted-error)
+(define-socket-condition sockint::EBADF bad-file-descriptor-error)
+(define-socket-condition sockint::ECONNREFUSED connection-refused-error)
+(define-socket-condition sockint::EINTR interrupted-error)
+(define-socket-condition sockint::EINVAL invalid-argument-error)
+(define-socket-condition sockint::ENOBUFS no-buffers-error)
+(define-socket-condition sockint::ENOMEM out-of-memory-error)
+(define-socket-condition sockint::EOPNOTSUPP operation-not-supported-error)
+(define-socket-condition sockint::EPERM operation-not-permitted-error)
+(define-socket-condition sockint::EPROTONOSUPPORT protocol-not-supported-error)
+(define-socket-condition sockint::ESOCKTNOSUPPORT socket-type-not-supported-error)
+(define-socket-condition sockint::ENETUNREACH network-unreachable-error)
+
+Exported errors:
+* (apropos "ERROR" :sb-bsd-sockets)
+
+SB-BSD-SOCKETS:INTERRUPTED-ERROR
+SB-BSD-SOCKETS:TRY-AGAIN-ERROR
+* SB-BSD-SOCKETS:NO-RECOVERY-ERROR (EFAIL?)
+SB-BSD-SOCKETS:CONNECTION-REFUSED-ERROR
+SB-BSD-SOCKETS:INVALID-ARGUMENT-ERROR
+* SB-BSD-SOCKETS:HOST-NOT-FOUND-ERROR
+SB-BSD-SOCKETS:OPERATION-NOT-PERMITTED-ERROR
+SB-BSD-SOCKETS:OPERATION-NOT-SUPPORTED-ERROR
+SB-BSD-SOCKETS:PROTOCOL-NOT-SUPPORTED-ERROR
+SB-BSD-SOCKETS:OPERATION-TIMEOUT-ERROR
+SB-BSD-SOCKETS:SOCKET-TYPE-NOT-SUPPORTED-ERROR
+SB-BSD-SOCKETS:NO-BUFFERS-ERROR
+SB-BSD-SOCKETS:NETWORK-UNREACHABLE-ERROR
+SB-BSD-SOCKETS:BAD-FILE-DESCRIPTOR-ERROR
+SB-BSD-SOCKETS:ADDRESS-IN-USE-ERROR
+SB-BSD-SOCKETS:OUT-OF-MEMORY-ERROR
+
+And 1 non-exported error:
+
+SB-BSD-SOCKETS::NO-ADDRESS-ERROR
+
+*-ed errors aren't yet addressed in the errorlist supported by usocket

Added: usocket/branches/hans/notes/usock-sockets.txt
==============================================================================
--- (empty file)
+++ usocket/branches/hans/notes/usock-sockets.txt	Sat Jul 19 08:00:01 2008
@@ -0,0 +1,28 @@
+Package:
+
+  clisp  : socket
+  cmucl  : extensions
+  sbcl   : sb-bsd-sockets
+  lw     : comm
+  openmcl: openmcl-socket
+  allegro: sock
+
+Connecting (TCP/inet only)
+
+  clisp  : socket-connect port &optional [host] &key :element-type :external-format :buffered :timeout = > socket-stream
+  cmucl  : connect-to-inet-socket host port &optional kind => file descriptor
+  sbcl   : sb-socket-connect socket &rest address => socket
+  lw     : open-tcp-stream hostname service &key direction element-type buffered => stream-object
+  openmcl: socket-connect socket => :active, :passive or nil
+  allegro: make-socket (&rest args &key type format connect address-family eol) => socket
+
+Closing
+
+  clisp  : close socket
+  cmucl  : close-socket socket
+  sbcl   : socket-close socket
+  lw     : close socket
+  openmcl: close socket
+  allegro: close socket
+
+Errors
\ No newline at end of file

Added: usocket/branches/hans/package.lisp
==============================================================================
--- (empty file)
+++ usocket/branches/hans/package.lisp	Sat Jul 19 08:00:01 2008
@@ -0,0 +1,62 @@
+;;;; $Id: package.lisp 326 2008-04-11 21:13:40Z ehuelsmann $
+;;;; $URL: svn://common-lisp.net/project/usocket/svn/usocket/branches/hans/package.lisp $
+
+;;;; See the LICENSE file for licensing information.
+
+#+lispworks (cl:require "comm")
+
+(cl:eval-when (:execute :load-toplevel :compile-toplevel)
+  (cl:defpackage :usocket
+      (:use :cl)
+    (:export #:*wildcard-host*
+             #:*auto-port*
+
+             #:socket-connect ; socket constructors and methods
+             #:socket-listen
+             #:socket-accept
+             #:socket-close
+             #:wait-for-input
+             #:get-local-address
+             #:get-peer-address
+             #:get-local-port
+             #:get-peer-port
+             #:get-local-name
+             #:get-peer-name
+
+             #:with-connected-socket ; convenience macros
+             #:with-server-socket
+             #:with-client-socket
+             #:with-socket-listener
+
+             #:usocket ; socket object and accessors
+             #:stream-usocket
+             #:stream-server-usocket
+             #:socket
+             #:socket-stream
+             #:datagram-usocket
+
+             #:host-byte-order ; IP(v4) utility functions
+             #:hbo-to-dotted-quad
+             #:hbo-to-vector-quad
+             #:vector-quad-to-dotted-quad
+             #:dotted-quad-to-vector-quad
+             #:ip=
+             #:ip/=
+
+             #:integer-to-octet-buffer ; Network utility functions
+             #:octet-buffer-to-integer
+             #:port-to-octet-buffer
+             #:port-from-octet-buffer
+             #:ip-to-octet-buffer
+             #:ip-from-octet-buffer
+
+             #:with-mapped-conditions
+             #:socket-condition ; conditions
+             #:ns-condition
+             #:socket-error ; errors
+             #:ns-error
+             #:unknown-condition
+             #:ns-unknown-condition
+             #:unknown-error
+             #:ns-unknown-error)))
+

Added: usocket/branches/hans/run-usocket-tests.sh
==============================================================================
--- (empty file)
+++ usocket/branches/hans/run-usocket-tests.sh	Sat Jul 19 08:00:01 2008
@@ -0,0 +1,57 @@
+#!/bin/sh
+
+# Test script to be run from the usocket source root
+#
+# Unfortunately, it currently works only with SBCL
+# in my setup...
+#
+# I need to figure out how to setup ASDF with the other lisps
+# I have installed: cmucl, ABCL, clisp, allegro and lispworks
+
+cd `dirname $0`/test
+rm tests.log
+
+if test -z "$1" ; then
+  lisps=*.conf
+else
+  lisps=$1
+fi
+
+for my_lisp_conf in $lisps ; do
+
+
+args=
+lisp_bin=
+lisp_name=
+lisp_exit="(quit result)"
+
+. $my_lisp_conf
+
+if test -z "$lisp_bin" ; then
+  echo "YOU NEED TO SET A LISP BINARY IN YOUR CONF FILE"
+  exit 1
+fi
+
+if test -z "$lisp_name" ; then
+  lisp_name="`basename \"$lisp_bin\"`"
+fi
+
+echo "
+#-sbcl (load \"asdf.lisp\")
+
+(asdf:operate #-sbcl 'asdf:load-source-op
+              #+sbcl 'asdf:load-op :usocket-test)
+
+(let ((result (if (usocket-test:do-tests) 1 0)))
+  $lisp_exit)
+" | $lisp_bin $args
+
+if test $? -eq 1 ; then
+  echo "PASS: $lisp_name" >> tests.log
+else
+  echo "FAIL: $lisp_name" >> tests.log
+fi
+
+echo "Above the test results gathered for $lisp_name."
+
+done

Added: usocket/branches/hans/test/abcl.conf.in
==============================================================================
--- (empty file)
+++ usocket/branches/hans/test/abcl.conf.in	Sat Jul 19 08:00:01 2008
@@ -0,0 +1,10 @@
+# lisp binary test setup file
+
+args=
+
+# lisp_bin is required!
+lisp_bin=~/src/abcl-0.0.9/abcl
+lisp_name=ArmedBear
+
+# lisp_exit is required!
+lisp_exit="(quit :status result)"

Added: usocket/branches/hans/test/allegro.conf.in
==============================================================================
--- (empty file)
+++ usocket/branches/hans/test/allegro.conf.in	Sat Jul 19 08:00:01 2008
@@ -0,0 +1,10 @@
+# lisp binary test setup file
+
+args="-batch"
+
+# lisp_bin is required!
+lisp_bin="~/src/acl/acl70_trial/alisp"
+lisp_name=Allegro
+
+# lisp_exit is required!
+lisp_exit="(exit result :no-unwind t)"

Added: usocket/branches/hans/test/clisp.conf.in
==============================================================================
--- (empty file)
+++ usocket/branches/hans/test/clisp.conf.in	Sat Jul 19 08:00:01 2008
@@ -0,0 +1,10 @@
+# lisp binary test setup file
+
+args=
+
+# lisp_bin is required!
+lisp_bin=clisp
+lisp_name=clisp
+
+# lisp_exit is required!
+lisp_exit="(quit result)"

Added: usocket/branches/hans/test/cmucl.conf.in
==============================================================================
--- (empty file)
+++ usocket/branches/hans/test/cmucl.conf.in	Sat Jul 19 08:00:01 2008
@@ -0,0 +1,10 @@
+# lisp binary test setup file
+
+args=
+
+# lisp_bin is required!
+lisp_bin="~/src/bin/lisp"
+lisp_name=CMUCL
+
+# lisp_exit is required!
+lisp_exit="(unix:unix-exit result)"

Added: usocket/branches/hans/test/package.lisp
==============================================================================
--- (empty file)
+++ usocket/branches/hans/test/package.lisp	Sat Jul 19 08:00:01 2008
@@ -0,0 +1,13 @@
+;;;; $Id: package.lisp 57 2006-02-07 19:39:46Z ehuelsmann $
+;;;; $URL: svn://common-lisp.net/project/usocket/svn/usocket/branches/hans/test/package.lisp $
+
+;;;; See the LICENSE file for licensing information.
+
+(in-package :cl-user)
+
+(eval-when (:execute :load-toplevel :compile-toplevel)
+  (defpackage :usocket-test
+      (:use :cl :regression-test)
+    (:nicknames :usoct)
+    (:export :do-tests :run-usocket-tests)))
+

Added: usocket/branches/hans/test/sbcl.conf.in
==============================================================================
--- (empty file)
+++ usocket/branches/hans/test/sbcl.conf.in	Sat Jul 19 08:00:01 2008
@@ -0,0 +1,10 @@
+# lisp binary test setup file
+
+args=
+
+# lisp_bin is required!
+lisp_bin=sbcl
+lisp_name=SBCL
+
+# lisp_exit is required!
+lisp_exit="(quit status :recklessly-p t)"

Added: usocket/branches/hans/test/test-usocket.lisp
==============================================================================
--- (empty file)
+++ usocket/branches/hans/test/test-usocket.lisp	Sat Jul 19 08:00:01 2008
@@ -0,0 +1,161 @@
+;;;; $Id: test-usocket.lisp 228 2007-04-08 21:56:25Z ehuelsmann $
+;;;; $URL: svn://common-lisp.net/project/usocket/svn/usocket/branches/hans/test/test-usocket.lisp $
+
+;;;; See LICENSE for licensing information.
+
+(in-package :usocket-test)
+
+;; The parameters below may need adjustments to match the system
+;; the tests are run on.
+(defparameter +non-existing-host+ "192.168.1.1")
+(defparameter +unused-local-port+ 15213)
+(defparameter *soc1* (usocket::make-stream-socket :socket :my-socket
+                                                  :stream :my-stream))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defparameter +common-lisp-net+ #(80 68 86 115))) ;; common-lisp.net IP
+
+(defmacro with-caught-conditions ((expect throw) &body body)
+  `(catch 'caught-error
+     (handler-case
+      (progn , at body)
+      (usocket:unknown-error (c) (if (typep c ,expect)
+                                     (throw 'caught-error ,throw)
+                                   (progn
+                                     (describe c)
+                                     (describe
+                                      (usocket::usocket-real-error c))
+                                     c)))
+      (error (c) (if (typep c ,expect)
+                     (throw 'caught-error ,throw)
+                   (progn
+                     (describe c)
+                     c)))
+      (usocket:unknown-condition (c) (if (typep c ,expect)
+                                         (throw 'caught-error ,throw)
+                                       (progn
+                                         (describe c)
+                                         (describe
+                                          (usocket::usocket-real-condition c))
+                                         c)))
+      (condition (c) (if (typep c ,expect)
+                         (throw 'caught-error ,throw)
+                       (progn
+                         (describe c)
+                         c))))))
+
+(deftest make-socket.1 (usocket:socket *soc1*) :my-socket)
+(deftest make-socket.2 (usocket:socket-stream *soc1*) :my-stream)
+
+(deftest socket-no-connect.1
+  (with-caught-conditions ('usocket:socket-error nil)
+      (usocket:socket-connect "127.0.0.0" +unused-local-port+)
+      t)
+  nil)
+(deftest socket-no-connect.2
+  (with-caught-conditions ('usocket:socket-error nil)
+    (usocket:socket-connect #(127 0 0 0) +unused-local-port+)
+    t)
+  nil)
+(deftest socket-no-connect.3
+  (with-caught-conditions ('usocket:socket-error nil)
+    (usocket:socket-connect 2130706432 +unused-local-port+) ;; == #(127 0 0 0)
+    t)
+  nil)
+
+(deftest socket-failure.1
+  (with-caught-conditions (#-(or cmu lispworks armedbear openmcl)
+                             'usocket:network-unreachable-error
+                           #+(or cmu lispworks armedbear)
+                             'usocket:unknown-error
+                           #+openmcl
+                             'usocket:timeout-error
+                           nil)
+    (usocket:socket-connect 2130706432 +unused-local-port+) ;; == #(127 0 0 0)
+    :unreach)
+  nil)
+(deftest socket-failure.2
+  (with-caught-conditions (#+(or lispworks armedbear)
+                             'usocket:unknown-error
+                           #+cmu
+                             'usocket:network-unreachable-error
+                           #+openmcl
+                             'usocket:timeout-error
+                           #-(or lispworks armedbear cmu openmcl)
+                             'usocket:host-unreachable-error
+                           nil)
+      (usocket:socket-connect +non-existing-host+ 80) ;; 80 = just a port
+      :unreach)
+  nil)
+
+
+;; let's hope c-l.net doesn't move soon, or that people start to
+;; test usocket like crazy..
+(deftest socket-connect.1
+  (with-caught-conditions (nil nil)
+    (let ((sock (usocket:socket-connect "common-lisp.net" 80)))
+      (unwind-protect
+          (typep sock 'usocket:usocket)
+        (usocket:socket-close sock))))
+  t)
+(deftest socket-connect.2
+  (with-caught-conditions (nil nil)
+    (let ((sock (usocket:socket-connect +common-lisp-net+ 80)))
+      (unwind-protect
+          (typep sock 'usocket:usocket)
+        (usocket:socket-close sock))))
+  t)
+(deftest socket-connect.3
+  (with-caught-conditions (nil nil)
+    (let ((sock (usocket:socket-connect (usocket::host-byte-order +common-lisp-net+) 80)))
+      (unwind-protect
+          (typep sock 'usocket:usocket)
+        (usocket:socket-close sock))))
+  t)
+
+;; let's hope c-l.net doesn't change its software any time soon
+(deftest socket-stream.1
+  (with-caught-conditions (nil nil)
+    (let ((sock (usocket:socket-connect "common-lisp.net" 80)))
+      (unwind-protect
+          (progn
+            (format (usocket:socket-stream sock)
+                    "GET / HTTP/1.0~A~A~A~A"
+                    #\Return #\Newline #\Return #\Newline)
+            (force-output (usocket:socket-stream sock))
+            (read-line (usocket:socket-stream sock)))
+        (usocket:socket-close sock))))
+  #+clisp "HTTP/1.1 200 OK"
+  #-clisp #.(format nil "HTTP/1.1 200 OK~A" #\Return) nil)
+
+(deftest socket-name.1
+  (with-caught-conditions (nil nil)
+    (let ((sock (usocket:socket-connect +common-lisp-net+ 80)))
+      (unwind-protect
+          (usocket::get-peer-address sock)
+        (usocket:socket-close sock))))
+  #.+common-lisp-net+)
+(deftest socket-name.2
+  (with-caught-conditions (nil nil)
+    (let ((sock (usocket:socket-connect +common-lisp-net+ 80)))
+      (unwind-protect
+          (usocket::get-peer-port sock)
+        (usocket:socket-close sock))))
+  80)
+(deftest socket-name.3
+  (with-caught-conditions (nil nil)
+    (let ((sock (usocket:socket-connect +common-lisp-net+ 80)))
+      (unwind-protect
+          (usocket::get-peer-name sock)
+        (usocket:socket-close sock))))
+  #.+common-lisp-net+ 80)
+(deftest socket-name.4
+  (with-caught-conditions (nil nil)
+    (let ((sock (usocket:socket-connect +common-lisp-net+ 80)))
+      (unwind-protect
+          (usocket::get-local-address sock)
+        (usocket:socket-close sock))))
+  #(192 168 1 65))
+
+
+(defun run-usocket-tests ()
+  (do-tests))

Added: usocket/branches/hans/test/usocket-test.asd
==============================================================================
--- (empty file)
+++ usocket/branches/hans/test/usocket-test.asd	Sat Jul 19 08:00:01 2008
@@ -0,0 +1,22 @@
+;;;; $Id: usocket-test.asd 46 2006-02-06 20:50:07Z ehuelsmann $
+;;;; $URL: svn://common-lisp.net/project/usocket/svn/usocket/branches/hans/test/usocket-test.asd $
+
+;;;; See the LICENSE file for licensing information.
+
+(in-package #:cl-user)
+
+(defpackage #:usocket-test-system
+    (:use #:cl #:asdf))
+
+(in-package #:usocket-test-system)
+
+(defsystem usocket-test
+    :name "usocket-test"
+    :author "Erik Enge"
+    :version "0.1.0"
+    :licence "MIT"
+    :description "Tests for usocket"
+    :depends-on (:usocket :rt)
+    :components ((:file "package")
+                 (:file "test-usocket"
+                        :depends-on ("package"))))

Added: usocket/branches/hans/test/your-lisp.conf.in
==============================================================================
--- (empty file)
+++ usocket/branches/hans/test/your-lisp.conf.in	Sat Jul 19 08:00:01 2008
@@ -0,0 +1,10 @@
+# lisp binary test setup file
+
+args=
+
+# lisp_bin is required!
+lisp_bin=<path-to-your-lisp-binary-here>
+lisp_name=
+
+# lisp_exit is required!
+lisp_exit=

Added: usocket/branches/hans/usocket.asd
==============================================================================
--- (empty file)
+++ usocket/branches/hans/usocket.asd	Sat Jul 19 08:00:01 2008
@@ -0,0 +1,43 @@
+
+;;;; $Id: usocket.asd 320 2008-02-21 20:29:19Z ehuelsmann $
+;;;; $URL: svn://common-lisp.net/project/usocket/svn/usocket/branches/hans/usocket.asd $
+
+;;;; See the LICENSE file for licensing information.
+
+(in-package #:cl-user)
+
+(defpackage #:usocket-system
+    (:use #:cl #:asdf))
+
+(in-package #:usocket-system)
+
+(defsystem usocket
+    :name "usocket"
+    :author "Erik Enge & Erik Huelsmann"
+    :version "0.5.0-dev"
+    :licence "MIT"
+    :description "Universal socket library for Common Lisp"
+    :depends-on (:split-sequence
+                 #+sbcl :sb-bsd-sockets)
+    :components ((:file "package")
+                 (:file "usocket"
+                        :depends-on ("package"))
+                 (:file "condition"
+                        :depends-on ("usocket"))
+                 #+clisp (:file "clisp" :pathname "backend/clisp"
+                                :depends-on ("condition"))
+                 #+cmu (:file "cmucl" :pathname "backend/cmucl"
+                              :depends-on ("condition"))
+                 #+scl (:file "scl" :pathname "backend/scl"
+                              :depends-on ("condition"))
+                 #+(or sbcl ecl) (:file "sbcl" :pathname "backend/sbcl"
+                                        :depends-on ("condition"))
+                 #+lispworks (:file "lispworks" :pathname "backend/lispworks"
+                                    :depends-on ("condition"))
+                 #+openmcl (:file "openmcl" :pathname "backend/openmcl"
+                                  :depends-on ("condition"))
+                 #+allegro (:file "allegro" :pathname "backend/allegro"
+                                  :depends-on ("condition"))
+                 #+armedbear (:file "armedbear" :pathname "backend/armedbear"
+                                                :depends-on ("condition"))
+                 ))

Added: usocket/branches/hans/usocket.lisp
==============================================================================
--- (empty file)
+++ usocket/branches/hans/usocket.lisp	Sat Jul 19 08:00:01 2008
@@ -0,0 +1,456 @@
+;;;; $Id: usocket.lisp 335 2008-04-23 21:29:50Z hhubner $
+;;;; $URL: svn://common-lisp.net/project/usocket/svn/usocket/branches/hans/usocket.lisp $
+
+;;;; See LICENSE for licensing information.
+
+(in-package :usocket)
+
+(defparameter *wildcard-host* #(0 0 0 0)
+  "Hostname to pass when all interfaces in the current system are to be bound.")
+
+(defparameter *auto-port* 0
+  "Port number to pass when an auto-assigned port number is wanted.")
+
+(defclass usocket ()
+  ((socket
+    :initarg :socket
+    :accessor socket
+    :documentation "Implementation specific socket object instance."))
+  (:documentation
+"The main socket class.
+
+Sockets should be closed using the `socket-close' method."))
+
+(defclass stream-usocket (usocket)
+   ((stream
+     :initarg :stream
+     :accessor socket-stream
+     :documentation "Stream instance associated with the socket."
+;;
+;;Iff an external-format was passed to `socket-connect' or `socket-listen'
+;;the stream is a flexi-stream. Otherwise the stream is implementation
+;;specific."
+))
+   (:documentation
+"Stream socket class.
+
+Contrary to other sockets, these sockets may be closed either
+with the `socket-close' method or by closing the associated stream
+(which can be retrieved with the `socket-stream' accessor)."))
+
+(defclass stream-server-usocket (usocket)
+  ((element-type
+    :initarg :element-type
+    :initform #-lispworks 'character
+              #+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.
+"
+   ))
+  (:documentation "Socket which listens for stream connections to
+be initiated from remote sockets."))
+
+(defun usocket-p (socket)
+  (typep socket 'usocket))
+
+(defun stream-usocket-p (socket)
+  (typep socket 'stream-usocket))
+
+(defun stream-server-usocket-p (socket)
+  (typep socket 'stream-server-usocket))
+
+(defun datagram-usocket-p (socket)
+  (typep socket 'datagram-usocket))
+
+(defclass datagram-usocket (usocket)
+  ((connected-p :initarg :connected-p :accessor connected-p))
+  (:documentation ""))
+
+(defun make-socket (&key socket)
+  "Create a usocket socket type from implementation specific socket."
+  (unless socket
+    (error 'invalid-socket))
+  (make-stream-socket :socket socket))
+
+(defun make-stream-socket (&key socket stream)
+  "Create a usocket socket type from implementation specific socket
+and stream objects.
+
+Sockets returned should be closed using the `socket-close' method or
+by closing the stream associated with the socket.
+"
+  (unless socket
+    (error 'invalid-socket-error))
+  (unless stream
+    (error 'invalid-socket-stream-error))
+  (make-instance 'stream-usocket
+                 :socket socket
+                 :stream stream))
+
+(defun make-stream-server-socket (socket &key (element-type
+                                               #-lispworks 'character
+                                               #+lispworks 'base-char))
+  "Create a usocket-server socket type from an
+implementation-specific socket object.
+
+The returned value is a subtype of `stream-server-usocket'.
+"
+  (unless socket
+    (error 'invalid-socket-error))
+  (make-instance 'stream-server-usocket
+                 :socket socket
+                 :element-type element-type))
+
+(defun make-datagram-socket (socket &key connected-p)
+  (unless socket
+    (error 'invalid-socket-error))
+  (make-instance 'datagram-usocket
+                 :socket socket
+                 :connected-p connected-p))
+
+(defgeneric socket-accept (socket &key element-type)
+  (:documentation
+      "Accepts a connection from `socket', returning a `stream-socket'.
+
+The stream associated with the socket returned has `element-type' when
+explicitly specified, or the element-type passed to `socket-listen' otherwise."))
+
+(defgeneric socket-close (usocket)
+  (:documentation "Close a previously opened `usocket'."))
+
+(defgeneric get-local-address (socket)
+  (:documentation "Returns the IP address of the socket."))
+
+(defgeneric get-peer-address (socket)
+  (:documentation
+   "Returns the IP address of the peer the socket is connected to."))
+
+(defgeneric get-local-port (socket)
+  (:documentation "Returns the IP port of the socket.
+
+This function applies to both `stream-usocket' and `server-stream-usocket'
+type objects."))
+
+(defgeneric get-peer-port (socket)
+  (:documentation "Returns the IP port of the peer the socket to."))
+
+(defgeneric get-local-name (socket)
+  (:documentation "Returns the IP address and port of the socket as values.
+
+This function applies to both `stream-usocket' and `server-stream-usocket'
+type objects."))
+
+(defgeneric get-peer-name (socket)
+  (:documentation
+   "Returns the IP address and port of the peer
+the socket is connected to as values."))
+
+(defgeneric set-socket-timeouts (socket read-timeout write-timeout)
+  (:documentation "Set the SO_RCVTIMEO and SO_SNDTIMEO socket options
+for the SOCKET.  Both READ-TIMEOUT and WRITE-TIMEOUT are speficied in
+\(fractional) seconds.")
+  (:method ((usocket usocket) read-timeout write-timeout)
+    (set-socket-timeouts (socket usocket) read-timeout write-timeout)))
+
+(defmacro with-connected-socket ((var socket) &body body)
+  "Bind `socket' to `var', ensuring socket destruction on exit.
+
+`body' is only evaluated when `var' is bound to a non-null value.
+
+The `body' is an implied progn form."
+  `(let ((,var ,socket))
+     (unwind-protect
+         (when ,var
+           (with-mapped-conditions (,var)
+             , at body))
+       (when ,var
+         (socket-close ,var)))))
+
+(defmacro with-client-socket ((socket-var stream-var &rest socket-connect-args)
+                              &body body)
+  "Bind the socket resulting from a call to `socket-connect' with
+the arguments `socket-connect-args' to `socket-var' and if `stream-var' is
+non-nil, bind the associated socket stream to it."
+  `(with-connected-socket (,socket-var (socket-connect , at socket-connect-args))
+       ,(if (null stream-var)
+           `(progn , at body)
+          `(let ((,stream-var (socket-stream ,socket-var)))
+             , at body))))
+
+(defmacro with-server-socket ((var server-socket) &body body)
+  "Bind `server-socket' to `var', ensuring socket destruction on exit.
+
+`body' is only evaluated when `var' is bound to a non-null value.
+
+The `body' is an implied progn form."
+  `(with-connected-socket (,var ,server-socket)
+      , at body))
+
+(defmacro with-socket-listener ((socket-var &rest socket-listen-args)
+                                &body body)
+  "Bind the socket resulting from a call to `socket-listen' with arguments
+`socket-listen-args' to `socket-var'."
+  `(with-server-socket (,socket-var (socket-listen , at socket-listen-args))
+      , at body))
+
+
+(defgeneric wait-for-input (socket-or-sockets
+                            &key timeout)
+  (:documentation
+"Waits for one or more streams to become ready for reading from
+the socket.  When `timeout' (a non-negative real number) is
+specified, wait `timeout' seconds, or wait indefinitely when
+it isn't specified.  A `timeout' value of 0 (zero) means polling.
+
+Returns two values: the first value is the list of streams which
+are readable (or in case of server streams acceptable).  NIL may
+be returned for this value either when waiting timed out or when
+it was interrupted (EINTR).  The second value is a real number
+indicating the time remaining within the timeout period or NIL if
+none."))
+
+
+(defmethod wait-for-input (socket-or-sockets &key timeout)
+  (let* ((start (get-internal-real-time))
+	 (sockets (if (listp socket-or-sockets)
+		      socket-or-sockets
+		      (list socket-or-sockets)))
+	 ;; retrieve a list of all sockets which are ready without waiting
+	 (ready-sockets
+	  (remove-if (complement #'(lambda (x)
+				     (and (stream-usocket-p x)
+					  (listen (socket-stream x)))))
+		     sockets))
+         ;; the internal routine is responsibe for
+         ;; making sure the wait doesn't block on socket-streams of
+         ;; which the socket isn't ready, but there's space left in the
+         ;; buffer
+         (result (wait-for-input-internal
+                  sockets
+                  :timeout (if (null ready-sockets) timeout 0))))
+    (values (union ready-sockets result)
+            (when timeout
+              (let ((elapsed (/ (- (get-internal-real-time) start)
+                                internal-time-units-per-second)))
+                (when (< elapsed timeout)
+                  (- timeout elapsed)))))))
+
+
+;;
+;; Data utility functions
+;;
+
+(defun integer-to-octet-buffer (integer buffer octets &key (start 0))
+  (do ((b start (1+ b))
+       (i (ash (1- octets) 3) ;; * 8
+          (- i 8)))
+      ((> 0 i) buffer)
+    (setf (aref buffer b)
+          (ldb (byte 8 i) integer))))
+
+(defun octet-buffer-to-integer (buffer octets &key (start 0))
+  (let ((integer 0))
+    (do ((b start (1+ b))
+         (i (ash (1- octets) 3) ;; * 8
+            (- i 8)))
+        ((> 0 i)
+         integer)
+      (setf (ldb (byte 8 i) integer)
+            (aref buffer b)))))
+
+
+(defmacro port-to-octet-buffer (port buffer &key (start 0))
+  `(integer-to-octet-buffer ,port ,buffer 2 ,start))
+
+(defmacro ip-to-octet-buffer (ip buffer &key (start 0))
+  `(integer-to-octet-buffer (host-byte-order ,ip) ,buffer 4 ,start))
+
+(defmacro port-from-octet-buffer (buffer &key (start 0))
+  `(octet-buffer-to-integer ,buffer 2 ,start))
+
+(defmacro ip-from-octet-buffer (buffer &key (start 0))
+  `(octet-buffer-to-integer ,buffer 4 ,start))
+
+;;
+;; IP(v4) utility functions
+;;
+
+(defun list-of-strings-to-integers (list)
+  "Take a list of strings and return a new list of integers (from
+parse-integer) on each of the string elements."
+  (let ((new-list nil))
+    (dolist (element (reverse list))
+      (push (parse-integer element) new-list))
+    new-list))
+
+(defun hbo-to-dotted-quad (integer)
+  "Host-byte-order integer to dotted-quad string conversion utility."
+  (let ((first (ldb (byte 8 24) integer))
+        (second (ldb (byte 8 16) integer))
+        (third (ldb (byte 8 8) integer))
+        (fourth (ldb (byte 8 0) integer)))
+    (format nil "~A.~A.~A.~A" first second third fourth)))
+
+(defun hbo-to-vector-quad (integer)
+  "Host-byte-order integer to dotted-quad string conversion utility."
+  (let ((first (ldb (byte 8 24) integer))
+        (second (ldb (byte 8 16) integer))
+        (third (ldb (byte 8 8) integer))
+        (fourth (ldb (byte 8 0) integer)))
+    (vector first second third fourth)))
+
+(defun vector-quad-to-dotted-quad (vector)
+  (format nil "~A.~A.~A.~A"
+          (aref vector 0)
+          (aref vector 1)
+          (aref vector 2)
+          (aref vector 3)))
+
+(defun dotted-quad-to-vector-quad (string)
+  (let ((list (list-of-strings-to-integers (split-sequence:split-sequence #\. string))))
+    (vector (first list) (second list) (third list) (fourth list))))
+
+(defgeneric host-byte-order (address))
+(defmethod host-byte-order ((string string))
+  "Convert a string, such as 192.168.1.1, to host-byte-order,
+such as 3232235777."
+  (let ((list (list-of-strings-to-integers (split-sequence:split-sequence #\. string))))
+    (+ (* (first list) 256 256 256) (* (second list) 256 256)
+       (* (third list) 256) (fourth list))))
+
+(defmethod host-byte-order ((vector vector))
+  "Convert a vector, such as #(192 168 1 1), to host-byte-order, such as
+3232235777."
+  (+ (* (aref vector 0) 256 256 256) (* (aref vector 1) 256 256)
+     (* (aref vector 2) 256) (aref vector 3)))
+
+(defmethod host-byte-order ((int integer))
+  int)
+
+(defun host-to-hostname (host)
+  "Translate a string or vector quad to a stringified hostname."
+  (etypecase host
+    (string host)
+    ((vector t 4) (vector-quad-to-dotted-quad host))
+    (integer (hbo-to-dotted-quad host))))
+
+(defun ip= (ip1 ip2)
+  (etypecase ip1
+    (string (string= ip1 (host-to-hostname ip2)))
+    ((vector t 4) (or (eq ip1 ip2)
+                      (and (= (aref ip1 0) (aref ip2 0))
+                           (= (aref ip1 1) (aref ip2 1))
+                           (= (aref ip1 2) (aref ip2 2))
+                           (= (aref ip1 3) (aref ip2 3)))))
+    (integer (= ip1 (host-byte-order ip2)))))
+
+(defun ip/= (ip1 ip2)
+  (not (ip= ip1 ip2)))
+
+;;
+;; DNS helper functions
+;;
+
+#-(or clisp armedbear)
+(progn
+  (defun get-host-by-name (name)
+    (let ((hosts (get-hosts-by-name name)))
+      (car hosts)))
+
+  (defun get-random-host-by-name (name)
+    (let ((hosts (get-hosts-by-name name)))
+      (when hosts
+        (elt hosts (random (length hosts))))))
+
+  (defun host-to-vector-quad (host)
+    "Translate a host specification (vector quad, dotted quad or domain name)
+to a vector quad."
+    (etypecase host
+      (string (let* ((ip (ignore-errors
+                           (dotted-quad-to-vector-quad host))))
+                (if (and ip (= 4 (length ip)))
+                    ;; valid IP dotted quad?
+                    ip
+                  (get-random-host-by-name host))))
+      ((vector t 4) host)
+      (integer (hbo-to-vector-quad host))))
+
+  (defun host-to-hbo (host)
+    (etypecase host
+      (string (let ((ip (ignore-errors
+                          (dotted-quad-to-vector-quad host))))
+                (if (and ip (= 4 (length ip)))
+                    (host-byte-order ip)
+            (host-to-hbo (get-host-by-name host)))))
+      ((vector t 4) (host-byte-order host))
+      (integer host))))
+
+;;
+;; Other utility functions
+;;
+
+(defun split-timeout (timeout &optional (fractional 1000000))
+  "Split real value timeout into seconds and microseconds.
+Optionally, a different fractional part can be specified."
+  (multiple-value-bind
+      (secs sec-frac)
+      (truncate timeout 1)
+    (values secs
+            (truncate (* fractional sec-frac) 1))))
+
+
+
+
+;;
+;; Setting of documentation for backend defined functions
+;;
+
+;; Documentation for the function
+;;
+;; (defun SOCKET-CONNECT (host port &key element-type) ..)
+;;
+
+(setf (documentation 'socket-connect 'function)
+      "Connect to `host' on `port'.  `host' is assumed to be a string or
+an IP address represented in vector notation, such as #(192 168 1 1).
+`port' is assumed to be an integer.
+
+`element-type' specifies the element type to use when constructing the
+stream associated with the socket.  The default is 'character.
+
+Returns a usocket object.")
+
+;; Documentation for the function
+;;
+;; (defun SOCKET-LISTEN (host port &key reuseaddress backlog element-type) ..)
+;;###FIXME: extend with default-element-type
+(setf (documentation 'socket-listen 'function)
+      "Bind to interface `host' on `port'. `host' should be the
+representation of an interface address.  The implementation is not
+required to do an address lookup, making no guarantees that hostnames
+will be correctly resolved.  If `*wildcard-host*' is passed for `host',
+the socket will be bound to all available interfaces for the IPv4
+protocol in the system.  `port' can be selected by the IP stack by
+passing `*auto-port*'.
+
+Returns an object of type `stream-server-usocket'.
+
+`reuse-address' and `backlog' are advisory parameters for setting socket
+options at creation time. `element-type' is the element type of the
+streams to be created by `socket-accept'.  `reuseaddress' is supported for
+backward compatibility (but deprecated); when both `reuseaddress' and
+`reuse-address' have been specified, the latter takes precedence.
+")


From ehuelsmann at common-lisp.net  Sat Jul 26 21:53:04 2008
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Sat, 26 Jul 2008 17:53:04 -0400 (EDT)
Subject: [usocket-cvs] r384 - in usocket/trunk: . backend
Message-ID: <20080726215304.DE3C25D183@common-lisp.net>

Author: ehuelsmann
Date: Sat Jul 26 17:53:00 2008
New Revision: 384

Modified:
   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
   usocket/trunk/backend/scl.lisp
   usocket/trunk/package.lisp
   usocket/trunk/usocket.lisp
Log:
Backport new-wfi branch.

Modified: usocket/trunk/backend/allegro.lisp
==============================================================================
--- usocket/trunk/backend/allegro.lisp	(original)
+++ usocket/trunk/backend/allegro.lisp	Sat Jul 26 17:53:00 2008
@@ -68,6 +68,8 @@
 ;; because socket-streams are also sockets.
 (defmethod socket-close ((usocket usocket))
   "Close socket."
+  (when (wait-list usocket)
+     (remove-waiter (wait-list usocket) usocket))
   (with-mapped-conditions (usocket)
     (close (socket usocket))))
 
@@ -132,18 +134,29 @@
     (list (hbo-to-vector-quad (socket:lookup-hostname
                                (host-to-hostname name))))))
 
-(defun wait-for-input-internal (sockets &key timeout)
+(defun %setup-wait-list (wait-list)
+  (declare (ignore wait-list)))
+
+(defun %add-waiter (wait-list waiter)
+  (push (socket waiter) (wait-list-%wait wait-list)))
+
+(defun %remove-waiter (wait-list waiter)
+  (setf (wait-list-%wait wait-list)
+        (remove (socket waiter) (wait-list-%wait wait-list))))
+
+(defun wait-for-input-internal (wait-list &key timeout)
   (with-mapped-conditions ()
     (let ((active-internal-sockets
            (if timeout
-               (mp:wait-for-input-available (mapcar #'socket sockets)
+               (mp:wait-for-input-available (wait-list-%wait wait-list)
                                             :timeout timeout)
-             (mp:wait-for-input-available (mapcar #'socket sockets)))))
+             (mp:wait-for-input-available (wait-list-%wait wait-list)))))
       ;; 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))))
+      ;; [Same code is also used in openmcl.lisp]
+      (dolist (x active-internal-sockets)
+        (setf (state (gethash x (wait-list-map wait-list)))
+              :READ))
+      wait-list)))

Modified: usocket/trunk/backend/armedbear.lisp
==============================================================================
--- usocket/trunk/backend/armedbear.lisp	(original)
+++ usocket/trunk/backend/armedbear.lisp	Sat Jul 26 17:53:00 2008
@@ -88,6 +88,7 @@
    (t
     (java:jclass-name (jop-class instance)))))
 
+(declaim (inline jop-deref))
 (defun jop-deref (instance)
   (if (java-object-proxy-p instance)
       (jop-value instance)
@@ -198,7 +199,6 @@
              (jchan (jdi:do-jstatic-call "java.nio.channels.SocketChannel"
                                          "open" sock-addr))
              (sock (jdi:do-jmethod-call jchan "socket")))
-        (describe sock)
          (setf usock
                (make-stream-socket
                 :socket jchan
@@ -247,6 +247,8 @@
 ;;    (print (jcall (jmethod "java.net.BindException" "getMessage") native-exception))))
 
 (defmethod socket-close ((usocket usocket))
+  (when (wait-list usocket)
+     (remove-waiter (wait-list usocket) usocket))
   (with-mapped-conditions (usocket)
     (jdi:do-jmethod (socket usocket) "close")))
 
@@ -254,6 +256,8 @@
 ;; socket streams. Closing the stream flushes
 ;; its buffers *and* closes the socket.
 (defmethod socket-close ((usocket stream-usocket))
+  (when (wait-list usocket)
+     (remove-waiter (wait-list usocket) usocket))
   (with-mapped-conditions (usocket)
     (close (socket-stream usocket))))
 
@@ -351,20 +355,20 @@
    ((datagram-usocket-p socket)
     "java.nio.channels.DatagramChannel")))
 
-(defun wait-for-input-internal (sockets &key timeout)
-  (let* ((ops (logior (op-read) (op-accept)))
+(defun wait-for-input-internal (wait-list &key timeout)
+  (let* ((sockets (wait-list-waiters wait-list))
+         (ops (logior (op-read) (op-accept)))
          (selector (jdi:do-jstatic "java.nio.channels.Selector" "open"))
          (channels (mapcar #'socket sockets)))
     (unwind-protect
         (with-mapped-conditions ()
-          (let ((jfalse (java:make-immediate-object nil :boolean))
-                (sel (jdi:jop-deref selector)))
+          (let ((sel (jdi:jop-deref selector)))
             (dolist (channel channels)
               (let ((chan (jdi:jop-deref channel)))
                 (java:jcall (java:jmethod "java.nio.channels.SelectableChannel"
                                           "configureBlocking"
                                           "boolean")
-                            chan jfalse)
+                            chan (java:make-immediate-object nil :boolean))
                 (java:jcall (java:jmethod "java.nio.channels.SelectableChannel"
                                           "register"
                                           "java.nio.channels.Selector" "int")
@@ -378,7 +382,7 @@
                 ;; we actually have work to do
                 (let* ((selkeys (jdi:do-jmethod selector "selectedKeys"))
                        (selkey-iterator (jdi:do-jmethod selkeys "iterator"))
-                       ready-sockets)
+                       (%wait (wait-list-%wait wait-list)))
                   (loop while (java:jcall
                                (java:jmethod "java.util.Iterator" "hasNext")
                                (jdi:jop-deref selkey-iterator))
@@ -387,33 +391,40 @@
                                         "java.nio.channels.SelectionKey"))
                                   (chan (jdi:jop-deref
                                          (jdi:do-jmethod key "channel"))))
-                             (push chan ready-sockets)))
-                  (remove-if #'(lambda (s)
-                                 (not (member (jdi:jop-deref (socket s))
-                                              ready-sockets
-                                              :test #'(lambda (x y)
-                                                        (java:jcall (java:jmethod "java.lang.Object"
-                                                                             "equals"
-                                                                             "java.lang.Object")
-                                                                    x y)))))
-                             sockets))))))
-      ;; cancel all Selector registrations
-      (let* ((keys (jdi:do-jmethod selector "keys"))
-             (iter (jdi:do-jmethod keys "iterator")))
-        (loop while (java:jcall (java:jmethod "java.util.Iterator" "hasNext")
-                                (jdi:jop-deref iter))
-              do (java:jcall
-                  (java:jmethod "java.nio.channels.SelectionKey" "cancel")
-                  (java:jcall (java:jmethod "java.util.Iterator" "next")
-                              (jdi:jop-deref iter)))))
-      ;; close the selector
+                             (setf (state (gethash chan %wait))
+                                   :READ))))))))
+      ;; close the selector: all keys will be deregistered
       (java:jcall (java:jmethod "java.nio.channels.Selector" "close")
                   (jdi:jop-deref selector))
       ;; make all sockets blocking again.
-      (let ((jtrue (java:make-immediate-object t :boolean)))
-        (dolist (chan channels)
-          (java:jcall (java:jmethod "java.nio.channels.SelectableChannel"
-                                          "configureBlocking"
-                                          "boolean")
-                      (jdi:jop-deref chan) jtrue))))))
+     (dolist (channel channels)
+       (java:jcall (java:jmethod "java.nio.channels.SelectableChannel"
+                                 "configureBlocking"
+                                 "boolean")
+                      (jdi:jop-deref channel)
+                      (java:make-immediate-object t :boolean))))))
+
+
+;;
+;;
+;;
+;; The WAIT-LIST part
+;;
+
+;;
+;; Note that even though Java has the concept of the Selector class, which
+;; remotely looks like a wait-list, it requires the sockets to be non-blocking.
+;; usocket however doesn't make any such guarantees and is therefore unable to
+;; use the concept outside of the waiting routine itself (blergh!).
+;;
+
+(defun %setup-wait-list (wl)
+  (setf (wait-list-%wait wl)
+        (make-hash-table :test #'equal :rehash-size 1.3d0)))
+
+(defun %add-waiter (wl w)
+  (setf (gethash (jdi:jop-deref (socket w)) (wait-list-%wait wl))
+        w))
 
+(defun %remove-waiter (wl w)
+  (remhash (socket w) (wait-list-%wait wl)))
\ No newline at end of file

Modified: usocket/trunk/backend/clisp.lisp
==============================================================================
--- usocket/trunk/backend/clisp.lisp	(original)
+++ usocket/trunk/backend/clisp.lisp	Sat Jul 26 17:53:00 2008
@@ -101,10 +101,14 @@
 ;; are the same object
 (defmethod socket-close ((usocket usocket))
   "Close socket."
+  (when (wait-list usocket)
+     (remove-waiter (wait-list usocket) usocket))
   (with-mapped-conditions (usocket)
     (close (socket usocket))))
 
 (defmethod socket-close ((usocket stream-server-usocket))
+  (when (wait-list usocket)
+     (remove-waiter (wait-list usocket) usocket))
   (socket:socket-server-close (socket usocket)))
 
 (defmethod get-local-name ((usocket usocket))
@@ -132,23 +136,34 @@
   (nth-value 1 (get-peer-name usocket)))
 
 
-(defmethod wait-for-input-internal (sockets &key timeout)
+(defun %setup-wait-list (wait-list)
+  (declare (ignore wait-list)))
+
+(defun %add-waiter (wait-list waiter)
+  (push (cons (socket waiter) NIL) (wait-list-%wait wait-list)))
+
+(defun %remove-waiter (wait-list waiter)
+  (setf (wait-list-%wait wait-list)
+        (remove (socket waiter) (wait-list-%wait wait-list) :key #'car)))
+
+(defmethod wait-for-input-internal (wait-list &key timeout)
   (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))
+      (dolist (x (wait-list-%wait wait-list))
+        (setf (cdr x) :INPUT))
+      (let* ((request-list (wait-list-%wait wait-list))
              (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))))))
+                            (socket:socket-status request-list)))
+             (sockets (wait-list-waiters wait-list)))
+        (do* ((x (pop sockets) (pop sockets))
+              (y (pop status-list) (pop status-list)))
+             ((null x))
+          (when (eq y :INPUT)
+            (setf (state x) :READ)))
+        wait-list))))
 
 
 ;;
@@ -221,6 +236,8 @@
       rv))
 
   (defmethod socket-close ((usocket datagram-usocket))
+    (when (wait-list usocket)
+       (remove-waiter (wait-list usocket) usocket))
     (rawsock:sock-close (socket usocket)))
 
   )

Modified: usocket/trunk/backend/cmucl.lisp
==============================================================================
--- usocket/trunk/backend/cmucl.lisp	(original)
+++ usocket/trunk/backend/cmucl.lisp	Sat Jul 26 17:53:00 2008
@@ -99,11 +99,15 @@
 ;; socket stream when closing a stream socket.
 (defmethod socket-close ((usocket stream-usocket))
   "Close socket."
+  (when (wait-list usocket)
+     (remove-waiter (wait-list usocket) usocket))
   (with-mapped-conditions (usocket)
     (close (socket-stream usocket))))
 
 (defmethod socket-close ((usocket usocket))
   "Close socket."
+  (when (wait-list usocket)
+     (remove-waiter (wait-list usocket) usocket))
   (with-mapped-conditions (usocket)
     (ext:close-socket (socket usocket))))
 
@@ -164,26 +168,38 @@
 (defun get-host-name ()
   (unix:unix-gethostname))
 
-(defun wait-for-input-internal (sockets &key timeout)
+(defun %setup-wait-list (wait-list)
+  (declare (ignore wait-list)))
+
+(defun %add-waiter (wait-list waiter)
+  (declare (ignore wait-list waiter))
+  (push (socket waiter) (wait-list-%wait wait-list)))
+
+(defun %remove-waiter (wait-list waiter)
+  (declare (ignore wait-list waiter))
+  (setf (wait-list-%wait wait-list)
+        (remove (socket waiter) (wait-list-%wait waiter))))
+
+(defun wait-for-input-internal (wait-list &key timeout)
   (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))
+       (dolist (socket (wait-list-%wait wait-list))
+         (unix:fd-set socket rfds))
        (multiple-value-bind
            (secs musecs)
            (split-timeout (or timeout 1))
          (multiple-value-bind
              (count err)
-             (unix:unix-fast-select (1+ (reduce #'max sockets
-                                                :key #'socket))
+             (unix:unix-fast-select (1+ (reduce #'max
+                                                (wait-list-%wait wait-list)))
                                     (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)
+               (dolist (x (wait-list-waiters wait-list))
+                 (when (unix:fd-isset (socket x) rfds)
+                   (setf (state x) :READ)))
              (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	Sat Jul 26 17:53:00 2008
@@ -119,9 +119,13 @@
 ;; are correctly flushed and the socket closed.
 (defmethod socket-close ((usocket stream-usocket))
   "Close socket."
+  (when (wait-list usocket)
+     (remove-waiter (wait-list usocket) usocket))
   (close (socket-stream usocket)))
 
 (defmethod socket-close ((usocket usocket))
+  (when (wait-list usocket)
+     (remove-waiter (wait-list usocket) usocket))
   (with-mapped-conditions (usocket)
      (comm::close-socket (socket usocket))))
 
@@ -171,21 +175,36 @@
 ;;;
 
 #-win32
-(defun wait-for-input-internal (sockets &key timeout)
-  (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?
-    (dolist (x sockets)
-       (mp:notice-fd (os-socket-handle x)))
-    (mp:process-wait-with-timeout "Waiting for a socket to become active"
-                                  (truncate timeout)
-                                  #'(lambda (socks)
-                                      (some #'usocket-listen socks))
-                                  sockets)
-    (dolist (x sockets)
-       (mp:unnotice-fd (os-socket-handle x)))
-    (remove nil (mapcar #'usocket-listen sockets))))
+(progn
+
+  (defun %setup-wait-list (wait-list)
+    (declare (ignore wait-list)))
+
+  (defun %add-waiter (wait-list waiter)
+    (declare (ignore wait-list waiter)))
+
+  (defun %remove-waiter (wait-list waiter)
+    (declare (ignore wait-list waiter)))
+
+  (defun wait-for-input-internal (wait-list &key timeout)
+    (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?
+      (dolist (x (wait-list-waiters wait-list))
+        (mp:notice-fd (os-socket-handle x)))
+      (mp:process-wait-with-timeout "Waiting for a socket to become active"
+                                    (truncate timeout)
+                                    #'(lambda (socks)
+                                        (let (rv)
+                                          (dolist (x socks rv)
+                                            (when (usocket-listen x)
+                                              (setf (state x) :READ
+                                                    rv t)))))
+                                    (wait-list-waiters wait-list))
+      (dolist (x (wait-list-waiters wait-list))
+        (mp:unnotice-fd (os-socket-handle x)))
+      wait-list)))
 
 
 ;;;
@@ -230,6 +249,23 @@
 
   (defconstant fionread 1074030207)
 
+
+  ;; Note:
+  ;;
+  ;;  If special finalization has to occur for a given
+  ;;  system resource (handle), an associated object should
+  ;;  be created.  A special cleanup action should be added
+  ;;  to the system and a special cleanup action should
+  ;;  be flagged on all objects created for resources like it
+  ;;
+  ;;  We have 2 functions to do so:
+  ;;   * hcl:add-special-free-action (function-symbol)
+  ;;   * hcl:flag-special-free-action (object)
+  ;;
+  ;;  Note that the special free action will be called on all
+  ;;  objects which have been flagged for special free, so be
+  ;;  sure to check for the right argument type!
+  
   (fli:define-foreign-type ws-socket () '(:unsigned :int))
   (fli:define-foreign-type win32-handle () '(:unsigned :int))
   (fli:define-c-struct wsa-network-events (network-events :long)
@@ -274,7 +310,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
@@ -294,14 +330,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))
@@ -310,43 +338,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/trunk/backend/openmcl.lisp
==============================================================================
--- usocket/trunk/backend/openmcl.lisp	(original)
+++ usocket/trunk/backend/openmcl.lisp	Sat Jul 26 17:53:00 2008
@@ -32,21 +32,23 @@
 (defun input-available-p (sockets &optional ticks-to-wait)
   (ccl::rletZ ((tv :timeval))
     (ccl::ticks-to-timeval ticks-to-wait tv)
+    ;;### The trickery below can be moved to the wait-list now...
     (ccl::%stack-block ((infds ccl::*fd-set-size*))
       (ccl::fd-zero infds)
       (let ((max-fd -1))
         (dolist (sock sockets)
-          (let ((fd (openmcl-socket:socket-os-fd sock)))
+          (let ((fd (openmcl-socket:socket-os-fd (socket sock))))
             (setf max-fd (max max-fd fd))
             (ccl::fd-set fd infds)))
         (let* ((res (#_select (1+ max-fd)
                               infds (ccl::%null-ptr) (ccl::%null-ptr)
                               (if ticks-to-wait tv (ccl::%null-ptr)))))
           (when (> res 0)
-            (remove-if #'(lambda (x)
-                           (not (ccl::fd-is-set (openmcl-socket:socket-os-fd x)
-                                                infds)))
-                       sockets)))))))
+            (dolist (x sockets)
+              (when (ccl::fd-is-set (openmcl-socket:socket-os-fd (socket x))
+                                    infds)
+                (setf (state x) :READ))))
+          sockets)))))
 
 (defun raise-error-from-id (condition-id socket real-condition)
   (let ((usock-err (cdr (assoc condition-id +openmcl-error-map+))))
@@ -109,6 +111,8 @@
 ;; and their associated objects are represented
 ;; by the same object.
 (defmethod socket-close ((usocket usocket))
+  (when (wait-list usocket)
+     (remove-waiter (wait-list usocket) usocket))
   (with-mapped-conditions (usocket)
     (close (socket usocket))))
 
@@ -141,19 +145,23 @@
      (list (hbo-to-vector-quad (openmcl-socket:lookup-hostname
                                 (host-to-hostname name))))))
 
-(defun wait-for-input-internal (sockets &key timeout)
+
+(defun %setup-wait-list (wait-list)
+  (declare (ignore wait-list)))
+
+(defun %add-waiter (wait-list waiter)
+  (declare (ignore wait-list waiter)))
+
+(defun %remove-waiter (wait-list waiter)
+  (declare (ignore wait-list waiter)))
+
+(defun wait-for-input-internal (wait-list &key timeout)
   (with-mapped-conditions ()
-    (let* ((ticks-timeout (truncate (* (or timeout 1) ccl::*ticks-per-second*)))
+    (let* ((ticks-timeout (truncate (* (or timeout 1)
+                                       ccl::*ticks-per-second*)))
            (active-internal-sockets
-            (input-available-p (mapcar #'socket sockets)
+            (input-available-p (wait-list-waiters wait-list)
                                (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))))
+      wait-list)))
 
 

Modified: usocket/trunk/backend/sbcl.lisp
==============================================================================
--- usocket/trunk/backend/sbcl.lisp	(original)
+++ usocket/trunk/backend/sbcl.lisp	Sat Jul 26 17:53:00 2008
@@ -64,6 +64,33 @@
     (ffi:c-inline () () :fixnum
      "FD_SETSIZE" :one-liner t))
 
+  (defun fdset-alloc ()
+    (ffi:c-inline () () :pointer-void
+     "cl_alloc_atomic(sizeof(fd_set))" :one-liner t))
+
+  (defun fdset-zero (fdset)
+    (ffi:c-inline (fdset) (:pointer-void) :void
+     "FD_ZERO((fd_set*)#0)" :one-liner t))
+
+  (defun fdset-set (fdset fd)
+    (ffi:c-inline (fdset fd) (:pointer-void :fixnum) :void
+     "FD_SET(#1,(fd_set*)#0)" :one-liner t))
+
+  (defun fdset-clr (fdset fd)
+    (ffi:c-inline (fdset fd) (:pointer-void :fixnum) :void
+     "FD_CLR(#1,(fd_set*)#0)" :one-liner t))
+
+  (defun fdset-fd-isset (fdset fd)
+    (ffi:c-inline (fdset fd) (:pointer-void :fixnum) :bool
+     "FD_ISSET(#1,(fd_set*)#0)" :one-liner t))
+
+  (declaim (inline fd-setsize
+                   fdset-alloc
+                   fdset-zero
+                   fdset-set
+                   fdset-clr
+                   fdset-fd-isset))
+
   (defun get-host-name ()
     (ffi:c-inline
      () () :object
@@ -75,61 +102,47 @@
           @(return) = Cnil;
       }" :one-liner nil :side-effects nil))
 
-  (defun read-select (read-fds to-secs &optional (to-musecs 0))
-    (ffi:c-inline (read-fds to-secs to-musecs) (t t :unsigned-int) t
-      "{
-          fd_set rfds;
-          cl_object cur_fd = #0;
+  (defun read-select (wl to-secs &optional (to-musecs 0))
+    (let* ((sockets (wait-list-waiters wl))
+           (rfds (wait-list-%wait wl))
+           (max-fd (reduce #'(lambda (x y)
+                               (let ((sy (sb-bsd-sockets:socket-file-descriptor
+                                          (socket y))))
+                                 (if (< x sy) sy x)))
+                           (cdr sockets)
+                           :initial-value (sb-bsd-sockets:socket-file-descriptor
+                                           (socket (car sockets))))))
+      (fdset-zero rfds)
+      (dolist (sock sockets)
+        (fdset-set rfds (sb-bsd-sockets:socket-file-descriptor
+                         (socket sock))))
+      (let ((count
+             (ffi:c-inline (to-secs to-musecs rfds max-fd)
+                           (t :unsigned-int :pointer-void :int)
+                           :int
+      "
           int count;
-          int max_fd = -1;
           struct timeval tv;
 
-          FD_ZERO(&rfds);
-          while (CONSP(cur_fd)) {
-            int fd = fixint(cur_fd->cons.car);
-            max_fd = (max_fd > fd) ? max_fd : fd;
-            FD_SET(fd, &rfds);
-            cur_fd = cur_fd->cons.cdr;
-          }
-
-          if (#1 != Cnil) {
-            tv.tv_sec = fixnnint(#1);
-            tv.tv_usec = #2;
+          if (#0 != Cnil) {
+            tv.tv_sec = fixnnint(#0);
+            tv.tv_usec = #1;
           }
-          count = select(max_fd + 1, &rfds, NULL, NULL,
-                         (#1 != Cnil) ? &tv : NULL);
+        @(return) = select(#3 + 1, (fd_set*)#2, NULL, NULL,
+                           (#0 != Cnil) ? &tv : NULL);
+")))
+        (cond
+          ((= 0 count)
+           (values nil nil))
+          ((< count 0)
+           ;; check for EINTR and EAGAIN; these should not err
+           (values nil (ffi:c-inline () () :int "errno" :one-liner t)))
+          (t
+           (dolist (sock sockets)
+             (when (fdset-fd-isset rfds (sb-bsd-sockets:socket-file-descriptor
+                                         (socket sock)))
+               (setf (state sock) :READ))))))))
 
-          if (count == 0)
-            @(return 0) = Cnil;
-            @(return 1) = Cnil;
-          else if (count < 0)
-            /*###FIXME: We should be raising an error here...
-
-              except, ofcourse in case of EINTR or EAGAIN */
-
-            @(return 0) = Cnil;
-            @(return 1) = MAKE_INTEGER(errno);
-          else
-            {
-              cl_object rv = Cnil;
-              cur_fd = #0;
-
-              /* when we're going to use the same code on Windows,
-                 as well as unix, we can't be sure it'll fit into
-                 a fixnum: these aren't unix filehandle bitmaps sets on
-                 Windows... */
-
-              while (CONSP(cur_fd)) {
-                int fd = fixint(cur_fd->cons.car);
-                if (FD_ISSET(fd, &rfds))
-                  rv = CONS(MAKE_INTEGER(fd), rv);
-
-                cur_fd = cur_fd->cons.cdr;
-              }
-              @(return 0) = rv;
-              @(return 1) = Cnil;
-            }
-}"))
 
 )
 
@@ -152,6 +165,7 @@
      . operation-not-permitted-error)
     (sb-bsd-sockets:protocol-not-supported-error
      . protocol-not-supported-error)
+    #-ecl
     (sb-bsd-sockets:unknown-protocol
      . protocol-not-supported-error)
     (sb-bsd-sockets:socket-type-not-supported-error
@@ -161,6 +175,7 @@
     (sb-bsd-sockets:socket-error . ,#'map-socket-error)
 
     ;; Nameservice errors: mapped to unknown-error
+    #-ecl #-ecl #-ecl
     (sb-bsd-sockets:no-recovery-error . ns-no-recovery-error)
     (sb-bsd-sockets:try-again-error . ns-try-again-condition)
     (sb-bsd-sockets:host-not-found-error . ns-host-not-found-error)))
@@ -232,10 +247,14 @@
 ;; different objects. Be sure to close the stream (which
 ;; closes the socket too) when closing a stream-socket.
 (defmethod socket-close ((usocket usocket))
+  (when (wait-list usocket)
+     (remove-waiter (wait-list usocket) usocket))
   (with-mapped-conditions (usocket)
     (sb-bsd-sockets:socket-close (socket usocket))))
 
 (defmethod socket-close ((usocket stream-usocket))
+  (when (wait-list usocket)
+     (remove-waiter (wait-list usocket) usocket))
   (with-mapped-conditions (usocket)
     (close (socket-stream usocket))))
 
@@ -271,13 +290,25 @@
 #+sbcl
 (progn
   #-win32
+(defun %setup-wait-list (wait-list)
+  (declare (ignore wait-list)))
+
+(defun %add-waiter (wait-list waiter)
+  (push (socket waiter) (wait-list-%wait wait-list)))
+
+(defun %remove-waiter (wait-list waiter)
+  (setf (wait-list-%wait wait-list)
+        (remove (socket waiter) (wait-list-%wait wait-list))))
+
+
+
   (defun wait-for-input-internal (sockets &key timeout)
     (with-mapped-conditions ()
       (sb-alien:with-alien ((rfds (sb-alien:struct sb-unix:fd-set)))
          (sb-unix:fd-zero rfds)
-         (dolist (socket sockets)
+         (dolist (socket (wait-list-%wait sockets))
            (sb-unix:fd-set
-            (sb-bsd-sockets:socket-file-descriptor (socket socket))
+            (sb-bsd-sockets:socket-file-descriptor socket)
             rfds))
          (multiple-value-bind
              (secs musecs)
@@ -285,7 +316,7 @@
            (multiple-value-bind
                (count err)
                (sb-unix:unix-fast-select
-                (1+ (reduce #'max (mapcar #'socket sockets)
+                (1+ (reduce #'max (mapcar #'socket (wait-list-waiters sockets))
                             :key #'sb-bsd-sockets:socket-file-descriptor))
                 (sb-alien:addr rfds) nil nil
                 (when timeout secs) musecs)
@@ -294,12 +325,11 @@
 		   (error (map-errno-error err)))
 		 (when (< 0 count)
 		   ;; process the result...
-		   (remove-if
-		    #'(lambda (x)
-			(not (sb-unix:fd-isset
-			      (sb-bsd-sockets:socket-file-descriptor (socket x))
-			      rfds)))
-		    sockets))))))))
+                   (dolist (x (wait-list-waiters sockets))
+                     (when (not (sb-unix:fd-isset
+                                 (sb-bsd-sockets:socket-file-descriptor (socket x))
+                                 rfds))
+                       (setf (state x) :READ))))))))))
 
   #+win32
   (warn "wait-for-input not (yet!) supported...")
@@ -307,23 +337,25 @@
 
 #+ecl
 (progn
-  (defun wait-for-input-internal (sockets &key timeout)
+  (defun wait-for-input-internal (wl &key timeout)
     (with-mapped-conditions ()
       (multiple-value-bind
-          (secs usecs)
+            (secs usecs)
           (split-timeout (or timeout 1))
-        (let* ((sock-fds (mapcar #'sb-bsd-sockets:socket-file-descriptor
-                                 (mapcar #'socket sockets))))
-	  (multiple-value-bind
-		(result-fds err)
-	      (read-select sock-fds (when timeout secs) usecs)
-	    (if (null err)
-		(remove-if #'(lambda (s)
-			       (not
-				(member
-				 (sb-bsd-sockets:socket-file-descriptor
-				  (socket s))
-				 result-fds)))
-			   sockets)
-		(error (map-errno-error err))))))))
+        (multiple-value-bind
+              (result-fds err)
+            (read-select wl (when timeout secs) usecs)
+          (unless (null err)
+            (error (map-errno-error err)))))))
+
+  (defun %setup-wait-list (wl)
+    (setf (wait-list-%wait wl)
+          (fdset-alloc)))
+
+  (defun %add-waiter (wl w)
+    (declare (ignore wl w)))
+
+  (defun %remove-waiter (wl w)
+    (declare (ignore wl w)))
+
   )

Modified: usocket/trunk/backend/scl.lisp
==============================================================================
--- usocket/trunk/backend/scl.lisp	(original)
+++ usocket/trunk/backend/scl.lisp	Sat Jul 26 17:53:00 2008
@@ -71,11 +71,15 @@
 ;; are flushed and the socket is closed correctly afterwards.
 (defmethod socket-close ((usocket usocket))
   "Close socket."
+  (when (wait-list usocket)
+     (remove-waiter (wait-list usocket) usocket))
   (with-mapped-conditions (usocket)
     (ext:close-socket (socket usocket))))
 
 (defmethod socket-close ((usocket stream-usocket))
   "Close socket."
+  (when (wait-list usocket)
+     (remove-waiter (wait-list usocket) usocket))
   (with-mapped-conditions (usocket)
     (close (socket-stream usocket))))
 

Modified: usocket/trunk/package.lisp
==============================================================================
--- usocket/trunk/package.lisp	(original)
+++ usocket/trunk/package.lisp	Sat Jul 26 17:53:00 2008
@@ -15,7 +15,6 @@
              #:socket-listen
              #:socket-accept
              #:socket-close
-             #:wait-for-input
              #:get-local-address
              #:get-peer-address
              #:get-local-port
@@ -23,6 +22,12 @@
              #:get-local-name
              #:get-peer-name
 
+             #:wait-for-input ; waiting for input-ready state (select() like)
+             #:make-wait-list
+             #:add-waiter
+             #:remove-waiter
+             #:remove-all-waiters
+
              #:with-connected-socket ; convenience macros
              #:with-server-socket
              #:with-client-socket

Modified: usocket/trunk/usocket.lisp
==============================================================================
--- usocket/trunk/usocket.lisp	(original)
+++ usocket/trunk/usocket.lisp	Sat Jul 26 17:53:00 2008
@@ -15,7 +15,40 @@
   ((socket
     :initarg :socket
     :accessor socket
-    :documentation "Implementation specific socket object instance."))
+    :documentation "Implementation specific socket object instance.'")
+   (wait-list
+    :initform nil
+    :accessor wait-list
+    :documentation "WAIT-LIST the object is associated with.")
+   (state
+    :initform nil
+    :accessor state
+    :documentation "Per-socket return value for the `wait-for-input' function.
+
+The value stored in this slot can be any of
+ NIL          - not ready
+ :READ        - ready to read
+ :READ-WRITE  - ready to read and write
+ :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.
 
@@ -33,7 +66,7 @@
 ))
    (:documentation
 "Stream socket class.
-
+'
 Contrary to other sockets, these sockets may be closed either
 with the `socket-close' method or by closing the associated stream
 (which can be retrieved with the `socket-stream' accessor)."))
@@ -45,21 +78,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."))
 
@@ -201,10 +220,52 @@
       , at body))
 
 
-(defgeneric wait-for-input (socket-or-sockets
-                            &key timeout)
-  (:documentation
-"Waits for one or more streams to become ready for reading from
+(defstruct (wait-list (:constructor %make-wait-list))
+  %wait     ;; implementation specific
+  waiters ;; the list of all usockets
+  map  ;; maps implementation sockets to usockets
+  )
+
+;; Implementation specific:
+;;
+;;  %setup-wait-list
+;;  %add-waiter
+;;  %remove-waiter
+
+(declaim (inline %setup-wait-list
+                 %add-waiter
+                 %remove-waiter))
+
+(defun make-wait-list (waiters)
+  (let ((wl (%make-wait-list)))
+    (setf (wait-list-map wl) (make-hash-table))
+    (%setup-wait-list wl)
+    (dolist (x waiters)
+      (add-waiter wl x))
+    wl))
+
+(defun add-waiter (wait-list input)
+  (setf (gethash (socket input) (wait-list-map wait-list)) input
+        (wait-list input) wait-list)
+  (pushnew input (wait-list-waiters wait-list))
+  (%add-waiter wait-list input))
+
+(defun remove-waiter (wait-list input)
+  (%remove-waiter wait-list input)
+  (setf (wait-list-waiters wait-list)
+        (remove input (wait-list-waiters wait-list))
+        (wait-list input) nil)
+  (remhash (socket input) (wait-list-map wait-list)))
+
+(defun remove-all-waiters (wait-list)
+  (dolist (waiter (wait-list-waiters wait-list))
+    (%remove-waiter waiter))
+  (setf (wait-list-waiters wait-list) nil)
+  (clrhash (wait-list-map wait-list)))
+
+
+(defun wait-for-input (socket-or-sockets &key timeout ready-only)
+  "Waits for one or more streams to become ready for reading from
 the socket.  When `timeout' (a non-negative real number) is
 specified, wait `timeout' seconds, or wait indefinitely when
 it isn't specified.  A `timeout' value of 0 (zero) means polling.
@@ -214,34 +275,38 @@
 be returned for this value either when waiting timed out or when
 it was interrupted (EINTR).  The second value is a real number
 indicating the time remaining within the timeout period or NIL if
-none."))
-
-
-(defmethod wait-for-input (socket-or-sockets &key timeout)
+none."
+  (unless (wait-list-p socket-or-sockets)
+    (let ((wl (make-wait-list (if (listp socket-or-sockets)
+                                  socket-or-sockets (list socket-or-sockets)))))
+      (multiple-value-bind
+            (socks to)
+          (wait-for-input wl :timeout timeout :ready-only ready-only)
+        (return-from wait-for-input
+          (values (if ready-only socks socket-or-sockets) to)))))
   (let* ((start (get-internal-real-time))
-	 (sockets (if (listp socket-or-sockets)
-		      socket-or-sockets
-		      (list socket-or-sockets)))
-	 ;; retrieve a list of all sockets which are ready without waiting
-	 (ready-sockets
-	  (remove-if (complement #'(lambda (x)
-				     (and (stream-usocket-p x)
-					  (listen (socket-stream x)))))
-		     sockets))
+         (sockets-ready 0))
+    (dolist (x (wait-list-waiters socket-or-sockets))
+      (when (setf (state x)
+                  (if (and (stream-usocket-p x)
+                           (listen (socket-stream x)))
+                      :READ NIL))
+        (incf sockets-ready)))
          ;; the internal routine is responsibe for
          ;; making sure the wait doesn't block on socket-streams of
-         ;; which the socket isn't ready, but there's space left in the
+         ;; which theready- socket isn't ready, but there's space left in the
          ;; buffer
-         (result (wait-for-input-internal
-                  sockets
-                  :timeout (if (null ready-sockets) timeout 0))))
-    (values (union ready-sockets result)
-            (when timeout
-              (let ((elapsed (/ (- (get-internal-real-time) start)
-                                internal-time-units-per-second)))
-                (when (< elapsed timeout)
-                  (- timeout elapsed)))))))
-
+    (wait-for-input-internal socket-or-sockets
+                             :timeout (if (zerop sockets-ready) timeout 0))
+    (let ((to-result (when timeout
+                       (let ((elapsed (/ (- (get-internal-real-time) start)
+                                         internal-time-units-per-second)))
+                         (when (< elapsed timeout)
+                           (- timeout elapsed))))))
+      (values (if ready-only
+                  (remove-if #'null (wait-list-waiters socket-or-sockets) :key #'state)
+                  socket-or-sockets)
+              to-result))))
 
 ;;
 ;; Data utility functions
@@ -392,7 +457,7 @@
       ((vector t 4) (host-byte-order host))
       (integer host))))
 
-;;
+;;ready-
 ;; Other utility functions
 ;;
 
@@ -416,7 +481,6 @@
 ;;
 ;; (defun SOCKET-CONNECT (host port &key element-type) ..)
 ;;
-
 (setf (documentation 'socket-connect 'function)
       "Connect to `host' on `port'.  `host' is assumed to be a string or
 an IP address represented in vector notation, such as #(192 168 1 1).
@@ -433,7 +497,7 @@
 ;;###FIXME: extend with default-element-type
 (setf (documentation 'socket-listen 'function)
       "Bind to interface `host' on `port'. `host' should be the
-representation of an interface address.  The implementation is not
+representation of an ready-interface address.  The implementation is not
 required to do an address lookup, making no guarantees that hostnames
 will be correctly resolved.  If `*wildcard-host*' is passed for `host',
 the socket will be bound to all available interfaces for the IPv4


From ehuelsmann at common-lisp.net  Sat Jul 26 21:54:21 2008
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Sat, 26 Jul 2008 17:54:21 -0400 (EDT)
Subject: [usocket-cvs] r385 - in usocket/branches/0.4.x: . backend
Message-ID: <20080726215421.E590E79166@common-lisp.net>

Author: ehuelsmann
Date: Sat Jul 26 17:54:21 2008
New Revision: 385

Modified:
   usocket/branches/0.4.x/backend/allegro.lisp
   usocket/branches/0.4.x/backend/armedbear.lisp
   usocket/branches/0.4.x/backend/clisp.lisp
   usocket/branches/0.4.x/backend/cmucl.lisp
   usocket/branches/0.4.x/backend/lispworks.lisp
   usocket/branches/0.4.x/backend/openmcl.lisp
   usocket/branches/0.4.x/backend/sbcl.lisp
   usocket/branches/0.4.x/backend/scl.lisp
   usocket/branches/0.4.x/package.lisp
   usocket/branches/0.4.x/usocket.lisp
Log:
Backport new-wfi branch to 0.4.x release branch.

Modified: usocket/branches/0.4.x/backend/allegro.lisp
==============================================================================
--- usocket/branches/0.4.x/backend/allegro.lisp	(original)
+++ usocket/branches/0.4.x/backend/allegro.lisp	Sat Jul 26 17:54:21 2008
@@ -63,6 +63,8 @@
 ;; because socket-streams are also sockets.
 (defmethod socket-close ((usocket usocket))
   "Close socket."
+  (when (wait-list usocket)
+     (remove-waiter (wait-list usocket) usocket))
   (with-mapped-conditions (usocket)
     (close (socket usocket))))
 
@@ -127,18 +129,29 @@
     (list (hbo-to-vector-quad (socket:lookup-hostname
                                (host-to-hostname name))))))
 
-(defun wait-for-input-internal (sockets &key timeout)
+(defun %setup-wait-list (wait-list)
+  (declare (ignore wait-list)))
+
+(defun %add-waiter (wait-list waiter)
+  (push (socket waiter) (wait-list-%wait wait-list)))
+
+(defun %remove-waiter (wait-list waiter)
+  (setf (wait-list-%wait wait-list)
+        (remove (socket waiter) (wait-list-%wait wait-list))))
+
+(defun wait-for-input-internal (wait-list &key timeout)
   (with-mapped-conditions ()
     (let ((active-internal-sockets
            (if timeout
-               (mp:wait-for-input-available (mapcar #'socket sockets)
+               (mp:wait-for-input-available (wait-list-%wait wait-list)
                                             :timeout timeout)
-             (mp:wait-for-input-available (mapcar #'socket sockets)))))
+             (mp:wait-for-input-available (wait-list-%wait wait-list)))))
       ;; 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))))
+      ;; [Same code is also used in openmcl.lisp]
+      (dolist (x active-internal-sockets)
+        (setf (state (gethash x (wait-list-map wait-list)))
+              :READ))
+      wait-list)))

Modified: usocket/branches/0.4.x/backend/armedbear.lisp
==============================================================================
--- usocket/branches/0.4.x/backend/armedbear.lisp	(original)
+++ usocket/branches/0.4.x/backend/armedbear.lisp	Sat Jul 26 17:54:21 2008
@@ -88,6 +88,7 @@
    (t
     (java:jclass-name (jop-class instance)))))
 
+(declaim (inline jop-deref))
 (defun jop-deref (instance)
   (if (java-object-proxy-p instance)
       (jop-value instance)
@@ -196,7 +197,6 @@
              (jchan (jdi:do-jstatic-call "java.nio.channels.SocketChannel"
                                          "open" sock-addr))
              (sock (jdi:do-jmethod-call jchan "socket")))
-        (describe sock)
          (setf usock
                (make-stream-socket
                 :socket jchan
@@ -245,6 +245,8 @@
 ;;    (print (jcall (jmethod "java.net.BindException" "getMessage") native-exception))))
 
 (defmethod socket-close ((usocket usocket))
+  (when (wait-list usocket)
+     (remove-waiter (wait-list usocket) usocket))
   (with-mapped-conditions (usocket)
     (jdi:do-jmethod (socket usocket) "close")))
 
@@ -252,6 +254,8 @@
 ;; socket streams. Closing the stream flushes
 ;; its buffers *and* closes the socket.
 (defmethod socket-close ((usocket stream-usocket))
+  (when (wait-list usocket)
+     (remove-waiter (wait-list usocket) usocket))
   (with-mapped-conditions (usocket)
     (close (socket-stream usocket))))
 
@@ -349,20 +353,20 @@
    ((datagram-usocket-p socket)
     "java.nio.channels.DatagramChannel")))
 
-(defun wait-for-input-internal (sockets &key timeout)
-  (let* ((ops (logior (op-read) (op-accept)))
+(defun wait-for-input-internal (wait-list &key timeout)
+  (let* ((sockets (wait-list-waiters wait-list))
+         (ops (logior (op-read) (op-accept)))
          (selector (jdi:do-jstatic "java.nio.channels.Selector" "open"))
          (channels (mapcar #'socket sockets)))
     (unwind-protect
         (with-mapped-conditions ()
-          (let ((jfalse (java:make-immediate-object nil :boolean))
-                (sel (jdi:jop-deref selector)))
+          (let ((sel (jdi:jop-deref selector)))
             (dolist (channel channels)
               (let ((chan (jdi:jop-deref channel)))
                 (java:jcall (java:jmethod "java.nio.channels.SelectableChannel"
                                           "configureBlocking"
                                           "boolean")
-                            chan jfalse)
+                            chan (java:make-immediate-object nil :boolean))
                 (java:jcall (java:jmethod "java.nio.channels.SelectableChannel"
                                           "register"
                                           "java.nio.channels.Selector" "int")
@@ -376,7 +380,7 @@
                 ;; we actually have work to do
                 (let* ((selkeys (jdi:do-jmethod selector "selectedKeys"))
                        (selkey-iterator (jdi:do-jmethod selkeys "iterator"))
-                       ready-sockets)
+                       (%wait (wait-list-%wait wait-list)))
                   (loop while (java:jcall
                                (java:jmethod "java.util.Iterator" "hasNext")
                                (jdi:jop-deref selkey-iterator))
@@ -385,33 +389,40 @@
                                         "java.nio.channels.SelectionKey"))
                                   (chan (jdi:jop-deref
                                          (jdi:do-jmethod key "channel"))))
-                             (push chan ready-sockets)))
-                  (remove-if #'(lambda (s)
-                                 (not (member (jdi:jop-deref (socket s))
-                                              ready-sockets
-                                              :test #'(lambda (x y)
-                                                        (java:jcall (java:jmethod "java.lang.Object"
-                                                                             "equals"
-                                                                             "java.lang.Object")
-                                                                    x y)))))
-                             sockets))))))
-      ;; cancel all Selector registrations
-      (let* ((keys (jdi:do-jmethod selector "keys"))
-             (iter (jdi:do-jmethod keys "iterator")))
-        (loop while (java:jcall (java:jmethod "java.util.Iterator" "hasNext")
-                                (jdi:jop-deref iter))
-              do (java:jcall
-                  (java:jmethod "java.nio.channels.SelectionKey" "cancel")
-                  (java:jcall (java:jmethod "java.util.Iterator" "next")
-                              (jdi:jop-deref iter)))))
-      ;; close the selector
+                             (setf (state (gethash chan %wait))
+                                   :READ))))))))
+      ;; close the selector: all keys will be deregistered
       (java:jcall (java:jmethod "java.nio.channels.Selector" "close")
                   (jdi:jop-deref selector))
       ;; make all sockets blocking again.
-      (let ((jtrue (java:make-immediate-object t :boolean)))
-        (dolist (chan channels)
-          (java:jcall (java:jmethod "java.nio.channels.SelectableChannel"
-                                          "configureBlocking"
-                                          "boolean")
-                      (jdi:jop-deref chan) jtrue))))))
+     (dolist (channel channels)
+       (java:jcall (java:jmethod "java.nio.channels.SelectableChannel"
+                                 "configureBlocking"
+                                 "boolean")
+                      (jdi:jop-deref channel)
+                      (java:make-immediate-object t :boolean))))))
+
+
+;;
+;;
+;;
+;; The WAIT-LIST part
+;;
+
+;;
+;; Note that even though Java has the concept of the Selector class, which
+;; remotely looks like a wait-list, it requires the sockets to be non-blocking.
+;; usocket however doesn't make any such guarantees and is therefore unable to
+;; use the concept outside of the waiting routine itself (blergh!).
+;;
+
+(defun %setup-wait-list (wl)
+  (setf (wait-list-%wait wl)
+        (make-hash-table :test #'equal :rehash-size 1.3d0)))
+
+(defun %add-waiter (wl w)
+  (setf (gethash (jdi:jop-deref (socket w)) (wait-list-%wait wl))
+        w))
 
+(defun %remove-waiter (wl w)
+  (remhash (socket w) (wait-list-%wait wl)))
\ No newline at end of file

Modified: usocket/branches/0.4.x/backend/clisp.lisp
==============================================================================
--- usocket/branches/0.4.x/backend/clisp.lisp	(original)
+++ usocket/branches/0.4.x/backend/clisp.lisp	Sat Jul 26 17:54:21 2008
@@ -1,4 +1,4 @@
-;;;; $Id$
+`;;;; $Id$
 ;;;; $URL$
 
 ;;;; See LICENSE for licensing information.
@@ -96,10 +96,14 @@
 ;; are the same object
 (defmethod socket-close ((usocket usocket))
   "Close socket."
+  (when (wait-list usocket)
+     (remove-waiter (wait-list usocket) usocket))
   (with-mapped-conditions (usocket)
     (close (socket usocket))))
 
 (defmethod socket-close ((usocket stream-server-usocket))
+  (when (wait-list usocket)
+     (remove-waiter (wait-list usocket) usocket))
   (socket:socket-server-close (socket usocket)))
 
 (defmethod get-local-name ((usocket usocket))
@@ -127,21 +131,32 @@
   (nth-value 1 (get-peer-name usocket)))
 
 
-(defmethod wait-for-input-internal (sockets &key timeout)
+(defun %setup-wait-list (wait-list)
+  (declare (ignore wait-list)))
+
+(defun %add-waiter (wait-list waiter)
+  (push (cons (socket waiter) NIL) (wait-list-%wait wait-list)))
+
+(defun %remove-waiter (wait-list waiter)
+  (setf (wait-list-%wait wait-list)
+        (remove (socket waiter) (wait-list-%wait wait-list) :key #'car)))
+
+(defmethod wait-for-input-internal (wait-list &key timeout)
   (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))
+      (dolist (x (wait-list-%wait wait-list))
+        (setf (cdr x) :INPUT))
+      (let* ((request-list (wait-list-%wait wait-list))
              (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))))))
+                            (socket:socket-status request-list)))
+             (sockets (wait-list-waiters wait-list)))
+        (do* ((x (pop sockets) (pop sockets))
+              (y (pop status-list) (pop status-list)))
+             ((null x))
+          (when (eq y :INPUT)
+            (setf (state x) :READ)))
+        wait-list))))
 

Modified: usocket/branches/0.4.x/backend/cmucl.lisp
==============================================================================
--- usocket/branches/0.4.x/backend/cmucl.lisp	(original)
+++ usocket/branches/0.4.x/backend/cmucl.lisp	Sat Jul 26 17:54:21 2008
@@ -97,11 +97,15 @@
 ;; socket stream when closing a stream socket.
 (defmethod socket-close ((usocket stream-usocket))
   "Close socket."
+  (when (wait-list usocket)
+     (remove-waiter (wait-list usocket) usocket))
   (with-mapped-conditions (usocket)
     (close (socket-stream usocket))))
 
 (defmethod socket-close ((usocket usocket))
   "Close socket."
+  (when (wait-list usocket)
+     (remove-waiter (wait-list usocket) usocket))
   (with-mapped-conditions (usocket)
     (ext:close-socket (socket usocket))))
 
@@ -162,26 +166,38 @@
 (defun get-host-name ()
   (unix:unix-gethostname))
 
-(defun wait-for-input-internal (sockets &key timeout)
+(defun %setup-wait-list (wait-list)
+  (declare (ignore wait-list)))
+
+(defun %add-waiter (wait-list waiter)
+  (declare (ignore wait-list waiter))
+  (push (socket waiter) (wait-list-%wait wait-list)))
+
+(defun %remove-waiter (wait-list waiter)
+  (declare (ignore wait-list waiter))
+  (setf (wait-list-%wait wait-list)
+        (remove (socket waiter) (wait-list-%wait waiter))))
+
+(defun wait-for-input-internal (wait-list &key timeout)
   (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))
+       (dolist (socket (wait-list-%wait wait-list))
+         (unix:fd-set socket rfds))
        (multiple-value-bind
            (secs musecs)
            (split-timeout (or timeout 1))
          (multiple-value-bind
              (count err)
-             (unix:unix-fast-select (1+ (reduce #'max sockets
-                                                :key #'socket))
+             (unix:unix-fast-select (1+ (reduce #'max
+                                                (wait-list-%wait wait-list)))
                                     (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)
+               (dolist (x (wait-list-waiters wait-list))
+                 (when (unix:fd-isset (socket x) rfds)
+                   (setf (state x) :READ)))
              (progn
                ;;###FIXME generate an error, except for EINTR
                )))))))

Modified: usocket/branches/0.4.x/backend/lispworks.lisp
==============================================================================
--- usocket/branches/0.4.x/backend/lispworks.lisp	(original)
+++ usocket/branches/0.4.x/backend/lispworks.lisp	Sat Jul 26 17:54:21 2008
@@ -117,9 +117,13 @@
 ;; are correctly flushed and the socket closed.
 (defmethod socket-close ((usocket stream-usocket))
   "Close socket."
+  (when (wait-list usocket)
+     (remove-waiter (wait-list usocket) usocket))
   (close (socket-stream usocket)))
 
 (defmethod socket-close ((usocket usocket))
+  (when (wait-list usocket)
+     (remove-waiter (wait-list usocket) usocket))
   (with-mapped-conditions (usocket)
      (comm::close-socket (socket usocket))))
 
@@ -169,21 +173,36 @@
 ;;;
 
 #-win32
-(defun wait-for-input-internal (sockets &key timeout)
-  (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?
-    (dolist (x sockets)
-       (mp:notice-fd (os-socket-handle x)))
-    (mp:process-wait-with-timeout "Waiting for a socket to become active"
-                                  (truncate timeout)
-                                  #'(lambda (socks)
-                                      (some #'usocket-listen socks))
-                                  sockets)
-    (dolist (x sockets)
-       (mp:unnotice-fd (os-socket-handle x)))
-    (remove nil (mapcar #'usocket-listen sockets))))
+(progn
+
+  (defun %setup-wait-list (wait-list)
+    (declare (ignore wait-list)))
+
+  (defun %add-waiter (wait-list waiter)
+    (declare (ignore wait-list waiter)))
+
+  (defun %remove-waiter (wait-list waiter)
+    (declare (ignore wait-list waiter)))
+
+  (defun wait-for-input-internal (wait-list &key timeout)
+    (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?
+      (dolist (x (wait-list-waiters wait-list))
+        (mp:notice-fd (os-socket-handle x)))
+      (mp:process-wait-with-timeout "Waiting for a socket to become active"
+                                    (truncate timeout)
+                                    #'(lambda (socks)
+                                        (let (rv)
+                                          (dolist (x socks rv)
+                                            (when (usocket-listen x)
+                                              (setf (state x) :READ
+                                                    rv t)))))
+                                    (wait-list-waiters wait-list))
+      (dolist (x (wait-list-waiters wait-list))
+        (mp:unnotice-fd (os-socket-handle x)))
+      wait-list)))
 
 
 ;;;
@@ -228,6 +247,23 @@
 
   (defconstant fionread 1074030207)
 
+
+  ;; Note:
+  ;;
+  ;;  If special finalization has to occur for a given
+  ;;  system resource (handle), an associated object should
+  ;;  be created.  A special cleanup action should be added
+  ;;  to the system and a special cleanup action should
+  ;;  be flagged on all objects created for resources like it
+  ;;
+  ;;  We have 2 functions to do so:
+  ;;   * hcl:add-special-free-action (function-symbol)
+  ;;   * hcl:flag-special-free-action (object)
+  ;;
+  ;;  Note that the special free action will be called on all
+  ;;  objects which have been flagged for special free, so be
+  ;;  sure to check for the right argument type!
+  
   (fli:define-foreign-type ws-socket () '(:unsigned :int))
   (fli:define-foreign-type win32-handle () '(:unsigned :int))
   (fli:define-c-struct wsa-network-events (network-events :long)
@@ -272,7 +308,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
@@ -292,14 +328,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))
@@ -308,43 +336,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/0.4.x/backend/openmcl.lisp
==============================================================================
--- usocket/branches/0.4.x/backend/openmcl.lisp	(original)
+++ usocket/branches/0.4.x/backend/openmcl.lisp	Sat Jul 26 17:54:21 2008
@@ -32,21 +32,23 @@
 (defun input-available-p (sockets &optional ticks-to-wait)
   (ccl::rletZ ((tv :timeval))
     (ccl::ticks-to-timeval ticks-to-wait tv)
+    ;;### The trickery below can be moved to the wait-list now...
     (ccl::%stack-block ((infds ccl::*fd-set-size*))
       (ccl::fd-zero infds)
       (let ((max-fd -1))
         (dolist (sock sockets)
-          (let ((fd (openmcl-socket:socket-os-fd sock)))
+          (let ((fd (openmcl-socket:socket-os-fd (socket sock))))
             (setf max-fd (max max-fd fd))
             (ccl::fd-set fd infds)))
         (let* ((res (#_select (1+ max-fd)
                               infds (ccl::%null-ptr) (ccl::%null-ptr)
                               (if ticks-to-wait tv (ccl::%null-ptr)))))
           (when (> res 0)
-            (remove-if #'(lambda (x)
-                           (not (ccl::fd-is-set (openmcl-socket:socket-os-fd x)
-                                                infds)))
-                       sockets)))))))
+            (dolist (x sockets)
+              (when (ccl::fd-is-set (openmcl-socket:socket-os-fd (socket x))
+                                    infds)
+                (setf (state x) :READ))))
+          sockets)))))
 
 (defun raise-error-from-id (condition-id socket real-condition)
   (let ((usock-err (cdr (assoc condition-id +openmcl-error-map+))))
@@ -104,6 +106,8 @@
 ;; and their associated objects are represented
 ;; by the same object.
 (defmethod socket-close ((usocket usocket))
+  (when (wait-list usocket)
+     (remove-waiter (wait-list usocket) usocket))
   (with-mapped-conditions (usocket)
     (close (socket usocket))))
 
@@ -136,19 +140,23 @@
      (list (hbo-to-vector-quad (openmcl-socket:lookup-hostname
                                 (host-to-hostname name))))))
 
-(defun wait-for-input-internal (sockets &key timeout)
+
+(defun %setup-wait-list (wait-list)
+  (declare (ignore wait-list)))
+
+(defun %add-waiter (wait-list waiter)
+  (declare (ignore wait-list waiter)))
+
+(defun %remove-waiter (wait-list waiter)
+  (declare (ignore wait-list waiter)))
+
+(defun wait-for-input-internal (wait-list &key timeout)
   (with-mapped-conditions ()
-    (let* ((ticks-timeout (truncate (* (or timeout 1) ccl::*ticks-per-second*)))
+    (let* ((ticks-timeout (truncate (* (or timeout 1)
+                                       ccl::*ticks-per-second*)))
            (active-internal-sockets
-            (input-available-p (mapcar #'socket sockets)
+            (input-available-p (wait-list-waiters wait-list)
                                (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))))
+      wait-list)))
 
 

Modified: usocket/branches/0.4.x/backend/sbcl.lisp
==============================================================================
--- usocket/branches/0.4.x/backend/sbcl.lisp	(original)
+++ usocket/branches/0.4.x/backend/sbcl.lisp	Sat Jul 26 17:54:21 2008
@@ -64,10 +64,37 @@
     (ffi:c-inline () () :fixnum
      "FD_SETSIZE" :one-liner t))
 
+  (defun fdset-alloc ()
+    (ffi:c-inline () () :pointer-void
+     "cl_alloc_atomic(sizeof(fd_set))" :one-liner t))
+
+  (defun fdset-zero (fdset)
+    (ffi:c-inline (fdset) (:pointer-void) :void
+     "FD_ZERO((fd_set*)#0)" :one-liner t))
+
+  (defun fdset-set (fdset fd)
+    (ffi:c-inline (fdset fd) (:pointer-void :fixnum) :void
+     "FD_SET(#1,(fd_set*)#0)" :one-liner t))
+
+  (defun fdset-clr (fdset fd)
+    (ffi:c-inline (fdset fd) (:pointer-void :fixnum) :void
+     "FD_CLR(#1,(fd_set*)#0)" :one-liner t))
+
+  (defun fdset-fd-isset (fdset fd)
+    (ffi:c-inline (fdset fd) (:pointer-void :fixnum) :bool
+     "FD_ISSET(#1,(fd_set*)#0)" :one-liner t))
+
+  (declaim (inline fd-setsize
+                   fdset-alloc
+                   fdset-zero
+                   fdset-set
+                   fdset-clr
+                   fdset-fd-isset))
+
   (defun get-host-name ()
     (ffi:c-inline
      () () :object
-     "{ char *buf = cl_alloc_atomic(256);
+     "{ char *buf = cl_alloc_atomic(257);
 
         if (gethostname(buf,256) == 0)
           @(return) = make_simple_base_string(buf);
@@ -75,62 +102,46 @@
           @(return) = Cnil;
       }" :one-liner nil :side-effects nil))
 
-  (defun read-select (read-fds to-secs &optional (to-musecs 0))
-    (ffi:c-inline (read-fds to-secs to-musecs) (t t :unsigned-int) t
-      "{
-          fd_set rfds;
-          cl_object cur_fd = #0;
+  (defun read-select (wl to-secs &optional (to-musecs 0))
+    (let* ((sockets (wait-list-waiters wl))
+           (rfds (wait-list-%wait wl))
+           (max-fd (reduce #'(lambda (x y)
+                               (let ((sy (sb-bsd-sockets:socket-file-descriptor
+                                          (socket y))))
+                                 (if (< x sy) sy x)))
+                           (cdr sockets)
+                           :initial-value (sb-bsd-sockets:socket-file-descriptor
+                                           (socket (car sockets))))))
+      (fdset-zero rfds)
+      (dolist (sock sockets)
+        (fdset-set rfds (sb-bsd-sockets:socket-file-descriptor
+                         (socket sock))))
+      (let ((count
+             (ffi:c-inline (to-secs to-musecs rfds max-fd)
+                           (t :unsigned-int :pointer-void :int)
+                           :int
+      "
           int count;
-          int max_fd = -1;
           struct timeval tv;
 
-          FD_ZERO(&rfds);
-          while (CONSP(cur_fd)) {
-            int fd = fixint(CAR(cur_fd));
-            max_fd = (max_fd > fd) ? max_fd : fd;
-            FD_SET(fd, &rfds);
-            cur_fd = CDR(cur_fd);
-          }
-
-          if (#1 != Cnil) {
-            tv.tv_sec = fixnnint(#1);
-            tv.tv_usec = #2;
+          if (#0 != Cnil) {
+            tv.tv_sec = fixnnint(#0);
+            tv.tv_usec = #1;
           }
-          count = select(max_fd + 1, &rfds, NULL, NULL,
-                         (#1 != Cnil) ? &tv : NULL);
-
-          if (count == 0)
-            @(return 0) = Cnil;
-            @(return 1) = Cnil;
-          } else if (count < 0) {
-            /*###FIXME: We should be raising an error here...
-
-              except, ofcourse in case of EINTR or EAGAIN */
-
-            @(return 0) = Cnil;
-            @(return 1) = MAKE_INTEGER(errno);
-          } else
-            {
-              cl_object rv = Cnil;
-              cur_fd = #0;
-
-              /* when we're going to use the same code on Windows,
-                 as well as unix, we can't be sure it'll fit into
-                 a fixnum: these aren't unix filehandle bitmaps sets on
-                 Windows... */
-
-              while (CONSP(cur_fd)) {
-                int fd = fixint(cur_fd->cons.car);
-                if (FD_ISSET(fd, &rfds))
-                  rv = CONS(MAKE_INTEGER(fd), rv);
-
-                cur_fd = cur_fd->cons.cdr;
-              }
-              @(return 0) = rv;
-              @(return 1) = Cnil;
-            }
-}"))
-
+        @(return) = select(#3 + 1, (fd_set*)#2, NULL, NULL,
+                           (#0 != Cnil) ? &tv : NULL);
+")))
+        (cond
+          ((= 0 count)
+           (values nil nil))
+          ((< count 0)
+           ;; check for EINTR and EAGAIN; these should not err
+           (values nil (ffi:c-inline () () :int "errno" :one-liner t)))
+          (t
+           (dolist (sock sockets)
+             (when (fdset-fd-isset rfds (sb-bsd-sockets:socket-file-descriptor
+                                         (socket sock)))
+               (setf (state sock) :READ))))))))
 )
 
 (defun map-socket-error (sock-err)
@@ -231,10 +242,14 @@
 ;; different objects. Be sure to close the stream (which
 ;; closes the socket too) when closing a stream-socket.
 (defmethod socket-close ((usocket usocket))
+  (when (wait-list usocket)
+     (remove-waiter (wait-list usocket) usocket))
   (with-mapped-conditions (usocket)
     (sb-bsd-sockets:socket-close (socket usocket))))
 
 (defmethod socket-close ((usocket stream-usocket))
+  (when (wait-list usocket)
+     (remove-waiter (wait-list usocket) usocket))
   (with-mapped-conditions (usocket)
     (close (socket-stream usocket))))
 
@@ -270,13 +285,25 @@
 #+sbcl
 (progn
   #-win32
+(defun %setup-wait-list (wait-list)
+  (declare (ignore wait-list)))
+
+(defun %add-waiter (wait-list waiter)
+  (push (socket waiter) (wait-list-%wait wait-list)))
+
+(defun %remove-waiter (wait-list waiter)
+  (setf (wait-list-%wait wait-list)
+        (remove (socket waiter) (wait-list-%wait wait-list))))
+
+
+
   (defun wait-for-input-internal (sockets &key timeout)
     (with-mapped-conditions ()
       (sb-alien:with-alien ((rfds (sb-alien:struct sb-unix:fd-set)))
          (sb-unix:fd-zero rfds)
-         (dolist (socket sockets)
+         (dolist (socket (wait-list-%wait sockets))
            (sb-unix:fd-set
-            (sb-bsd-sockets:socket-file-descriptor (socket socket))
+            (sb-bsd-sockets:socket-file-descriptor socket)
             rfds))
          (multiple-value-bind
              (secs musecs)
@@ -284,7 +311,7 @@
            (multiple-value-bind
                (count err)
                (sb-unix:unix-fast-select
-                (1+ (reduce #'max (mapcar #'socket sockets)
+                (1+ (reduce #'max (mapcar #'socket (wait-list-waiters sockets))
                             :key #'sb-bsd-sockets:socket-file-descriptor))
                 (sb-alien:addr rfds) nil nil
                 (when timeout secs) musecs)
@@ -293,12 +320,11 @@
 		   (error (map-errno-error err)))
 		 (when (< 0 count)
 		   ;; process the result...
-		   (remove-if
-		    #'(lambda (x)
-			(not (sb-unix:fd-isset
-			      (sb-bsd-sockets:socket-file-descriptor (socket x))
-			      rfds)))
-		    sockets))))))))
+                   (dolist (x (wait-list-waiters sockets))
+                     (when (not (sb-unix:fd-isset
+                                 (sb-bsd-sockets:socket-file-descriptor (socket x))
+                                 rfds))
+                       (setf (state x) :READ))))))))))
 
   #+win32
   (warn "wait-for-input not (yet!) supported...")
@@ -306,23 +332,25 @@
 
 #+ecl
 (progn
-  (defun wait-for-input-internal (sockets &key timeout)
+  (defun wait-for-input-internal (wl &key timeout)
     (with-mapped-conditions ()
       (multiple-value-bind
-          (secs usecs)
+            (secs usecs)
           (split-timeout (or timeout 1))
-        (let* ((sock-fds (mapcar #'sb-bsd-sockets:socket-file-descriptor
-                                 (mapcar #'socket sockets))))
-	  (multiple-value-bind
-		(result-fds err)
-	      (read-select sock-fds (when timeout secs) usecs)
-	    (if (null err)
-		(remove-if #'(lambda (s)
-			       (not
-				(member
-				 (sb-bsd-sockets:socket-file-descriptor
-				  (socket s))
-				 result-fds)))
-			   sockets)
-		(error (map-errno-error err))))))))
+        (multiple-value-bind
+              (result-fds err)
+            (read-select wl (when timeout secs) usecs)
+          (unless (null err)
+            (error (map-errno-error err)))))))
+
+  (defun %setup-wait-list (wl)
+    (setf (wait-list-%wait wl)
+          (fdset-alloc)))
+
+  (defun %add-waiter (wl w)
+    (declare (ignore wl w)))
+
+  (defun %remove-waiter (wl w)
+    (declare (ignore wl w)))
+
   )

Modified: usocket/branches/0.4.x/backend/scl.lisp
==============================================================================
--- usocket/branches/0.4.x/backend/scl.lisp	(original)
+++ usocket/branches/0.4.x/backend/scl.lisp	Sat Jul 26 17:54:21 2008
@@ -69,11 +69,15 @@
 ;; are flushed and the socket is closed correctly afterwards.
 (defmethod socket-close ((usocket usocket))
   "Close socket."
+  (when (wait-list usocket)
+     (remove-waiter (wait-list usocket) usocket))
   (with-mapped-conditions (usocket)
     (ext:close-socket (socket usocket))))
 
 (defmethod socket-close ((usocket stream-usocket))
   "Close socket."
+  (when (wait-list usocket)
+     (remove-waiter (wait-list usocket) usocket))
   (with-mapped-conditions (usocket)
     (close (socket-stream usocket))))
 

Modified: usocket/branches/0.4.x/package.lisp
==============================================================================
--- usocket/branches/0.4.x/package.lisp	(original)
+++ usocket/branches/0.4.x/package.lisp	Sat Jul 26 17:54:21 2008
@@ -15,7 +15,6 @@
              #:socket-listen
              #:socket-accept
              #:socket-close
-             #:wait-for-input
              #:get-local-address
              #:get-peer-address
              #:get-local-port
@@ -23,6 +22,12 @@
              #:get-local-name
              #:get-peer-name
 
+             #:wait-for-input ; waiting for input-ready state (select() like)
+             #:make-wait-list
+             #:add-waiter
+             #:remove-waiter
+             #:remove-all-waiters
+
              #:with-connected-socket ; convenience macros
              #:with-server-socket
              #:with-client-socket

Modified: usocket/branches/0.4.x/usocket.lisp
==============================================================================
--- usocket/branches/0.4.x/usocket.lisp	(original)
+++ usocket/branches/0.4.x/usocket.lisp	Sat Jul 26 17:54:21 2008
@@ -15,7 +15,40 @@
   ((socket
     :initarg :socket
     :accessor socket
-    :documentation "Implementation specific socket object instance."))
+    :documentation "Implementation specific socket object instance.'")
+   (wait-list
+    :initform nil
+    :accessor wait-list
+    :documentation "WAIT-LIST the object is associated with.")
+   (state
+    :initform nil
+    :accessor state
+    :documentation "Per-socket return value for the `wait-for-input' function.
+
+The value stored in this slot can be any of
+ NIL          - not ready
+ :READ        - ready to read
+ :READ-WRITE  - ready to read and write
+ :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.
 
@@ -33,7 +66,7 @@
 ))
    (:documentation
 "Stream socket class.
-
+'
 Contrary to other sockets, these sockets may be closed either
 with the `socket-close' method or by closing the associated stream
 (which can be retrieved with the `socket-stream' accessor)."))
@@ -45,21 +78,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."))
 
@@ -195,10 +214,52 @@
       , at body))
 
 
-(defgeneric wait-for-input (socket-or-sockets
-                            &key timeout)
-  (:documentation
-"Waits for one or more streams to become ready for reading from
+(defstruct (wait-list (:constructor %make-wait-list))
+  %wait     ;; implementation specific
+  waiters ;; the list of all usockets
+  map  ;; maps implementation sockets to usockets
+  )
+
+;; Implementation specific:
+;;
+;;  %setup-wait-list
+;;  %add-waiter
+;;  %remove-waiter
+
+(declaim (inline %setup-wait-list
+                 %add-waiter
+                 %remove-waiter))
+
+(defun make-wait-list (waiters)
+  (let ((wl (%make-wait-list)))
+    (setf (wait-list-map wl) (make-hash-table))
+    (%setup-wait-list wl)
+    (dolist (x waiters)
+      (add-waiter wl x))
+    wl))
+
+(defun add-waiter (wait-list input)
+  (setf (gethash (socket input) (wait-list-map wait-list)) input
+        (wait-list input) wait-list)
+  (pushnew input (wait-list-waiters wait-list))
+  (%add-waiter wait-list input))
+
+(defun remove-waiter (wait-list input)
+  (%remove-waiter wait-list input)
+  (setf (wait-list-waiters wait-list)
+        (remove input (wait-list-waiters wait-list))
+        (wait-list input) nil)
+  (remhash (socket input) (wait-list-map wait-list)))
+
+(defun remove-all-waiters (wait-list)
+  (dolist (waiter (wait-list-waiters wait-list))
+    (%remove-waiter waiter))
+  (setf (wait-list-waiters wait-list) nil)
+  (clrhash (wait-list-map wait-list)))
+
+
+(defun wait-for-input (socket-or-sockets &key timeout ready-only)
+  "Waits for one or more streams to become ready for reading from
 the socket.  When `timeout' (a non-negative real number) is
 specified, wait `timeout' seconds, or wait indefinitely when
 it isn't specified.  A `timeout' value of 0 (zero) means polling.
@@ -208,33 +269,38 @@
 be returned for this value either when waiting timed out or when
 it was interrupted (EINTR).  The second value is a real number
 indicating the time remaining within the timeout period or NIL if
-none."))
-
-
-(defmethod wait-for-input (socket-or-sockets &key timeout)
+none."
+  (unless (wait-list-p socket-or-sockets)
+    (let ((wl (make-wait-list (if (listp socket-or-sockets)
+                                  socket-or-sockets (list socket-or-sockets)))))
+      (multiple-value-bind
+            (socks to)
+          (wait-for-input wl :timeout timeout :ready-only ready-only)
+        (return-from wait-for-input
+          (values (if ready-only socks socket-or-sockets) to)))))
   (let* ((start (get-internal-real-time))
-	 (sockets (if (listp socket-or-sockets)
-		      socket-or-sockets
-		      (list socket-or-sockets)))
-	 ;; retrieve a list of all sockets which are ready without waiting
-	 (ready-sockets
-	  (remove-if (complement #'(lambda (x)
-				     (and (stream-usocket-p x)
-					  (listen (socket-stream x)))))
-		     sockets))
+         (sockets-ready 0))
+    (dolist (x (wait-list-waiters socket-or-sockets))
+      (when (setf (state x)
+                  (if (and (stream-usocket-p x)
+                           (listen (socket-stream x)))
+                      :READ NIL))
+        (incf sockets-ready)))
          ;; the internal routine is responsibe for
          ;; making sure the wait doesn't block on socket-streams of
-         ;; which the socket isn't ready, but there's space left in the
+         ;; which theready- socket isn't ready, but there's space left in the
          ;; buffer
-         (result (wait-for-input-internal
-                  sockets
-                  :timeout (if (null ready-sockets) timeout 0))))
-    (values (union ready-sockets result)
-            (when timeout
-              (let ((elapsed (/ (- (get-internal-real-time) start)
-                                internal-time-units-per-second)))
-                (when (< elapsed timeout)
-                  (- timeout elapsed)))))))
+    (wait-for-input-internal socket-or-sockets
+                             :timeout (if (zerop sockets-ready) timeout 0))
+    (let ((to-result (when timeout
+                       (let ((elapsed (/ (- (get-internal-real-time) start)
+                                         internal-time-units-per-second)))
+                         (when (< elapsed timeout)
+                           (- timeout elapsed))))))
+      (values (if ready-only
+                  (remove-if #'null (wait-list-waiters socket-or-sockets) :key #'state)
+                  socket-or-sockets)
+              to-result))))
 
 ;;
 ;; IP(v4) utility functions
@@ -350,7 +416,7 @@
       ((vector t 4) (host-byte-order host))
       (integer host))))
 
-;;
+;;ready-
 ;; Other utility functions
 ;;
 
@@ -374,7 +440,6 @@
 ;;
 ;; (defun SOCKET-CONNECT (host port &key element-type) ..)
 ;;
-
 (setf (documentation 'socket-connect 'function)
       "Connect to `host' on `port'.  `host' is assumed to be a string or
 an IP address represented in vector notation, such as #(192 168 1 1).
@@ -391,7 +456,7 @@
 ;;###FIXME: extend with default-element-type
 (setf (documentation 'socket-listen 'function)
       "Bind to interface `host' on `port'. `host' should be the
-representation of an interface address.  The implementation is not
+representation of an ready-interface address.  The implementation is not
 required to do an address lookup, making no guarantees that hostnames
 will be correctly resolved.  If `*wildcard-host*' is passed for `host',
 the socket will be bound to all available interfaces for the IPv4


From ehuelsmann at common-lisp.net  Wed Jul 30 22:56:08 2008
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Wed, 30 Jul 2008 18:56:08 -0400 (EDT)
Subject: [usocket-cvs] r407 - usocket/trunk/backend
Message-ID: <20080730225608.8DB353E056@common-lisp.net>

Author: ehuelsmann
Date: Wed Jul 30 18:56:07 2008
New Revision: 407

Modified:
   usocket/trunk/backend/sbcl.lisp
Log:
Fix SBCL and ECL compilation.

Modified: usocket/trunk/backend/sbcl.lisp
==============================================================================
--- usocket/trunk/backend/sbcl.lisp	(original)
+++ usocket/trunk/backend/sbcl.lisp	Wed Jul 30 18:56:07 2008
@@ -37,6 +37,7 @@
 
 #+ecl
 (progn
+
   #-:wsock
   (ffi:clines
    "#include <errno.h>"
@@ -60,6 +61,9 @@
    "#define CONS(x, y) make_cons((x), (y))"
    "#define MAKE_INTEGER(x) make_integer((x))")
 
+  (defconstant sb-bsd-sockets::sockopt-tcp-nodelay (sockopt-tcp-nodelay))
+  (export sb-bsd-sockets::sockopt-tcp-nodelay)
+
   (defun fd-setsize ()
     (ffi:c-inline () () :fixnum
      "FD_SETSIZE" :one-liner t))
@@ -204,6 +208,9 @@
                        local-host local-port)
   (when deadline (unsupported 'deadline 'socket-connect))
   (when timeout (unsupported 'timeout 'socket-connect))
+  (when (and nodelay-specified
+             (not (fboundp 'sb-bsd-sockets::sockopt-tcp-nodelay)))
+    (unsupported 'nodelay 'socket-connect))
 
   (let* ((socket (make-instance 'sb-bsd-sockets:inet-socket
                                 :type :stream :protocol :tcp))
@@ -215,11 +222,14 @@
          ;;###FIXME: The above line probably needs an :external-format
          (usocket (make-stream-socket :stream stream :socket socket))
          (ip (host-to-vector-quad host)))
-    (when nodelay-specified
+    (when (and nodelay-specified
+               (fboundp 'sb-bsd-sockets::sockopt-tcp-nodelay))
       (setf (sb-bsd-sockets:sockopt-tcp-nodelay socket) nodelay))
     (when (or local-host local-port)
-      (sb-bsd-sockets:bind socket (host-to-vector-quad (or local-host *wildcard-host*))
-                           (or local-port *auto-port*)))
+      (sb-bsd-sockets:socket-bind socket
+                                  (host-to-vector-quad
+                                   (or local-host *wildcard-host*))
+                                  (or local-port *auto-port*)))
     (with-mapped-conditions (usocket)
       (sb-bsd-sockets:socket-connect socket ip port))
     usocket))


From ehuelsmann at common-lisp.net  Wed Jul 30 22:57:42 2008
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Wed, 30 Jul 2008 18:57:42 -0400 (EDT)
Subject: [usocket-cvs] r408 - usocket/trunk/backend
Message-ID: <20080730225742.609F2620B9@common-lisp.net>

Author: ehuelsmann
Date: Wed Jul 30 18:57:42 2008
New Revision: 408

Modified:
   usocket/trunk/backend/sbcl.lisp
Log:
Revert too much added in the last commit.

Modified: usocket/trunk/backend/sbcl.lisp
==============================================================================
--- usocket/trunk/backend/sbcl.lisp	(original)
+++ usocket/trunk/backend/sbcl.lisp	Wed Jul 30 18:57:42 2008
@@ -61,9 +61,6 @@
    "#define CONS(x, y) make_cons((x), (y))"
    "#define MAKE_INTEGER(x) make_integer((x))")
 
-  (defconstant sb-bsd-sockets::sockopt-tcp-nodelay (sockopt-tcp-nodelay))
-  (export sb-bsd-sockets::sockopt-tcp-nodelay)
-
   (defun fd-setsize ()
     (ffi:c-inline () () :fixnum
      "FD_SETSIZE" :one-liner t))


From ehuelsmann at common-lisp.net  Thu Jul 31 05:50:08 2008
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Thu, 31 Jul 2008 01:50:08 -0400 (EDT)
Subject: [usocket-cvs] r409 - usocket/trunk/backend
Message-ID: <20080731055008.F31D163033@common-lisp.net>

Author: ehuelsmann
Date: Thu Jul 31 01:50:06 2008
New Revision: 409

Modified:
   usocket/trunk/backend/armedbear.lisp
Log:
ABCL fixes for getting socket names.

Modified: usocket/trunk/backend/armedbear.lisp
==============================================================================
--- usocket/trunk/backend/armedbear.lisp	(original)
+++ usocket/trunk/backend/armedbear.lisp	Thu Jul 31 01:50:06 2008
@@ -275,16 +275,24 @@
     (close (socket-stream usocket))))
 
 (defmethod get-local-address ((usocket usocket))
-  (dotted-quad-to-vector-quad (ext:socket-local-address (socket usocket))))
+  (dotted-quad-to-vector-quad (ext:socket-local-address
+                               (jdi:jop-deref
+                                (jdi:do-jmethod-call (socket usocket)
+                                  "socket")))))
 
 (defmethod get-peer-address ((usocket stream-usocket))
-  (dotted-quad-to-vector-quad (ext:socket-peer-address (socket usocket))))
+  (dotted-quad-to-vector-quad (ext:socket-peer-address
+                               (jdi:jop-deref
+                                (jdi:do-jmethod-call (socket usocket)
+                                  "socket")))))
 
 (defmethod get-local-port ((usocket usocket))
-  (ext:socket-local-port (socket usocket)))
+  (ext:socket-local-port (jdi:jop-deref
+                          (jdi:do-jmethod-call (socket usocket) "socket"))))
 
 (defmethod get-peer-port ((usocket stream-usocket))
-  (ext:socket-peer-port (socket usocket)))
+  (ext:socket-peer-port (jdi:jop-deref
+                         (jdi:do-jmethod-call (socket usocket) "socket"))))
 
 (defmethod get-local-name ((usocket usocket))
   (values (get-local-address usocket)


From ehuelsmann at common-lisp.net  Thu Jul 31 06:17:55 2008
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Thu, 31 Jul 2008 02:17:55 -0400 (EDT)
Subject: [usocket-cvs] r410 - usocket/branches/0.4.x
Message-ID: <20080731061755.3C85B4904E@common-lisp.net>

Author: ehuelsmann
Date: Thu Jul 31 02:17:53 2008
New Revision: 410

Removed:
   usocket/branches/0.4.x/
Log:
Delete for re-branching.


From ehuelsmann at common-lisp.net  Thu Jul 31 06:18:31 2008
From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net)
Date: Thu, 31 Jul 2008 02:18:31 -0400 (EDT)
Subject: [usocket-cvs] r411 - usocket/branches/0.4.x
Message-ID: <20080731061831.D2D1763033@common-lisp.net>

Author: ehuelsmann
Date: Thu Jul 31 02:18:31 2008
New Revision: 411

Added:
   usocket/branches/0.4.x/
      - copied from r410, usocket/trunk/
Log:
Re-branch.