sbcl stuff

sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/.gitignore

@@ -0,0 +1 @@
+*~

sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/CHANGES

@@ -0,0 +1,211 @@
+0.8.3:
+
+  * New experimental backend: Mezzano (contributed by Bruno Cichon, #51)
+  * Bugfix: WAIT-FOR-INPUT fails to honor :ready-only t (#57, thanks to @Reepca for reporting this issue)
+  * Bugfix: [ECL] Fix read-select in backend/sbcl.lisp to loop if interrupted (#54, #55, thanks to @thijs)
+  * [CCL] Fix compiling with (readtable-case readtable-case) of :invert. (#56, patch from @genworks)
+  * [Genera] added file attibutes (to all USOCKET lisp files) for Genera.
+
+0.8.2: (June 11, 2019)
+
+  * General: now the HOST-OR-IP slot of NS-CONDITION has been exported. (#46)
+  * Bugfix: NS-HOST-NOT-FOUND-ERROR condition has unbound HOST-OR-IP slot (#46)
+  * Bugfix: [SBCL/LW] WAIT-FOR-INPUT waits only in the first call (when W-F-I is called with a single usocket, introduced in 0.8.0) (#50, thanks to @Hamayama for reporting/hints/testing this issue)
+
+0.8.1: (Feb 27, 2019)
+
+* New backend: clasp (patch from Christian Schafmeister, #45)
+* Bugfix: [SBCL] fixed loading usocket.asd in SBCL 1.5.0
+
+0.8.0: (Feb 4, 2019)
+
+* New backend (experimental): IOlib. (Push :USOCKET-IOLIB to *FEATURES* to enable this feature)
+* New feature: Optimized WAIT-FOR-INPUT for single-socket case (one-time consing)
+* New feature: Exported host-to-hostname (#42)
+* Bugfix: [SBCL] more robust/thread-safe WAIT-FOR-INPUT-INTERNAL
+
+0.7.1: (Aug 31, 2018)
+
+* New feature: GET-(RANDOM)-HOST-BY-NAME (now exported) prefer IPv4 on mixed IPv4/IPv6 (suggested by Mark H. David)
+* New backend: Symbolics Open Genera (Lisp machine) (patch from @Symbolics, #33)
+* Bugfix: [CLISP] fixed issues in server sockets and error handling. (patch from @vibs29, #28, #29)
+* Bugfix: [SBCL, ECL] Fix wait-for-input on Windows SBCL and ECL. (patch from Stas Boukarev, #30)
+* Bugfix: [LW] fixed non-existing system calls in LW 5.0 (comm::socket-set-tcp-nodelay)
+
+0.7.0: (Oct 25, 2016)
+
+* General: Separated USOCKET and USOCKET-SERVER systems (only the server part depends on Portable-threads)
+* General: USOCKET now depends on SPLIT-SEQUENCE (the exactly same vendor code is removed from usocket code base)
+* New feature: [LW] (SOCKET-OPTION :TCP-NODELAY) and its SETF version now works on LispWorks 4/5/6/7.
+* New feature: [LW] SOCKET-CONNECT now supports setting "tcp_nodelay" in version 4.x and 5.0.
+* Bugfix: [CCL] fixed issues in SOCKET-SHUTDOWN
+* Bugfix: [CLISP] fixed issues in WAIT-FOR-INPUT (Thanks to a patch by @vibs29, #27)
+* Bugfix: [LW] fixed loading in version <= 6.0 (actually 0.6.5 only fixed loading in LW 6.1)
+* Bugfix: [ECL] all compilation warnings were checked and fixed.
+
+0.6.5: (Oct 19, 2016)
+
+* New feature: SOCKET-OPTION and (setf SOCKET-OPTION) for :SEND-TIMEOUT (thanks to John Pallister)
+* Bugfix: Let (WAIT-FOR-INPUT NIL &TIMEOUT) return NIL with respect to TIMEOUT.
+* Bugfix: [LW] fixed loading in LispWorks 5.x & 6.x.
+* Bugfix: [LW] fixed SOCKET-SHUTDOWN in all versions.
+* Bugfix: [ABCL] Fixed incorrect IPv6 addresses (#26), patch from Elias Mårtenson (lokedhs)
+
+0.6.4: (Mar 17, 2016)
+
+* New feature: [SBCL] IPv6 support (patch from Guillaume LE VAILLANT, #15)
+* New feature: [API] SOCKET-SHUTDOWN added (patch from Thayne McCombs #9)
+* New feature: [Corman] minimal initial support of this platform
+* Bugfix: [SBCL/win32] wait-for-input nil-timeout bug (patch from Michal Herda, #13)
+* Bugfix: [ECL] included unistd.h for gethostname() (patch from Daniel Kochmanski, #7)
+* Bugfix: [LispWorks] SOCKET-RECEIVE now updates %READ-P (patch from Frank James)
+
+0.6.3: (May 23, 2015)
+
+* Bugfix: [CCL] Further fixed CCL-1.11 compatibility and a typo in SOCKET-CONNECT for CCL-1.10.
+* Bugfix: [ECL] Fixed build in some versions.
+* Bugfix: [LispWorks] SOCKET-SEND and SOCKET-RECEIVE now throw conditions if something goes wrong.
+
+0.6.2: (Apr 20, 2015)
+
+* Bugfix: [CCL] Fixed CCL-1.11 compatibility.
+* Bugfix: [ECL] Fixed compatibility on recent versions.
+* Bugfix: [LispWorks] Added support address-in-use-error condition on LW/Win32. (patch from Sergey Katrevich).
+
+0.6.1: (Jun 21, 2013)
+
+* New feature: [MOCL] Initial MOCL support (TCP only, no W-F-I, patch from github.com/Wukix/usocket).
+* New feature: [MCL] Initial UDP support for Macintosh Common Lisp (MCL/RMCL).
+* New feature: Added TCP-NO-DELAY (TCP_NODELAY) support in SOCKET-OPTION, for TCP client
+* Bugfix: [CCL] Added (:external-format ccl:*default-external-format*) to SOCKET-CONNECT, to prevent it fallback to ISO-8859-1 on NIL. (Patch from Vsevolod Dyomkin)
+* Bugfix: [CCL] Performance improved WAIT-FOR-INPUT and other fixes. (patch from Faré <fahree@gmail.com>)
+
+0.6.0: (Dec 26, 2012)
+
+* New feature: SOCKET-OPTION and (setf SOCKET-OPTION) for seting and geting various socket options.
+* New feature: SOCKET-SEND now support an CCL-like OFFSET keyword for sending only parts of the whole buffer.
+* New feature: [ECL] Added support for ECL DFFI mode on Windows. (no need for C compilers now)
+* Bugfix: [ECL] ECL now list sb-bsd-sockets as a dependency but relies on REQUIRE. (patched by Juanjo)
+* Bugfix: [ABCL] Make USOCKET compile warning-free on ABCL again: MAKE-IMMEDIATE-OBJECT was deprecated a while ago in favor of 2 predefined constants.
+* Bugfix: [LispWorks] remove redundant call to hcl:flag-special-free-action. (reported by Kamil Shakirov)
+* Bugfix: [CLISP] improved HANDLE-CONDITION for more CLISP environments.
+
+0.5.5: (Feb 27, 2012)
+
+* Enhancement: SOCKET-CONNECT argument :nodelay can now set to :if-supported (patch from Anton Vodonosov).
+* Enhancement: [Server] adding *remote-host* *remote-port* to socket-server stream handler functions (suggested by Matthew Curry)
+* Bugfix: [LispWorks] Fixed UDP support for LispWorks 6.1 (patch from Camille Troillard by Martin Simmons).
+* Bugfix: [LispWorks] Stop using hcl:add-special-free-action for reclaiming unused UDP socket fds to improve multi-threading stablity (suggested by Camille Troillard).
+* Bugfix: [LispWorks] Fixed SOCKET-CONNECT on Windows, now LOCAL-PORT never have *auto-port* (0) as default value.
+
+0.5.4: (Oct 1, 2011)
+
+* Bugfix: [ECL] Fixed for ECL's MAKE-BUILD by removing some unecessary code (reported by Juan Jose Garcia-Ripoll, the ECL maintainer)
+* Bugfix: [ACL] Fixed for Allegro CL modern mode.
+* Bugfix: [SBCL] SOCKET-CONNECT on TCP won't call bind() when keyword arguments LOCAL-HOST or LOCAL-PORT is not set. (reported by Robert Brown)
+
+0.5.3: (Aug 13, 2011)
+
+* Bugfix: [MCL] Fixed SOCKET-LISTEN on vector addresses like #(0 0 0 0)
+* Bugfix: [MCL] Fixed WAIT-FOR-INPUT on passive sockets (stream-server-usocket)
+* Bugfix: [LispWorks] Fixed using OPEN-UDP-SOCKET in delivered applications (thanks to Camille Troillard and Martin Simmons, this fix is from LispWorks-UDP project).
+* Bugfix: [SBCL] Fixed for "SBCL data flush problem", reported by Robert Brown and confirmed by Nikodemus Siivola.
+
+0.5.2: (May 11, 2011)
+
+* General: [SBCL] SOCKET-CONNECT's TIMEOUT argument was limited on non-Windows platforms.
+* Bugfix: [CLISP] WAIT-FOR-INPUT now functions right (with/without READY-ONLY), this made Hunchentoot working on CLISP. (Thanks to Anton Vodonosov <avodonosov@yandex.ru>)
+* Bugfix: [ABCL] Fix SOCKET-ACCEPT to follow the documented API so that when called without an :ELEMENT-TYPE argument. (Thanks to Mark Evenson, the ABCL developer)
+* Bugfix: [LispWorks] Fixed SOCKET-ACCEPT (Windows only) on WAIT-FOR-INPUTed sockets.
+* Bugfix: [SBCL, ECL] Fixed wrongly STATE set/unset for WAIT-FOR-INPUT on Windows (report by Elliott Slaughter)
+* Enhancement: Additional NAME keyword argument for SOCKET-SERVER for setting the server thread name.
+* Enhancement: [ABCL] GET-ADDRESS now works with underlying IPv6 addresses.
+* Enhancement: [CLISP] missing GET-LOCAL-* methods for STREAM-SERVER-USOCKET was now added.
+
+0.5.1: (Apr 2, 2011)
+
+* New feature: [CLISP] UDP (Datagram) support based on FFI (Win/Mac/Linux), no RAWSOCK needed.
+* Enhancement: SOCKET-SERVER return a second value (socket) when calling in new-thread mode.
+* Enhancement: [CLISP] Full support of DNS helper functions (GET-HOST-BY-NAME, ...) added.
+* Enhancement: [CLISP] Better network error type detection based on OS error code.
+* Enhancement: [LispWorks] Better network error type detection based on OS error code.
+* Bugfix: Fixed wrong macro expansions of {IP|PORT}-{FROM|TO}-OCTET-BUFFER functions (since 0.4.0)
+* Bugfix: SOCKET-CONNECT didn't set CONNECTED-P for datagram usockets on most backends.
+* Bugfix: [SBCL] Fixes for "SBCL/Win32: finalizer problem, etc", by Anton Kovalenko <anton@sw4me.com>
+* Bugfix: [SBCL] Fixed SOCKET-SERVER (UDP) on SBCL due to a issue in SOCKET-CONNECT when HOST is NIL.
+* Bugfix: [SBCL] SOCKET-CONNECT's TIMEOUT argument now works as a "connection timeout".
+* Bugfix: [CMUCL] Fixed SOCKET-SEND on unconnected usockets under Unicode version of CMUCL.
+* Bugfix: [CLISP] Fixed and confirmed UDP (Datagram) support (RAWSOCK version).
+
+0.5.0: (Mar 12, 2011)
+
+* New supported platform: Macintosh Common Lisp (5.0 and up, plus RMCL)
+* Support for UDP (datagram-usocket) was added (for all supported platform except MCL)
+* Add WAIT-FOR-INPUT support for SBCL and ECL on win32.
+* Simple TCP and UDP server API: SOCKET-SERVER
+* Completely rewritten full-feature ABCL backends using latest Java interfaces
+* Lots of bug fixed since 0.4.1
+
+0.4.1: (Dec 27, 2008)
+
+* fixes for ECL, LispWorks, SBCL, SCL
+
+0.4.0: (Oct 28, 2008)
+
+* select()-like api: make a single thread wait for multiple sockets.
+* various socket options for socket-creation with SOCKET-CONNECT.
+
+0.3.6: (Jun 21, 2008)
+
+* Code fixups based on advice from the ECL and OpenMCL maintainers.
+* New exported symbols: WITH-MAPPED-CONDITIONS, NS-CONDITION, NS-ERROR, NS-UNKNOWN-ERROR and NS-UNKNOWN-CONDITION.
+
+0.3.4: (Jul 25, 2007)
+
+* Fix clisp get-host-name, multiple ECL fixes.
+
+0.3.3: (Jun 05, 2007)
+
+* Fix where host resolution routine was unable to resolve would return NIL instead of erroring.
+
+0.3.2: (Mar 04, 2007)
+
+* Fixes for many backends related to closing sockets.
+* LispWorks fix for broken server sockets.
+* API guarantee adjustments in preparation of porting Drakma.
+
+0.3.1: (Feb 28, 2007)
+
+* fixed with-server-socket; prevent creation of invalid sockets; 2 more convenience macros.
+
+0.3.0: (Jan 21, 2007)
+
+* Server sockets
+
+0.2.5: (Jan 19, 2007)
+
+* Allegro compilation fix.
+
+0.2.4: (Jan 17, 2007)
+
+* Various fixes for CMUCL, OpenMCL, Allegro and LispWorks.
+
+0.2.3: (Jan 04, 2007)
+
+* Add :element-type support to support stacking flexi-streams on socket streams for portable :external-format support.
+
+0.2.2: (Jan 03, 2007)
+
+* Add ECL support and a small SBCL bugfix.
+
+0.2.1: (Dec 21, 2006)
+
+* Remove 'open-stream' interface which is supposed to be provided by the 'trivial-usocket' package.
+
+0.2.0: (Dec 18, 2006)
+
+* Add support for Scieneer Common Lisp, fix issue #6 and API preparation for server side sockets (not in this release)
+
+0.1.0: (Feb 13, 2006)
+
+* Initial release

sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/CONTRIBUTORS

@@ -0,0 +1,47 @@
+-*- Mode: outline -*-
+
+List of major USOCKET contributors:
+
+* Erik Enge
+* Erik Huelsmann <ehuels@gmail.com>
+  - original authors
+
+* Chun Tian <binghe.lisp@gmail.com>
+* Hans Huebner <hans.huebner@gmail.com>
+  - current maintainers
+
+* Attila Lendvai <attila.lendvai@gmail.com>
+  - better handling of unsupported Lisps
+
+* Vladimir Sekissov <svg@surnet.ru>
+  - fixes for CMUCL implementation
+
+* Pierre Thierry <nowhere.man@levallois.eu.org>
+  - added license information
+
+* Stelian Ionescu <sionescu@cddr.org>
+  - finished conversion from generic functions
+  - enabled running thread-safe code in unthreaded lisps
+
+* Douglas Crosher <dtc@scieneer.com>
+  - added Scieneer Common Lisp support
+
+* Frank James
+  - UDP fixes and test cases
+
+* Mark H. David <mhd@yv.org>
+  - UDP test cases
+  - Suggestions on fixing GET-HOST-BY-NAME and HOST-TO-HBO
+
+* Elliott Slaughter <elliottslaughter@gmail.com>
+  - Advanced WAIT-FOR-INPUT test case
+
+* Anton Vodonosov <avodonosov@yandex.ru>
+  - CLISP fixes
+
+* Terje Norderhaug <terje@in-progress.com>
+  - MCL vendor code
+
+* @Hamayama <fkyo0985@gmail.com>
+
+  - Reporting/hints/testing of issue #50 (regression in 0.8.0, 0.8.1)

sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/LICENSE

@@ -0,0 +1,25 @@
+(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
+Copyright (c) 2008-2019 Hans Hueber and Chun Tian
+
+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.

sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/README.md

@@ -0,0 +1,148 @@
+## USOCKET - Universal socket library for Common Lisp
+
+https://common-lisp.net/project/usocket/
+
+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:
+
+1. Allegro CL
+2. ABCL (ArmedBear)
+3. Clasp
+4. Clozure CL
+5. Corman Lisp
+6. GNU CLISP
+7. CMUCL
+8. ECL
+9. LispWorks (4.3 and up)
+10. Digitool MCL and RMCL (5.0 and up)
+11. Mezzano
+12. MOCL
+13. SBCL
+14. Scieneer CL
+15. Symbolics Lisp Machine (Genera)
+
+If your favorite common lisp misses in the list above, please contact
+usocket-devel@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
+ - socket-shutdown
+
+### 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
+  https://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?)

sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/TODO

@@ -0,0 +1,5 @@
+- Fix condition systems (making all implementation generate same error)
+- Add INET6 support.
+- IOlib backend
+
+For more TODO items, see http://trac.common-lisp.net/usocket/report.

sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/.gitignore

@@ -0,0 +1 @@
+*~

sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/abcl.lisp

@@ -0,0 +1,436 @@
+;;;; New ABCL networking support (replacement to old armedbear.lisp)
+;;;; Author: Chun Tian (binghe)
+
+;;;; See LICENSE for licensing information.
+
+(in-package :usocket)
+
+;;; Java Classes ($*...)
+(defvar $*boolean (jclass "boolean"))
+(defvar $*byte (jclass "byte"))
+(defvar $*byte[] (jclass "[B"))
+(defvar $*int (jclass "int"))
+(defvar $*long (jclass "long"))
+(defvar $*|Byte| (jclass "java.lang.Byte"))
+(defvar $*DatagramChannel (jclass "java.nio.channels.DatagramChannel"))
+(defvar $*DatagramPacket (jclass "java.net.DatagramPacket"))
+(defvar $*DatagramSocket (jclass "java.net.DatagramSocket"))
+(defvar $*Inet4Address (jclass "java.net.Inet4Address"))
+(defvar $*InetAddress (jclass "java.net.InetAddress"))
+(defvar $*InetSocketAddress (jclass "java.net.InetSocketAddress"))
+(defvar $*Iterator (jclass "java.util.Iterator"))
+(defvar $*SelectableChannel (jclass "java.nio.channels.SelectableChannel"))
+(defvar $*SelectionKey (jclass "java.nio.channels.SelectionKey"))
+(defvar $*Selector (jclass "java.nio.channels.Selector"))
+(defvar $*ServerSocket (jclass "java.net.ServerSocket"))
+(defvar $*ServerSocketChannel (jclass "java.nio.channels.ServerSocketChannel"))
+(defvar $*Set (jclass "java.util.Set"))
+(defvar $*Socket (jclass "java.net.Socket"))
+(defvar $*SocketAddress (jclass "java.net.SocketAddress"))
+(defvar $*SocketChannel (jclass "java.nio.channels.SocketChannel"))
+(defvar $*String (jclass "java.lang.String"))
+
+;;; Java Constructor ($%.../n)
+(defvar $%Byte/0 (jconstructor $*|Byte| $*byte))
+(defvar $%DatagramPacket/3 (jconstructor $*DatagramPacket $*byte[] $*int $*int))
+(defvar $%DatagramPacket/5 (jconstructor $*DatagramPacket $*byte[] $*int $*int $*InetAddress $*int))
+(defvar $%DatagramSocket/0 (jconstructor $*DatagramSocket))
+(defvar $%DatagramSocket/1 (jconstructor $*DatagramSocket $*int))
+(defvar $%DatagramSocket/2 (jconstructor $*DatagramSocket $*int $*InetAddress))
+(defvar $%InetSocketAddress/1 (jconstructor $*InetSocketAddress $*int))
+(defvar $%InetSocketAddress/2 (jconstructor $*InetSocketAddress $*InetAddress $*int))
+(defvar $%ServerSocket/0 (jconstructor $*ServerSocket))
+(defvar $%ServerSocket/1 (jconstructor $*ServerSocket $*int))
+(defvar $%ServerSocket/2 (jconstructor $*ServerSocket $*int $*int))
+(defvar $%ServerSocket/3 (jconstructor $*ServerSocket $*int $*int $*InetAddress))
+(defvar $%Socket/0 (jconstructor $*Socket))
+(defvar $%Socket/2 (jconstructor $*Socket $*InetAddress $*int))
+(defvar $%Socket/4 (jconstructor $*Socket $*InetAddress $*int $*InetAddress $*int))
+
+;;; Java Methods ($@...[/Class]/n)
+(defvar $@accept/0 (jmethod $*ServerSocket "accept"))
+(defvar $@bind/DatagramSocket/1 (jmethod $*DatagramSocket "bind" $*SocketAddress))
+(defvar $@bind/ServerSocket/1 (jmethod $*ServerSocket "bind" $*SocketAddress))
+(defvar $@bind/ServerSocket/2 (jmethod $*ServerSocket "bind" $*SocketAddress $*int))
+(defvar $@bind/Socket/1 (jmethod $*Socket "bind" $*SocketAddress))
+(defvar $@byteValue/0 (jmethod $*|Byte| "byteValue"))
+(defvar $@channel/0 (jmethod $*SelectionKey "channel"))
+(defvar $@close/DatagramSocket/0 (jmethod $*DatagramSocket "close"))
+(defvar $@close/Selector/0 (jmethod $*Selector "close"))
+(defvar $@close/ServerSocket/0 (jmethod $*ServerSocket "close"))
+(defvar $@close/Socket/0 (jmethod $*Socket "close"))
+(defvar $@shutdownInput/Socket/0 (jmethod $*Socket "shutdownInput"))
+(defvar $@shutdownOutput/Socket/0 (jmethod $*Socket "shutdownOutput"))
+(defvar $@configureBlocking/1 (jmethod $*SelectableChannel "configureBlocking" $*boolean))
+(defvar $@connect/DatagramChannel/1 (jmethod $*DatagramChannel "connect" $*SocketAddress))
+(defvar $@connect/Socket/1 (jmethod $*Socket "connect" $*SocketAddress))
+(defvar $@connect/Socket/2 (jmethod $*Socket "connect" $*SocketAddress $*int))
+(defvar $@connect/SocketChannel/1 (jmethod $*SocketChannel "connect" $*SocketAddress))
+(defvar $@getAddress/0 (jmethod $*InetAddress "getAddress"))
+(defvar $@getAllByName/1 (jmethod $*InetAddress "getAllByName" $*String))
+(defvar $@getByName/1 (jmethod $*InetAddress "getByName" $*String))
+(defvar $@getChannel/DatagramSocket/0 (jmethod $*DatagramSocket "getChannel"))
+(defvar $@getChannel/ServerSocket/0 (jmethod $*ServerSocket "getChannel"))
+(defvar $@getChannel/Socket/0 (jmethod $*Socket "getChannel"))
+(defvar $@getAddress/DatagramPacket/0 (jmethod $*DatagramPacket "getAddress"))
+(defvar $@getHostName/0 (jmethod $*InetAddress "getHostName"))
+(defvar $@getInetAddress/DatagramSocket/0 (jmethod $*DatagramSocket "getInetAddress"))
+(defvar $@getInetAddress/ServerSocket/0 (jmethod $*ServerSocket "getInetAddress"))
+(defvar $@getInetAddress/Socket/0 (jmethod $*Socket "getInetAddress"))
+(defvar $@getLength/DatagramPacket/0 (jmethod $*DatagramPacket "getLength"))
+(defvar $@getLocalAddress/DatagramSocket/0 (jmethod $*DatagramSocket "getLocalAddress"))
+(defvar $@getLocalAddress/Socket/0 (jmethod $*Socket "getLocalAddress"))
+(defvar $@getLocalPort/DatagramSocket/0 (jmethod $*DatagramSocket "getLocalPort"))
+(defvar $@getLocalPort/ServerSocket/0 (jmethod $*ServerSocket "getLocalPort"))
+(defvar $@getLocalPort/Socket/0 (jmethod $*Socket "getLocalPort"))
+(defvar $@getOffset/DatagramPacket/0 (jmethod $*DatagramPacket "getOffset"))
+(defvar $@getPort/DatagramPacket/0 (jmethod $*DatagramPacket "getPort"))
+(defvar $@getPort/DatagramSocket/0 (jmethod $*DatagramSocket "getPort"))
+(defvar $@getPort/Socket/0 (jmethod $*Socket "getPort"))
+(defvar $@hasNext/0 (jmethod $*Iterator "hasNext"))
+(defvar $@iterator/0 (jmethod $*Set "iterator"))
+(defvar $@next/0 (jmethod $*Iterator "next"))
+(defvar $@open/DatagramChannel/0 (jmethod $*DatagramChannel "open"))
+(defvar $@open/Selector/0 (jmethod $*Selector "open"))
+(defvar $@open/ServerSocketChannel/0 (jmethod $*ServerSocketChannel "open"))
+(defvar $@open/SocketChannel/0 (jmethod $*SocketChannel "open"))
+(defvar $@receive/1 (jmethod $*DatagramSocket "receive" $*DatagramPacket))
+(defvar $@register/2 (jmethod $*SelectableChannel "register" $*Selector $*int))
+(defvar $@select/0 (jmethod $*Selector "select"))
+(defvar $@select/1 (jmethod $*Selector "select" $*long))
+(defvar $@selectedKeys/0 (jmethod $*Selector "selectedKeys"))
+(defvar $@send/1 (jmethod $*DatagramSocket "send" $*DatagramPacket))
+(defvar $@setReuseAddress/1 (jmethod $*ServerSocket "setReuseAddress" $*boolean))
+(defvar $@setSoTimeout/DatagramSocket/1 (jmethod $*DatagramSocket "setSoTimeout" $*int))
+(defvar $@setSoTimeout/Socket/1 (jmethod $*Socket "setSoTimeout" $*int))
+(defvar $@setTcpNoDelay/1 (jmethod $*Socket "setTcpNoDelay" $*boolean))
+(defvar $@socket/DatagramChannel/0 (jmethod $*DatagramChannel "socket"))
+(defvar $@socket/ServerSocketChannel/0 (jmethod $*ServerSocketChannel "socket"))
+(defvar $@socket/SocketChannel/0 (jmethod $*SocketChannel "socket"))
+(defvar $@validOps/0 (jmethod $*SelectableChannel "validOps"))
+
+;;; Java Field Variables ($+...)
+(defvar $+op-accept (jfield $*SelectionKey "OP_ACCEPT"))
+(defvar $+op-connect (jfield $*SelectionKey "OP_CONNECT"))
+(defvar $+op-read (jfield $*SelectionKey "OP_READ"))
+(defvar $+op-write (jfield $*SelectionKey "OP_WRITE"))
+
+
+;;; Wrapper functions (return-type: java-object)
+(defun %get-address (address)
+  (jcall $@getAddress/0 address))
+(defun %get-all-by-name (string) ; return a simple vector
+  (jstatic $@getAllByName/1 $*InetAddress string))
+(defun %get-by-name (string)
+  (jstatic $@getByName/1 $*InetAddress string))
+
+(defun host-to-inet4 (host)
+  "USOCKET host formats to Java Inet4Address, used internally."
+  (%get-by-name (host-to-hostname host)))
+
+;;; HANDLE-CONTITION
+
+(defparameter +abcl-error-map+
+  `(("java.net.BindException" . operation-not-permitted-error)
+    ("java.net.ConnectException" . connection-refused-error)
+    ("java.net.NoRouteToHostException" . network-unreachable-error) ; untested
+    ("java.net.PortUnreachableException" . protocol-not-supported-error) ; untested
+    ("java.net.ProtocolException" . protocol-not-supported-error) ; untested
+    ("java.net.SocketException" . socket-type-not-supported-error) ; untested
+    ("java.net.SocketTimeoutException" . timeout-error)))
+
+(defparameter +abcl-nameserver-error-map+
+  `(("java.net.UnknownHostException" . ns-host-not-found-error)))
+
+(defun handle-condition (condition &optional (socket nil) (host-or-ip nil))
+  (typecase condition
+    (java-exception
+     (let ((java-cause (java-exception-cause condition)))
+       (let* ((usock-error (cdr (assoc (jclass-of java-cause) +abcl-error-map+
+				       :test #'string=)))
+	      (usock-error (if (functionp usock-error)
+			       (funcall usock-error condition)
+			       usock-error))
+	      (nameserver-error (cdr (assoc (jclass-of java-cause) +abcl-nameserver-error-map+
+					    :test #'string=))))
+	 (if nameserver-error
+	     (error nameserver-error :socket socket :host-or-ip host-or-ip)
+	     (when usock-error
+	       (error usock-error :socket socket))))))))
+
+;;; GET-HOSTS-BY-NAME
+
+(defun get-address (address)
+  (when address
+    (let* ((array (%get-address address))
+	   (length (jarray-length array)))
+      (labels ((jbyte (n)
+		 (let ((byte (jarray-ref array n)))
+		   (if (minusp byte) (+ 256 byte) byte))))
+	(cond  
+          ((= 4 length)
+           (vector (jbyte 0) (jbyte 1) (jbyte 2) (jbyte 3)))
+          ((= 16 length)
+           (vector (jbyte 0) (jbyte 1) (jbyte 2) (jbyte 3) 
+                   (jbyte 4) (jbyte 5) (jbyte 6) (jbyte 7)
+                   (jbyte 8) (jbyte 9) (jbyte 10) (jbyte 11)
+                   (jbyte 12) (jbyte 13) (jbyte 14) (jbyte 15)))
+          (t nil)))))) ; neither a IPv4 nor IPv6 address?!
+
+(defun get-hosts-by-name (name)
+  (with-mapped-conditions (nil name)
+    (map 'list #'get-address (%get-all-by-name name))))
+
+;;; GET-HOST-BY-ADDRESS
+
+(defun get-host-by-address (host)
+  (let ((inet4 (host-to-inet4 host)))
+    (with-mapped-conditions (nil host)
+      (jcall $@getHostName/0 inet4))))
+
+;;; SOCKET-CONNECT
+
+(defun socket-connect (host port &key (protocol :stream) (element-type 'character)
+                       timeout deadline (nodelay t nodelay-supplied-p)
+                       local-host local-port)
+  (when deadline (unsupported 'deadline 'socket-connect))
+  (let (socket stream usocket)
+    (ecase protocol
+      (:stream ; TCP
+       (let ((channel (jstatic $@open/SocketChannel/0 $*SocketChannel))
+	     (address (jnew $%InetSocketAddress/2 (host-to-inet4 host) port)))
+	 (setq socket (jcall $@socket/SocketChannel/0 channel))
+	 ;; bind to local address if needed
+	 (when (or local-host local-port)
+	   (let ((local-address (jnew $%InetSocketAddress/2 (host-to-inet4 local-host) (or local-port 0))))
+	     (with-mapped-conditions (nil host)
+	       (jcall $@bind/Socket/1 socket local-address))))
+	 ;; connect to dest address
+	 (with-mapped-conditions (nil host)
+	   (jcall $@connect/SocketChannel/1 channel address))
+	 (setq stream (ext:get-socket-stream socket :element-type element-type)
+	       usocket (make-stream-socket :stream stream :socket socket))
+	 (when nodelay-supplied-p
+	   (jcall $@setTcpNoDelay/1 socket (if nodelay ;; both t and :if-supported mean java:+true+
+                                           java:+true+ java:+false+)))
+	 (when timeout
+	   (jcall $@setSoTimeout/Socket/1 socket (truncate (* 1000 timeout))))))
+      (:datagram ; UDP
+       (let ((channel (jstatic $@open/DatagramChannel/0 $*DatagramChannel)))
+	 (setq socket (jcall $@socket/DatagramChannel/0 channel))
+	 ;; bind to local address if needed
+	 (when (or local-host local-port)
+	   (let ((local-address (jnew $%InetSocketAddress/2 (host-to-inet4 local-host) (or local-port 0))))
+	     (with-mapped-conditions (nil local-host)
+	       (jcall $@bind/DatagramSocket/1 socket local-address))))
+	 ;; connect to dest address if needed
+	 (when (and host port)
+	   (let ((address (jnew $%InetSocketAddress/2 (host-to-inet4 host) port)))
+	     (with-mapped-conditions (nil host)
+	       (jcall $@connect/DatagramChannel/1 channel address))))
+	 (setq usocket (make-datagram-socket socket :connected-p (if (and host port) t nil)))
+	 (when timeout
+	   (jcall $@setSoTimeout/DatagramSocket/1 socket (truncate (* 1000 timeout)))))))
+    usocket))
+
+;;; SOCKET-LISTEN
+
+(defun socket-listen (host port &key reuseaddress
+                      (reuse-address nil reuse-address-supplied-p)
+		      (backlog 5 backlog-supplied-p)
+		      (element-type 'character))
+  (declare (type boolean reuse-address))
+  (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress))
+	 (channel (jstatic $@open/ServerSocketChannel/0 $*ServerSocketChannel))
+	 (socket (jcall $@socket/ServerSocketChannel/0 channel))
+	 (endpoint (jnew $%InetSocketAddress/2 (host-to-inet4 host) (or port 0))))
+    (jcall $@setReuseAddress/1 socket (if reuseaddress java:+true+ java:+false+))
+    (with-mapped-conditions (socket host)
+      (if backlog-supplied-p
+	  (jcall $@bind/ServerSocket/2 socket endpoint backlog)
+	  (jcall $@bind/ServerSocket/1 socket endpoint)))
+    (make-stream-server-socket socket :element-type element-type)))
+
+;;; SOCKET-ACCEPT
+
+(defmethod socket-accept ((usocket stream-server-usocket) 
+                          &key (element-type 'character element-type-p))
+  (with-mapped-conditions (usocket)
+    (let* ((client-socket (jcall $@accept/0 (socket usocket)))
+           (element-type (if element-type-p 
+                             element-type
+                             (element-type usocket)))
+	   (stream (ext:get-socket-stream client-socket :element-type element-type)))
+      (make-stream-socket :stream stream :socket client-socket))))
+
+;;; SOCKET-CLOSE
+
+(defmethod socket-close ((usocket stream-server-usocket))
+  (with-mapped-conditions (usocket)
+    (jcall $@close/ServerSocket/0 (socket usocket))))
+
+(defmethod socket-close ((usocket stream-usocket))
+  (with-mapped-conditions (usocket)
+    (close (socket-stream usocket))
+    (jcall $@close/Socket/0 (socket usocket))))
+
+(defmethod socket-close ((usocket datagram-usocket))
+  (with-mapped-conditions (usocket)
+    (jcall $@close/DatagramSocket/0 (socket usocket))))
+
+(defmethod socket-shutdown ((usocket stream-usocket) direction)
+  (with-mapped-conditions (usocket)
+    (ecase direction
+      (:input
+       (jcall $@shutdownInput/Socket/0 (socket usocket)))
+      (:output
+       (jcall $@shutdownOutput/Socket/0 (socket usocket))))))
+
+;;; GET-LOCAL/PEER-NAME/ADDRESS/PORT
+
+(defmethod get-local-name ((usocket usocket))
+  (values (get-local-address usocket)
+	  (get-local-port usocket)))
+
+(defmethod get-peer-name ((usocket usocket))
+  (values (get-peer-address usocket)
+	  (get-peer-port usocket)))
+
+(defmethod get-local-address ((usocket stream-usocket))
+  (get-address (jcall $@getLocalAddress/Socket/0 (socket usocket))))
+
+(defmethod get-local-address ((usocket stream-server-usocket))
+  (get-address (jcall $@getInetAddress/ServerSocket/0 (socket usocket))))
+
+(defmethod get-local-address ((usocket datagram-usocket))
+  (get-address (jcall $@getLocalAddress/DatagramSocket/0 (socket usocket))))
+
+(defmethod get-peer-address ((usocket stream-usocket))
+  (get-address (jcall $@getInetAddress/Socket/0 (socket usocket))))
+
+(defmethod get-peer-address ((usocket datagram-usocket))
+  (get-address (jcall $@getInetAddress/DatagramSocket/0 (socket usocket))))
+
+(defmethod get-local-port ((usocket stream-usocket))
+  (jcall $@getLocalPort/Socket/0 (socket usocket)))
+
+(defmethod get-local-port ((usocket stream-server-usocket))
+  (jcall $@getLocalPort/ServerSocket/0 (socket usocket)))
+
+(defmethod get-local-port ((usocket datagram-usocket))
+  (jcall $@getLocalPort/DatagramSocket/0 (socket usocket)))
+
+(defmethod get-peer-port ((usocket stream-usocket))
+  (jcall $@getPort/Socket/0 (socket usocket)))
+
+(defmethod get-peer-port ((usocket datagram-usocket))
+  (jcall $@getPort/DatagramSocket/0 (socket usocket)))
+
+;;; SOCKET-SEND & SOCKET-RECEIVE
+
+(defun *->byte (data)
+  (declare (type (unsigned-byte 8) data)) ; required by SOCKET-SEND
+  (jnew $%Byte/0 (if (> data 127) (- data 256) data)))
+
+(defun byte->* (byte &optional (element-type '(unsigned-byte 8)))
+  (let* ((ub8 (if (minusp byte) (+ 256 byte) byte)))
+    (if (eq element-type 'character)
+	(code-char ub8)
+	ub8)))
+
+(defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0))
+  (let* ((socket (socket usocket))
+	 (byte-array (jnew-array $*byte size))
+	 (packet (if (and host port)
+		     (jnew $%DatagramPacket/5 byte-array 0 size (host-to-inet4 host) port)
+		     (jnew $%DatagramPacket/3 byte-array 0 size))))
+    ;; prepare sending data
+    (loop for i from offset below (+ size offset)
+       do (setf (jarray-ref byte-array i) (*->byte (aref buffer i))))
+    (with-mapped-conditions (usocket host)
+      (jcall $@send/1 socket packet))))
+
+;;; TODO: return-host and return-port cannot be get ...
+(defmethod socket-receive ((usocket datagram-usocket) buffer length
+			   &key (element-type '(unsigned-byte 8)))
+  (declare (values (simple-array (unsigned-byte 8) (*)) ; buffer
+		   (integer 0)                          ; size
+		   (unsigned-byte 32)                   ; host
+		   (unsigned-byte 16)))                 ; port
+  (let* ((socket (socket usocket))
+	 (real-length (or length +max-datagram-packet-size+))
+	 (byte-array (jnew-array $*byte real-length))
+	 (packet (jnew $%DatagramPacket/3 byte-array 0 real-length)))
+    (with-mapped-conditions (usocket)
+      (jcall $@receive/1 socket packet))
+    (let* ((receive-length (jcall $@getLength/DatagramPacket/0 packet))
+	   (return-buffer (or buffer (make-array receive-length :element-type element-type))))
+      (loop for i from 0 below receive-length
+	 do (setf (aref return-buffer i)
+		  (byte->* (jarray-ref byte-array i) element-type)))
+      (let ((return-host (if (connected-p usocket)
+			     (get-peer-address usocket)
+			     (get-address (jcall $@getAddress/DatagramPacket/0 packet))))
+	    (return-port (if (connected-p usocket)
+			     (get-peer-port usocket)
+			     (jcall $@getPort/DatagramPacket/0 packet))))
+	(values return-buffer
+		receive-length
+		return-host
+		return-port)))))
+
+;;; WAIT-FOR-INPUT
+
+(defun socket-channel-class (usocket)
+  (cond ((stream-usocket-p usocket) $*SocketChannel)
+	((stream-server-usocket-p usocket) $*ServerSocketChannel)
+	((datagram-usocket-p usocket) $*DatagramChannel)))
+
+(defun get-socket-channel (usocket)
+  (let ((method (cond ((stream-usocket-p usocket) $@getChannel/Socket/0)
+		      ((stream-server-usocket-p usocket) $@getChannel/ServerSocket/0)
+		      ((datagram-usocket-p usocket) $@getChannel/DatagramSocket/0))))
+    (jcall method (socket usocket))))
+
+(defun wait-for-input-internal (wait-list &key timeout)
+  (let* ((sockets (wait-list-waiters wait-list))
+	 (ops (logior $+op-read $+op-accept))
+	 (selector (jstatic $@open/Selector/0 $*Selector))
+	 (channels (mapcar #'get-socket-channel sockets)))
+    (unwind-protect
+	 (with-mapped-conditions ()
+	   (dolist (channel channels)
+	     (jcall $@configureBlocking/1 channel java:+false+)
+	     (jcall $@register/2 channel selector (logand ops (jcall $@validOps/0 channel))))
+	   (let ((ready-count (if timeout
+				  (jcall $@select/1 selector (truncate (* timeout 1000)))
+				  (jcall $@select/0 selector))))
+	     (when (plusp ready-count)
+	       (let* ((keys (jcall $@selectedKeys/0 selector))
+		      (iterator (jcall $@iterator/0 keys))
+		      (%wait (wait-list-%wait wait-list)))
+		 (loop while (jcall $@hasNext/0 iterator)
+		       do (let* ((key (jcall $@next/0 iterator))
+				 (channel (jcall $@channel/0 key)))
+			    (setf (state (gethash channel %wait)) :read)))))))
+      (jcall $@close/Selector/0 selector)
+      (dolist (channel channels)
+	(jcall $@configureBlocking/1 channel java:+true+)))))
+
+;;; WAIT-LIST
+
+;;; NOTE from original worker (Erik):
+;;; 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 (get-socket-channel w) (wait-list-%wait wl)) w))
+
+(defun %remove-waiter (wl w)
+  (remhash (get-socket-channel w) (wait-list-%wait wl)))

sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/allegro.lisp

@@ -0,0 +1,228 @@
+;;;; See LICENSE for licensing information.
+
+(in-package :usocket)
+
+#+cormanlisp
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (require :acl-socket))
+
+#+allegro
+(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
+  #+allegro (excl.osi:gethostname)
+  #+cormanlisp "")
+
+(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)))
+
+;; TODO: what's the error class of Corman Lisp?
+(defun handle-condition (condition &optional (socket nil) (host-or-ip nil))
+  "Dispatch correct usocket condition."
+  (typecase condition
+    #+allegro
+    (excl:socket-error
+     (let ((usock-error
+            (cdr (assoc (excl:stream-error-identifier condition)
+                        +allegro-identifier-error-map+))))
+       (declare (type symbol usock-error))
+       (if usock-error
+           (cond ((subtypep usock-error 'ns-error)
+                  (error usock-error :socket socket :host-or-ip host-or-ip))
+                 (t
+                  (error usock-error :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 (protocol :stream) (element-type 'character)
+                       timeout deadline
+                       (nodelay t) ;; nodelay == t is the ACL default
+                       local-host local-port)
+  (when timeout (unsupported 'timeout 'socket-connect))
+  (when deadline (unsupported 'deadline 'socket-connect))
+  (when (eq nodelay :if-supported)
+    (setf nodelay t))
+
+  (let ((socket))
+    (setf socket
+          (with-mapped-conditions (socket (or host local-host))
+            (ecase protocol
+              (:stream
+	       (labels ((make-socket ()
+			  (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)))
+                 #+allegro
+		 (if timeout
+		     (mp:with-timeout (timeout nil)
+		       (make-socket))
+		     (make-socket))
+                 #+cormanlisp (make-socket)))
+              (:datagram
+	       (apply #'socket:make-socket
+		      (nconc (list :type protocol
+				   :address-family :internet
+				   :local-host (when local-host
+						 (host-to-hostname local-host))
+				   :local-port local-port
+				   :format (to-format element-type))
+			     (if (and host port)
+				 (list :connect :active
+				       :remote-host (host-to-hostname host)
+				       :remote-port port)
+				 (list :connect :passive))))))))
+    (ecase protocol
+      (:stream
+       (make-stream-socket :socket socket :stream socket))
+      (:datagram
+       (make-datagram-socket socket :connected-p (and host port t))))))
+
+;; 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))))
+
+(defmethod socket-shutdown ((usocket stream-usocket) direction)
+  (with-mapped-conditions (usocket)
+    (socket:shutdown (socket usocket) :direction direction)))
+
+(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 (nil host)
+                 (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))
+  #+allegro
+  (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)))
+
+#+allegro
+(defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0))
+  (with-mapped-conditions (usocket host)
+    (let ((s (socket usocket)))
+      (socket:send-to s
+		      (if (zerop offset)
+			  buffer
+			  (subseq buffer offset (+ offset size)))
+		      size
+		      :remote-host host
+		      :remote-port port))))
+
+#+allegro
+(defmethod socket-receive ((usocket datagram-usocket) buffer length &key)
+  (declare (values (simple-array (unsigned-byte 8) (*)) ; buffer
+		   (integer 0)                          ; size
+		   (unsigned-byte 32)                   ; host
+		   (unsigned-byte 16)))                 ; port
+  (with-mapped-conditions (usocket)
+    (let ((s (socket usocket)))
+      (socket:receive-from s length :buffer buffer :extract t))))
+
+(defun get-host-by-address (address)
+  (with-mapped-conditions (nil address)
+    (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 (nil name)
+    (list (hbo-to-vector-quad (socket:lookup-hostname
+                               (host-to-hostname name))))))
+
+(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))))
+
+#+allegro
+(defun wait-for-input-internal (wait-list &key timeout)
+  (with-mapped-conditions ()
+    (let ((active-internal-sockets
+           (if timeout
+               (mp:wait-for-input-available (wait-list-%wait wait-list)
+                                            :timeout timeout)
+             (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 openmcl.lisp]
+      (dolist (x active-internal-sockets)
+        (setf (state (gethash x (wait-list-map wait-list)))
+              :read))
+      wait-list)))

sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/clasp.lisp

@@ -0,0 +1,158 @@
+(in-package :usocket)
+
+#-clasp
+(progn
+  #-:wsock
+  (ffi:clines
+   "#include <errno.h>"
+   "#include <sys/socket.h>"
+   "#include <unistd.h>")
+  #+:wsock
+  (ffi:clines
+   "#ifndef FD_SETSIZE"
+   "#define FD_SETSIZE 1024"
+   "#endif"
+   "#include <winsock2.h>")
+  (ffi:clines
+   #+:msvc "#include <time.h>"
+   #-:msvc "#include <sys/time.h>"
+   "#include <ecl/ecl-inl.h>"))
+(progn
+  #-clasp
+  (defun cerrno ()
+    (ffi:c-inline () () :int
+		  "errno" :one-liner t))
+  #+clasp
+  (defun cerrno ()
+    (sockets-internal:errno))
+  
+  #-clasp
+  (defun fd-setsize ()
+    (ffi:c-inline () () :fixnum
+		  "FD_SETSIZE" :one-liner t))
+  #+clasp
+  (defun fd-setsize () (sockets-internal:fd-setsize))
+
+  #-clasp
+  (defun fdset-alloc ()
+    (ffi:c-inline () () :pointer-void
+		  "ecl_alloc_atomic(sizeof(fd_set))" :one-liner t))
+  #+clasp (defun fdset-alloc () (sockets-internal::alloc-atomic-sizeof-fd-set))
+
+  #-clasp
+  (defun fdset-zero (fdset)
+    (ffi:c-inline (fdset) (:pointer-void) :void
+		  "FD_ZERO((fd_set*)#0)" :one-liner t))
+  #+clasp(defun fdset-zero (fdset) (sockets-internal:fdset-zero fdset))
+
+  #-clasp
+  (defun fdset-set (fdset fd)
+    (ffi:c-inline (fdset fd) (:pointer-void :fixnum) :void
+		  "FD_SET(#1,(fd_set*)#0)" :one-liner t))
+  #+clasp(defun fdset-set (fdset fd) (sockets-internal:fdset-set fd fdset))
+
+  #-clasp
+  (defun fdset-clr (fdset fd)
+    (ffi:c-inline (fdset fd) (:pointer-void :fixnum) :void
+		  "FD_CLR(#1,(fd_set*)#0)" :one-liner t))
+  #+clasp(defun fdset-clr (fdset fd) (sockets-internal:fdset-clr fd fdset))
+
+  #-clasp
+  (defun fdset-fd-isset (fdset fd)
+    (ffi:c-inline (fdset fd) (:pointer-void :fixnum) :bool
+		  "FD_ISSET(#1,(fd_set*)#0)" :one-liner t))
+  #+clasp(defun fdset-fd-isset (fdset fd) (sockets-internal:fdset-isset fd fdset))
+
+  (declaim (inline cerrno
+                   fd-setsize
+                   fdset-alloc
+                   fdset-zero
+                   fdset-set
+                   fdset-clr
+                   fdset-fd-isset))
+  #-clasp
+  (defun get-host-name ()
+    (ffi:c-inline
+     () () :object
+     "{ char *buf = (char *) ecl_alloc_atomic(257);
+
+        if (gethostname(buf,256) == 0)
+          @(return) = make_simple_base_string(buf);
+        else
+          @(return) = Cnil;
+      }" :one-liner nil :side-effects nil))
+
+  #+clasp
+  (defun get-host-name ()
+    (sockets-internal:get-host-name))
+
+  #-clasp
+  (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;
+          struct timeval tv;
+
+          if (#0 != Cnil) {
+            tv.tv_sec = fixnnint(#0);
+            tv.tv_usec = #1;
+          }
+        @(return) = select(#3 + 1, (fd_set*)#2, NULL, NULL,
+                           (#0 != Cnil) ? &tv : NULL);
+" :one-liner nil)))
+        (cond
+          ((= 0 count)
+           (values nil nil))
+          ((< count 0)
+           ;; check for EINTR and EAGAIN; these should not err
+           (values nil (cerrno)))
+          (t
+           (dolist (sock sockets)
+             (when (fdset-fd-isset rfds (sb-bsd-sockets:socket-file-descriptor
+                                         (socket sock)))
+               (setf (state sock) :READ))))))))
+
+  #+clasp
+  (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 (sockets-internal:do-select to-secs to-musecs rfds max-fd)))
+        (cond
+          ((= 0 count)
+           (values nil nil))
+          ((< count 0)
+           ;; check for EINTR and EAGAIN; these should not err
+           (values nil (cerrno)))
+          (t
+           (dolist (sock sockets)
+             (when (fdset-fd-isset rfds (sb-bsd-sockets:socket-file-descriptor
+                                         (socket sock)))
+               (setf (state sock) :READ))))))))
+  )

sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/clisp.lisp

@@ -0,0 +1,715 @@
+;;;; See LICENSE for licensing information.
+
+(in-package :usocket)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  #-ffi
+  (warn "This image doesn't contain FFI package, GET-HOST-NAME won't work.")
+  #-(or ffi rawsock)
+  (warn "This image doesn't contain either FFI or RAWSOCK package, no UDP support."))
+
+;; utility routine for looking up the current host name
+#+ffi
+(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")
+	 #-win32 (:library :default)
+         (:language #-win32 :stdc
+                    #+win32 :stdc-stdcall)
+         (:return-type ffi:int))
+
+(defun get-host-name ()
+  #+ffi
+  (multiple-value-bind (retcode name)
+      (get-host-name-internal 256)
+    (when (= retcode 0)
+      name))
+  #-ffi
+  "localhost")
+
+(defun get-host-by-address (address)
+  (with-mapped-conditions (nil address)
+    (let ((hostent (posix:resolve-host-ipaddr (host-to-hostname address))))
+      (posix:hostent-name hostent))))
+
+(defun get-hosts-by-name (name)
+  (with-mapped-conditions (nil name)
+    (let ((hostent (posix:resolve-host-ipaddr name)))
+      (mapcar #'host-to-vector-quad
+              (posix:hostent-addr-list hostent)))))
+
+;; Format: ((UNIX Windows) . CONDITION)
+(defparameter +clisp-error-map+
+  #-win32
+  `((:EADDRINUSE . address-in-use-error)
+    (:EADDRNOTAVAIL . address-not-available-error)
+    (:EBADF . bad-file-descriptor-error)
+    (:ECONNREFUSED  . connection-refused-error)
+    (:ECONNRESET . connection-reset-error)
+    (:ECONNABORTED . connection-aborted-error)
+    (:EINVAL . invalid-argument-error)
+    (:ENOBUFS . no-buffers-error)
+    (:ENOMEM . out-of-memory-error)
+    (:ENOTSUP . operation-not-supported-error)
+    (:EPERM . operation-not-permitted-error)
+    (:EPROTONOSUPPORT . protocol-not-supported-error)
+    (:ESOCKTNOSUPPORT . socket-type-not-supported-error)
+    (:ENETUNREACH . network-unreachable-error)
+    (:ENETDOWN . network-down-error)
+    (:ENETRESET . network-reset-error)
+    (:ESHUTDOWN . already-shutdown-error)
+    (:ETIMEDOUT . timeout-error)
+    (:EHOSTDOWN . host-down-error)
+    (:EHOSTUNREACH . host-unreachable-error)
+    ;; when blocked reading, and we close our socket due to a timeout.
+    ;; POSIX.1 says that EAGAIN and EWOULDBLOCK may have the same values.
+    (:EAGAIN . timeout-error)
+    (:EWOULDBLOCK . timeout-error)) ;linux
+  #+win32
+  `((:WSAEADDRINUSE . address-in-use-error)
+    (:WSAEADDRNOTAVAIL . address-not-available-error)
+    (:WSAEBADF . bad-file-descriptor-error)
+    (:WSAECONNREFUSED  . connection-refused-error)
+    (:WSAECONNRESET . connection-reset-error)
+    (:WSAECONNABORTED . connection-aborted-error)
+    (:WSAEINVAL . invalid-argument-error)
+    (:WSAENOBUFS . no-buffers-error)
+    (:WSAENOMEM . out-of-memory-error)
+    (:WSAENOTSUP . operation-not-supported-error)
+    (:WSAEPERM . operation-not-permitted-error)
+    (:WSAEPROTONOSUPPORT . protocol-not-supported-error)
+    (:WSAESOCKTNOSUPPORT . socket-type-not-supported-error)
+    (:WSAENETUNREACH . network-unreachable-error)
+    (:WSAENETDOWN . network-down-error)
+    (:WSAENETRESET . network-reset-error)
+    (:WSAESHUTDOWN . already-shutdown-error)
+    (:WSAETIMEDOUT . timeout-error)
+    (:WSAEHOSTDOWN . host-down-error)
+    (:WSAEHOSTUNREACH . host-unreachable-error)))
+
+(defun parse-errno (condition)
+  "Returns a number or keyword if it can parse what is within parens, else NIL"
+  (let ((s (princ-to-string condition)))
+    (let ((pos1 (position #\( s))
+          (pos2 (position #\) s)))
+      ;mac: number, linux: keyword
+      (ignore-errors
+        (if (digit-char-p (char s (1+ pos1)))
+          (parse-integer s :start (1+ pos1) :end pos2)
+          (let ((*package* (find-package "KEYWORD")))
+            (car (read-from-string s t nil :start pos1 :end (1+ pos2)))))))))
+
+(defun handle-condition (condition &optional (socket nil) (host-or-ip nil))
+  "Dispatch a usocket condition instead of a CLISP specific one, if we can."
+  (let ((errno
+          (cond
+            ;clisp 2.49+
+            ((typep condition (find-symbol "OS-STREAM-ERROR" "EXT"))
+             (parse-errno condition))
+            ;clisp 2.49
+            ((typep condition (find-symbol "SIMPLE-STREAM-ERROR" "SYSTEM"))
+             (car (simple-condition-format-arguments condition))))))
+    (when errno
+      (let ((error-keyword (if (keywordp errno) errno #+ffi(os:errno errno))))
+        (let ((usock-error (cdr (assoc error-keyword +clisp-error-map+))))
+          (when usock-error
+            (if (subtypep usock-error 'error)
+                (cond ((subtypep usock-error 'ns-error)
+                       (error usock-error :socket socket :host-or-ip host-or-ip))
+                      (t
+                       (error usock-error :socket socket)))
+                (cond ((subtypep usock-error 'ns-condition)
+                       (signal usock-error :socket socket :host-or-ip host-or-ip))
+                      (t
+                       (signal usock-error :socket socket))))))))))
+
+(defun socket-connect (host port &key (protocol :stream) (element-type 'character)
+                       timeout deadline (nodelay t nodelay-specified)
+                       local-host local-port)
+  (declare (ignorable timeout local-host local-port))
+  (when deadline (unsupported 'deadline 'socket-connect))
+  (when (and nodelay-specified 
+             (not (eq nodelay :if-supported)))
+    (unsupported 'nodelay 'socket-connect))
+  (case protocol
+    (:stream
+     (let ((socket)
+	   (hostname (host-to-hostname host)))
+       (with-mapped-conditions (socket host)
+	 (setf socket
+	       (if timeout
+		   (socket:socket-connect port hostname
+					  :element-type element-type
+					  :buffered t
+					  :timeout timeout)
+		   (socket:socket-connect port hostname
+					  :element-type element-type
+					  :buffered t))))
+       (make-stream-socket :socket socket
+			   :stream socket))) ;; the socket is a stream too
+    (:datagram
+     #+(or rawsock ffi)
+     (with-mapped-conditions (nil (or host local-host))
+       (socket-create-datagram (or local-port *auto-port*)
+                               :local-host (or local-host *wildcard-host*)
+                               :remote-host (and host (host-to-vector-quad host))
+                               :remote-port port))
+     #-(or rawsock ffi)
+     (unsupported '(protocol :datagram) 'socket-connect))))
+
+(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 (nil host)
+        (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 socket-shutdown ((usocket stream-usocket) direction)
+  (with-mapped-conditions (usocket)
+    (socket:socket-stream-shutdown (socket usocket) direction)))
+
+(defmethod get-local-name ((usocket stream-usocket))
+  (multiple-value-bind
+      (address port)
+      (socket:socket-stream-local (socket usocket) t)
+    (values (dotted-quad-to-vector-quad address) port)))
+
+(defmethod get-local-name ((usocket stream-server-usocket))
+  (values (get-local-address usocket)
+          (get-local-port usocket)))
+
+(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-local-address ((usocket stream-server-usocket))
+  (dotted-quad-to-vector-quad
+   (socket:socket-server-host (socket usocket))))
+
+(defmethod get-peer-address ((usocket usocket))
+  (nth-value 0 (get-peer-name usocket)))
+
+(defmethod get-local-port ((usocket usocket))
+  (nth-value 1 (get-local-name usocket)))
+
+(defmethod get-local-port ((usocket stream-server-usocket))
+  (socket:socket-server-port (socket usocket)))
+
+(defmethod get-peer-port ((usocket usocket))
+  (nth-value 1 (get-peer-name usocket)))
+
+(defun %setup-wait-list (wait-list)
+  (declare (ignore wait-list)))
+
+(defun %add-waiter (wait-list waiter)
+  ;; clisp's #'socket-status takes a list whose elts look either like,
+  ;; (socket-stream direction . x) or like,
+  ;; (socket-server . x)
+  ;; and it replaces the x's.
+  (push (cons (socket waiter)
+              (cond ((stream-usocket-p waiter) (cons NIL NIL))
+                    (t 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))
+      (dolist (x (wait-list-%wait wait-list))
+        (when (consp (cdr x)) ;it's a socket-stream not socket-server
+          (setf (cadr 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)))
+             (sockets (wait-list-waiters wait-list)))
+        (do* ((x (pop sockets) (pop sockets))
+              (y (cdr (last (pop status-list))) (cdr (last (pop status-list)))))
+             ((null x))
+          (when (member y '(T :INPUT :EOF))
+            (setf (state x) :READ)))
+        wait-list))))
+
+;;;
+;;; UDP/Datagram sockets (RAWSOCK version)
+;;;
+
+#+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 port sockaddr_in)
+    (ip-to-octet-buffer ip sockaddr_in :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)))))
+      (rawsock:bind sock (rawsock:make-sockaddr :inet lsock_addr))
+      (when rsock_addr
+        (rawsock:connect sock (rawsock:make-sockaddr :inet rsock_addr)))
+      (make-datagram-socket sock :connected-p (if rsock_addr t nil))))
+
+  (defmethod socket-receive ((socket datagram-usocket) buffer length &key)
+    "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 (rawsock:make-sockaddr :inet))
+           (real-length (or length +max-datagram-packet-size+))
+           (real-buffer (or buffer
+                            (make-array real-length
+                                        :element-type '(unsigned-byte 8)))))
+      (let ((rv (rawsock:recvfrom sock real-buffer sockaddr
+                                 :start 0 :end real-length))
+            (host 0) (port 0))
+        (unless (connected-p socket)
+          (let ((data (rawsock:sockaddr-data sockaddr)))
+            (setq host (ip-from-octet-buffer data :start 4)
+                  port (port-from-octet-buffer data :start 2))))
+        (values (if buffer real-buffer (subseq real-buffer 0 rv))
+                rv
+                host
+                port))))
+
+  (defmethod socket-send ((socket datagram-usocket) buffer size &key host port (offset 0))
+    "Returns the number of octets sent."
+    (let* ((sock (socket socket))
+           (sockaddr (when (and host port)
+                       (rawsock:make-sockaddr :inet
+                                              (fill-sockaddr_in
+                                               (make-sockaddr_in)
+                                               (host-byte-order host)
+                                               port))))
+           (real-size (min size +max-datagram-packet-size+))
+           (real-buffer (if (typep buffer '(simple-array (unsigned-byte 8) (*)))
+                            buffer
+                          (make-array real-size
+                                      :element-type '(unsigned-byte 8)
+                                      :initial-contents (subseq buffer 0 real-size))))
+           (rv (if (and host port)
+                   (rawsock:sendto sock real-buffer sockaddr
+                                   :start offset
+                                   :end (+ offset real-size))
+                   (rawsock:send sock real-buffer
+                                 :start offset
+                                 :end (+ offset real-size)))))
+      rv))
+
+  (defmethod socket-close ((usocket datagram-usocket))
+    (rawsock:sock-close (socket usocket)))
+
+  (declaim (inline get-socket-name))
+  (defun get-socket-name (socket function)
+    (let ((sockaddr (rawsock:make-sockaddr :inet (make-sockaddr_in))))
+      (funcall function socket sockaddr)
+      (let ((data (rawsock:sockaddr-data sockaddr)))
+        (values (hbo-to-vector-quad (ip-from-octet-buffer data :start 2))
+                (port-from-octet-buffer data :start 0)))))
+
+  (defmethod get-local-name ((usocket datagram-usocket))
+    (get-socket-name (socket usocket) 'rawsock:getsockname))
+
+  (defmethod get-peer-name ((usocket datagram-usocket))
+    (get-socket-name (socket usocket) 'rawsock:getpeername))
+
+) ; progn
+
+;;;
+;;; UDP/Datagram sockets (FFI version)
+;;;
+
+#+(and ffi (not rawsock))
+(progn
+  ;; C primitive types
+  (ffi:def-c-type socklen_t ffi:uint32)
+
+  ;; C structures
+  (ffi:def-c-struct sockaddr
+    #+macos (sa_len ffi:uint8)
+    (sa_family  #-macos ffi:ushort
+		#+macos ffi:uint8)
+    (sa_data    (ffi:c-array ffi:char 14)))
+
+  (ffi:def-c-struct sockaddr_in
+    #+macos (sin_len ffi:uint8)
+    (sin_family #-macos ffi:short
+		#+macos ffi:uint8)
+    (sin_port   #-macos ffi:ushort
+		#+macos ffi:uint16)
+    (sin_addr   ffi:uint32)
+    (sin_zero   (ffi:c-array ffi:char 8)))
+
+  (ffi:def-c-struct timeval
+    (tv_sec     ffi:long)
+    (tv_usec    ffi:long))
+
+  ;; foreign functions
+  (ffi:def-call-out %sendto (:name "sendto")
+    (:arguments (socket ffi:int)
+		(buffer ffi:c-pointer)
+		(length ffi:int)
+		(flags ffi:int)
+		(address (ffi:c-ptr sockaddr))
+		(address-len ffi:int))
+    #+win32 (:library "WS2_32")
+    #-win32 (:library :default)
+    (:language #-win32 :stdc
+	       #+win32 :stdc-stdcall)
+    (:return-type ffi:int))
+
+  (ffi:def-call-out %send (:name "send")
+    (:arguments (socket ffi:int)
+		(buffer ffi:c-pointer)
+		(length ffi:int)
+		(flags ffi:int))
+    #+win32 (:library "WS2_32")
+    #-win32 (:library :default)
+    (:language #-win32 :stdc
+	       #+win32 :stdc-stdcall)
+    (:return-type ffi:int))
+
+  (ffi:def-call-out %recvfrom (:name "recvfrom")
+    (:arguments (socket ffi:int)
+		(buffer ffi:c-pointer)
+		(length ffi:int)
+		(flags ffi:int)
+		(address (ffi:c-ptr sockaddr) :in-out)
+		(address-len (ffi:c-ptr ffi:int) :in-out))
+    #+win32 (:library "WS2_32")
+    #-win32 (:library :default)
+    (:language #-win32 :stdc
+	       #+win32 :stdc-stdcall)
+    (:return-type ffi:int))
+
+  (ffi:def-call-out %socket (:name "socket")
+    (:arguments (family ffi:int)
+		(type ffi:int)
+		(protocol ffi:int))
+    #+win32 (:library "WS2_32")
+    #-win32 (:library :default)
+    (:language #-win32 :stdc
+	       #+win32 :stdc-stdcall)
+    (:return-type ffi:int))
+
+  (ffi:def-call-out %connect (:name "connect")
+    (:arguments (socket ffi:int)
+		(address (ffi:c-ptr sockaddr) :in)
+		(address_len socklen_t))
+    #+win32 (:library "WS2_32")
+    #-win32 (:library :default)
+    (:language #-win32 :stdc
+	       #+win32 :stdc-stdcall)
+    (:return-type ffi:int))
+
+  (ffi:def-call-out %bind (:name "bind")
+    (:arguments (socket ffi:int)
+		(address (ffi:c-ptr sockaddr) :in)
+		(address_len socklen_t))
+    #+win32 (:library "WS2_32")
+    #-win32 (:library :default)
+    (:language #-win32 :stdc
+	       #+win32 :stdc-stdcall)
+    (:return-type ffi:int))
+
+  (ffi:def-call-out %close (:name #-win32 "close" #+win32 "closesocket")
+    (:arguments (socket ffi:int))
+    #+win32 (:library "WS2_32")
+    #-win32 (:library :default)
+    (:language #-win32 :stdc
+	       #+win32 :stdc-stdcall)
+    (:return-type ffi:int))
+
+  (ffi:def-call-out %getsockopt (:name "getsockopt")
+    (:arguments (sockfd ffi:int)
+		(level ffi:int)
+		(optname ffi:int)
+		(optval ffi:c-pointer)
+		(optlen (ffi:c-ptr socklen_t) :out))
+    #+win32 (:library "WS2_32")
+    #-win32 (:library :default)
+    (:language #-win32 :stdc
+	       #+win32 :stdc-stdcall)
+    (:return-type ffi:int))
+
+  (ffi:def-call-out %setsockopt (:name "setsockopt")
+    (:arguments (sockfd ffi:int)
+		(level ffi:int)
+		(optname ffi:int)
+		(optval ffi:c-pointer)
+		(optlen socklen_t))
+    #+win32 (:library "WS2_32")
+    #-win32 (:library :default)
+    (:language #-win32 :stdc
+	       #+win32 :stdc-stdcall)
+    (:return-type ffi:int))
+
+  (ffi:def-call-out %htonl (:name "htonl")
+    (:arguments (hostlong ffi:uint32))
+    #+win32 (:library "WS2_32")
+    #-win32 (:library :default)
+    (:language #-win32 :stdc
+	       #+win32 :stdc-stdcall)
+    (:return-type ffi:uint32))
+
+  (ffi:def-call-out %htons (:name "htons")
+    (:arguments (hostshort ffi:uint16))
+    #+win32 (:library "WS2_32")
+    #-win32 (:library :default)
+    (:language #-win32 :stdc
+	       #+win32 :stdc-stdcall)
+    (:return-type ffi:uint16))
+
+  (ffi:def-call-out %ntohl (:name "ntohl")
+    (:arguments (netlong ffi:uint32))
+    #+win32 (:library "WS2_32")
+    #-win32 (:library :default)
+    (:language #-win32 :stdc
+	       #+win32 :stdc-stdcall)
+    (:return-type ffi:uint32))
+
+  (ffi:def-call-out %ntohs (:name "ntohs")
+    (:arguments (netshort ffi:uint16))
+    #+win32 (:library "WS2_32")
+    #-win32 (:library :default)
+    (:language #-win32 :stdc
+	       #+win32 :stdc-stdcall)
+    (:return-type ffi:uint16))
+
+  (ffi:def-call-out %getsockname (:name "getsockname")
+    (:arguments (sockfd ffi:int)
+		(localaddr (ffi:c-ptr sockaddr) :in-out)
+		(addrlen (ffi:c-ptr socklen_t) :in-out))
+    #+win32 (:library "WS2_32")
+    #-win32 (:library :default)
+    (:language #-win32 :stdc
+	       #+win32 :stdc-stdcall)
+    (:return-type ffi:int))
+
+  (ffi:def-call-out %getpeername (:name "getpeername")
+    (:arguments (sockfd ffi:int)
+		(peeraddr (ffi:c-ptr sockaddr) :in-out)
+		(addrlen (ffi:c-ptr socklen_t) :in-out))
+    #+win32 (:library "WS2_32")
+    #-win32 (:library :default)
+    (:language #-win32 :stdc
+	       #+win32 :stdc-stdcall)
+    (:return-type ffi:int))
+
+  ;; socket constants
+  (defconstant +socket-af-inet+ 2)
+  (defconstant +socket-sock-dgram+ 2)
+  (defconstant +socket-ip-proto-udp+ 17)
+
+  (defconstant +sockopt-so-rcvtimeo+ #-linux #x1006 #+linux 20 "Socket receive timeout")
+
+  (defparameter *length-of-sockaddr_in* (ffi:sizeof 'sockaddr_in))
+
+  (declaim (inline fill-sockaddr_in))
+  (defun fill-sockaddr_in (sockaddr host port)
+    (let ((hbo (host-to-hbo host)))
+      (ffi:with-c-place (place sockaddr)
+	#+macos
+	(setf (ffi:slot place 'sin_len) *length-of-sockaddr_in*)
+	(setf (ffi:slot place 'sin_family) +socket-af-inet+
+	      (ffi:slot place 'sin_port) (%htons port)
+	      (ffi:slot place 'sin_addr) (%htonl hbo)))
+      sockaddr))
+
+  (defun socket-create-datagram (local-port
+				 &key (local-host *wildcard-host*)
+				      remote-host
+				      remote-port)
+    (let ((sock (%socket +socket-af-inet+ +socket-sock-dgram+ +socket-ip-proto-udp+))
+	  (lsock_addr (fill-sockaddr_in (ffi:allocate-shallow 'sockaddr_in)
+					local-host local-port))
+	  (rsock_addr (when remote-host
+			(fill-sockaddr_in (ffi:allocate-shallow 'sockaddr_in)
+					  remote-host (or remote-port local-port)))))
+      (unless (plusp sock)
+	(error "SOCKET-CREATE-DATAGRAM ERROR (socket): ~A" (os:errno)))
+      (unwind-protect
+	   (let ((rv (%bind sock (ffi:cast (ffi:foreign-value lsock_addr) 'sockaddr)
+			    *length-of-sockaddr_in*)))
+	     (unless (zerop rv)
+	       (error "SOCKET-CREATE-DATAGRAM ERROR (bind): ~A" (os:errno)))
+	     (when rsock_addr
+	       (let ((rv (%connect sock
+				   (ffi:cast (ffi:foreign-value rsock_addr) 'sockaddr)
+				   *length-of-sockaddr_in*)))
+		 (unless (zerop rv)
+		   (error "SOCKET-CREATE-DATAGRAM ERROR (connect): ~A" (os:errno))))))
+	(ffi:foreign-free lsock_addr)
+	(when remote-host
+	  (ffi:foreign-free rsock_addr)))
+      (make-datagram-socket sock :connected-p (if rsock_addr t nil))))
+
+  (defun finalize-datagram-usocket (object)
+    (when (datagram-usocket-p object)
+      (socket-close object)))
+
+  (defmethod initialize-instance :after ((usocket datagram-usocket) &key)
+    (setf (slot-value usocket 'recv-buffer)
+	  (ffi:allocate-shallow 'ffi:uint8 :count +max-datagram-packet-size+))
+    ;; finalize the object
+    (ext:finalize usocket 'finalize-datagram-usocket))
+
+  (defmethod socket-close ((usocket datagram-usocket))
+    (with-slots (recv-buffer socket) usocket
+      (ffi:foreign-free recv-buffer)
+      (zerop (%close socket))))
+
+  (defmethod socket-receive ((usocket datagram-usocket) buffer length &key)
+    (let ((remote-address (ffi:allocate-shallow 'sockaddr_in))
+	  (remote-address-length (ffi:allocate-shallow 'ffi:int))
+	  nbytes (host 0) (port 0))
+      (setf (ffi:foreign-value remote-address-length)
+	    *length-of-sockaddr_in*)
+      (unwind-protect
+	   (multiple-value-bind (n address address-length)
+	       (%recvfrom (socket usocket)
+			  (ffi:foreign-address (slot-value usocket 'recv-buffer))
+			  +max-datagram-packet-size+
+			  0 ; flags
+			  (ffi:cast (ffi:foreign-value remote-address) 'sockaddr)
+			  (ffi:foreign-value remote-address-length))
+	     (when (minusp n)
+	       (error "SOCKET-RECEIVE ERROR: ~A" (os:errno)))
+	     (setq nbytes n)
+	     (when (= address-length *length-of-sockaddr_in*)
+	       (let ((data (sockaddr-sa_data address)))
+		 (setq host (ip-from-octet-buffer data :start 2)
+		       port (port-from-octet-buffer data))))
+	     (cond ((plusp n)
+		    (let ((return-buffer (ffi:foreign-value (slot-value usocket 'recv-buffer))))
+		      (if buffer ; replace exist buffer of create new return buffer
+			  (let ((end-1 (min (or length (length buffer)) +max-datagram-packet-size+))
+				(end-2 (min n +max-datagram-packet-size+)))
+			    (replace buffer return-buffer :end1 end-1 :end2 end-2))
+			  (setq buffer (subseq return-buffer 0 (min n +max-datagram-packet-size+))))))
+		   ((zerop n))))
+	(ffi:foreign-free remote-address)
+	(ffi:foreign-free remote-address-length))
+      (values buffer nbytes host port)))
+
+  ;; implementation note: different from socket-receive, we know how many bytes we want to send everytime,
+  ;; so, a send buffer will not needed, and if there is a buffer, it's hard to fill its content like those
+  ;; in LispWorks. So, we allocate new foreign buffer for holding data (unknown sequence subtype) every time.
+  ;; 
+  ;; I don't know if anyone is watching my coding work, but I think this design is reasonable for CLISP.
+  (defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0))
+    (declare (type sequence buffer)
+	     (type (integer 0 *) size offset))
+    (let ((remote-address
+	   (when (and host port)
+	     (fill-sockaddr_in (ffi:allocate-shallow 'sockaddr_in) host port)))
+	  (send-buffer
+	   (ffi:allocate-deep 'ffi:uint8
+			      (if (zerop offset)
+				  buffer
+				  (subseq buffer offset (+ offset size)))
+			      :count size :read-only t))
+	  (real-size (min size +max-datagram-packet-size+))
+	  (nbytes 0))
+      (unwind-protect
+	   (let ((n (if remote-address
+			(%sendto (socket usocket)
+				 (ffi:foreign-address send-buffer)
+				 real-size
+				 0 ; flags
+				 (ffi:cast (ffi:foreign-value remote-address) 'sockaddr)
+				 *length-of-sockaddr_in*)
+			(%send (socket usocket)
+			       (ffi:foreign-address send-buffer)
+			       real-size
+			       0))))
+	     (cond ((plusp n)
+		    (setq nbytes n))
+		   ((zerop n)
+		    (setq nbytes n))
+		   (t (error "SOCKET-SEND ERROR: ~A" (os:errno)))))
+	(ffi:foreign-free send-buffer)
+	(when remote-address
+	  (ffi:foreign-free remote-address))
+	nbytes)))
+
+  (declaim (inline get-socket-name))
+  (defun get-socket-name (socket function)
+    (let ((address (ffi:allocate-shallow 'sockaddr_in))
+	  (address-length (ffi:allocate-shallow 'ffi:int))
+	  (host 0) (port 0))
+      (setf (ffi:foreign-value address-length) *length-of-sockaddr_in*)
+      (unwind-protect
+	   (multiple-value-bind (rv return-address return-address-length)
+	       (funcall function socket
+			(ffi:cast (ffi:foreign-value address) 'sockaddr)
+			(ffi:foreign-value address-length))
+	     (declare (ignore return-address-length))
+	     (if (zerop rv)
+		 (let ((data (sockaddr-sa_data return-address)))
+		   (setq host (ip-from-octet-buffer data :start 2)
+			 port (port-from-octet-buffer data)))
+		 (error "GET-SOCKET-NAME ERROR: ~A" (os:errno))))
+	(ffi:foreign-free address)
+	(ffi:foreign-free address-length))
+      (values (hbo-to-vector-quad host) port)))
+
+  (defmethod get-local-name ((usocket datagram-usocket))
+    (get-socket-name (socket usocket) '%getsockname))
+
+  (defmethod get-peer-name ((usocket datagram-usocket))
+    (get-socket-name (socket usocket) '%getpeername))
+
+) ; progn

sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/clozure.lisp

@@ -0,0 +1,73 @@
+;;;; See LICENSE for licensing information.
+
+;;;; Functions for CCL 1.11 (IPv6) only, see openmcl.lisp for rest of functions.
+
+(in-package :usocket)
+
+#+ipv6
+(defun socket-connect (host port &key (protocol :stream) element-type
+                                   timeout deadline nodelay
+                                   local-host local-port)
+  (when (eq nodelay :if-supported)
+    (setf nodelay t))
+  (with-mapped-conditions (nil host)
+    (let* ((remote (when (and host port)
+		     (openmcl-socket:resolve-address :host (host-to-hostname host)
+						     :port port
+						     :socket-type protocol)))
+	   (local  (when (and local-host local-port)
+		     (openmcl-socket:resolve-address :host (host-to-hostname local-host)
+						     :port local-port
+						     :socket-type protocol)))
+	   (mcl-sock (apply #'openmcl-socket:make-socket
+			    `(:type ,protocol
+			      ,@(when (or remote local)
+				  `(:address-family ,(openmcl-socket:socket-address-family (or remote local))))
+			      ,@(when remote
+				  `(:remote-address ,remote))
+			      ,@(when local
+				  `(:local-address ,local))
+			      :format ,(to-format element-type protocol)
+			      :external-format ,ccl:*default-external-format*
+			      :deadline ,deadline
+			      :nodelay ,nodelay
+			      :connect-timeout ,timeout
+			      :input-timeout ,timeout))))
+      (ecase protocol
+        (:stream
+         (make-stream-socket :stream mcl-sock :socket mcl-sock))
+        (:datagram
+         (make-datagram-socket mcl-sock :connected-p (and remote t)))))))
+
+#+ipv6
+(defun socket-listen (host port
+                      &key
+                        (reuse-address nil reuse-address-supplied-p)
+                        (reuseaddress (when reuse-address-supplied-p reuse-address))
+                        (backlog 5)
+                        (element-type 'character))
+  (let ((local-address (openmcl-socket:resolve-address :host (host-to-hostname host)
+						       :port port :connect :passive)))
+    (with-mapped-conditions (nil host)
+      (make-stream-server-socket
+        (openmcl-socket:make-socket :connect :passive
+				    :address-family (openmcl-socket:socket-address-family local-address)
+				    :local-address local-address
+				    :reuse-address reuseaddress
+				    :backlog backlog
+				    :format (to-format element-type :stream))
+	:element-type element-type))))
+
+#+ipv6
+(defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0))
+  (let* ((ccl-socket (socket usocket))
+	 (socket-keys (ccl::socket-keys ccl-socket)))
+    (with-mapped-conditions (usocket host)
+      (if (and host port)
+	  (openmcl-socket:send-to ccl-socket buffer size
+				  :remote-host (host-to-hostname host)
+				  :remote-port port
+				  :offset offset)
+	  (openmcl-socket:send-to ccl-socket buffer size
+				  :remote-address (getf socket-keys :remote-address)
+				  :offset offset)))))

sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/cmucl.lisp

@@ -0,0 +1,298 @@
+;;;; 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 host-or-ip)
+  (let ((usock-error
+         (cdr (assoc err +cmucl-error-map+ :test #'member))))
+    (if usock-error
+        (if (subtypep usock-error 'error)
+            (cond ((subtypep usock-error 'ns-error)
+                   (error usock-error :socket socket :host-or-ip host-or-ip))
+                  (t
+                   (error usock-error :socket socket)))
+            (cond ((subtypep usock-error 'ns-condition)
+                   (signal usock-error :socket socket :host-or-ip host-or-ip))
+                  (t
+                   (signal usock-error :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) (host-or-ip nil))
+  "Dispatch correct usocket condition."
+  (typecase condition
+    (ext::socket-error (cmucl-map-socket-error (ext::socket-errno condition)
+                                               :socket socket
+                                               :condition condition
+                                               :host-or-ip host-or-ip))))
+
+(defun socket-connect (host port &key (protocol :stream) (element-type 'character)
+                       timeout deadline (nodelay t nodelay-specified)
+		       (local-host nil local-host-p)
+		       (local-port nil local-port-p)
+		       &aux
+		       (local-bind-p (fboundp 'ext::bind-inet-socket)))
+  (when timeout (unsupported 'timeout 'socket-connect))
+  (when deadline (unsupported 'deadline 'socket-connect))
+  (when (and nodelay-specified 
+             (not (eq nodelay :if-supported)))
+    (unsupported 'nodelay 'socket-connect))
+  (when (and local-host-p (not local-bind-p))
+     (unsupported 'local-host 'socket-connect :minimum "Snapshot 2008-08 (19E)"))
+  (when (and local-port-p (not local-bind-p))
+     (unsupported 'local-port 'socket-connect :minimum "Snapshot 2008-08 (19E)"))
+
+  (let ((socket))
+    (ecase protocol
+      (:stream
+       (setf socket
+	     (let ((args (list (host-to-hbo host) port protocol)))
+	       (when (and local-bind-p (or local-host-p local-port-p))
+		 (nconc args (list :local-host (when local-host
+						 (host-to-hbo local-host))
+				   :local-port local-port)))
+	       (with-mapped-conditions (socket host)
+		 (apply #'ext:connect-to-inet-socket args))))
+       (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)))))
+      (:datagram
+       (setf socket
+	     (if (and host port)
+		 (let ((args (list (host-to-hbo host) port protocol)))
+		   (when (and local-bind-p (or local-host-p local-port-p))
+		     (nconc args (list :local-host (when local-host
+						     (host-to-hbo local-host))
+				       :local-port local-port)))
+		   (with-mapped-conditions (socket (or host local-host))
+		     (apply #'ext:connect-to-inet-socket args)))
+		 (if (or local-host-p local-port-p)
+		     (with-mapped-conditions (socket (or host local-host))
+		       (apply #'ext:create-inet-listener
+			      (nconc (list (or local-port 0) protocol)
+				     (when (and local-host-p
+						(ip/= local-host *wildcard-host*))
+				       (list :host (host-to-hbo local-host))))))
+		     (with-mapped-conditions (socket (or host local-host))
+		       (ext:create-inet-socket protocol)))))
+       (if socket
+	   (let ((usocket (make-datagram-socket socket :connected-p (and host port t))))
+	     (ext:finalize usocket #'(lambda () (when (%open-p usocket)
+						  (ext:close-socket socket))))
+	     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 (nil host)
+           (apply #'ext:create-inet-listener
+                  (nconc  (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 socket-close :after ((socket datagram-usocket))
+  (setf (%open-p socket) nil))
+
+#+unicode
+(defun %unix-send (fd buffer length flags)
+  (alien:alien-funcall
+   (alien:extern-alien "send"
+		       (function c-call:int
+				 c-call:int
+				 system:system-area-pointer
+				 c-call:int
+				 c-call:int))
+   fd
+   (system:vector-sap buffer)
+   length
+   flags))
+
+(defmethod socket-shutdown ((usocket usocket) direction)
+  (with-mapped-conditions (usocket)
+    (ext:inet-shutdown (socket usocket) (ecase direction
+                                          (:input ext:shut-rd)
+                                          (:output ext:shut-wr)))))
+
+(defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0)
+			&aux (real-buffer (if (zerop offset)
+					      buffer
+					      (subseq buffer offset (+ offset size)))))
+  (with-mapped-conditions (usocket host)
+    (if (and host port)
+	(ext:inet-sendto (socket usocket) real-buffer size (host-to-hbo host) port)
+	#-unicode
+	(unix:unix-send (socket usocket) real-buffer size 0)
+	#+unicode
+	(%unix-send (socket usocket) real-buffer size 0))))
+
+(defmethod socket-receive ((usocket datagram-usocket) buffer length &key)
+  (declare (values (simple-array (unsigned-byte 8) (*)) ; buffer
+		   (integer 0)                          ; size
+		   (unsigned-byte 32)                   ; host
+		   (unsigned-byte 16)))                 ; port
+  (let ((real-buffer (or buffer
+                         (make-array length :element-type '(unsigned-byte 8))))
+        (real-length (or length
+                         (length buffer))))
+    (multiple-value-bind (nbytes remote-host remote-port)
+        (with-mapped-conditions (usocket)
+          (ext:inet-recvfrom (socket usocket) real-buffer real-length))
+      (values real-buffer nbytes remote-host remote-port))))
+
+(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-condition)))))) ;; 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 address))))
+
+(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 name))))
+
+(defun get-host-name ()
+  (unix:unix-gethostname))
+
+(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 ()
+    (alien:with-alien ((rfds (alien:struct unix:fd-set)))
+       (unix:fd-zero 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 wait-list)))
+				    (alien:addr rfds) nil nil
+				    (when timeout secs) musecs)
+	   (declare (ignore err))
+           (if (<= 0 count)
+               ;; process the result...
+               (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
+		 )))))))

sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/ecl.lisp

@@ -0,0 +1,152 @@
+;;;; -*- Mode: Lisp -*-
+
+;;;; Foreign functions defined by ECL's DFFI, used for #+ecl-bytecmp only.
+;;;; See LICENSE for licensing information.
+
+(in-package :usocket)
+
+#+(and ecl-bytecmp windows)
+(eval-when (:load-toplevel :execute)
+  (ffi:load-foreign-library "ws2_32.dll" :module "ws2_32"))
+
+#+(and ecl-bytecmp windows)
+(progn
+  (ffi:def-function ("gethostname" c-gethostname)
+    ((name (* :unsigned-char))
+     (len :int))
+    :returning :int
+    :module "ws2_32")
+
+  (defun get-host-name ()
+    "Returns the hostname"
+    (ffi:with-foreign-object (name '(:array :unsigned-char 256))
+      (when (zerop (c-gethostname (ffi:char-array-to-pointer name) 256))
+        (ffi:convert-from-foreign-string name))))
+
+  (ffi:def-foreign-type ws-socket :unsigned-int)
+  (ffi:def-foreign-type ws-dword :unsigned-long)
+  (ffi:def-foreign-type ws-event :unsigned-int)
+
+  (ffi:def-struct wsa-network-events
+    (network-events :long)
+    (error-code (:array :int 10)))
+
+  (ffi:def-function ("WSACreateEvent" wsa-event-create)
+    ()
+    :returning ws-event
+    :module "ws2_32")
+
+  (ffi:def-function ("WSACloseEvent" c-wsa-event-close)
+    ((event-object ws-event))
+    :returning :int
+    :module "ws2_32")
+
+  (defun wsa-event-close (ws-event)
+    (not (zerop (c-wsa-event-close ws-event))))
+
+  (ffi:def-function ("WSAEnumNetworkEvents" wsa-enum-network-events)
+    ((socket ws-socket)
+     (event-object ws-event)
+     (network-events (* wsa-network-events)))
+    :returning :int
+    :module "ws2_32")
+
+  (ffi:def-function ("WSAEventSelect" wsa-event-select)
+    ((socket ws-socket)
+     (event-object ws-event)
+     (network-events :long))
+    :returning :int
+    :module "ws2_32")
+
+  (ffi:def-function ("WSAWaitForMultipleEvents" c-wsa-wait-for-multiple-events)
+    ((number-of-events ws-dword)
+     (events (* ws-event))
+     (wait-all-p :int)
+     (timeout ws-dword)
+     (alertable-p :int))
+    :returning ws-dword
+    :module "ws2_32")
+
+  (defun wsa-wait-for-multiple-events (number-of-events events wait-all-p timeout alertable-p)
+    (c-wsa-wait-for-multiple-events number-of-events
+                                    events
+                                    (if wait-all-p -1 0)
+                                    timeout
+                                    (if alertable-p -1 0)))
+
+  (ffi:def-function ("ioctlsocket" wsa-ioctlsocket)
+    ((socket ws-socket)
+     (cmd :long)
+     (argp (* :unsigned-long)))
+    :returning :int
+    :module "ws2_32")
+
+  (ffi:def-function ("WSAGetLastError" wsa-get-last-error)
+    ()
+    :returning :int
+    :module "ws2_32")
+
+  (defun maybe-wsa-error (rv &optional socket)
+    (unless (zerop rv)
+      (raise-usock-err (wsa-get-last-error) socket)))
+
+  (defun bytes-available-for-read (socket)
+    (ffi:with-foreign-object (int-ptr :unsigned-long)
+      (maybe-wsa-error (wsa-ioctlsocket (socket-handle socket) fionread int-ptr)
+                       socket)
+      (let ((int (ffi:deref-pointer int-ptr :unsigned-long)))
+        (prog1 int
+          (when (plusp int)
+            (setf (state socket) :read))))))
+
+  (defun map-network-events (func network-events)
+    (let ((event-map (ffi:get-slot-value network-events 'wsa-network-events 'network-events))
+          (error-array (ffi:get-slot-pointer network-events 'wsa-network-events 'error-code)))
+      (unless (zerop event-map)
+        (dotimes (i fd-max-events)
+          (unless (zerop (ldb (byte 1 i) event-map))
+            (funcall func (ffi:deref-array error-array '(:array :int 10) i)))))))
+
+  (defun update-ready-and-state-slots (sockets)
+    (dolist (socket sockets)
+      (if (%ready-p socket)
+          (progn
+            (setf (state socket) :READ))
+        (ffi:with-foreign-object (network-events 'wsa-network-events)
+          (let ((rv (wsa-enum-network-events (socket-handle socket) 0 network-events)))
+            (if (zerop rv)
+                (map-network-events
+                 #'(lambda (err-code)
+                     (if (zerop err-code)
+                         (progn
+                           (setf (state socket) :READ)
+                           (when (stream-server-usocket-p socket)
+                             (setf (%ready-p socket) t)))
+                       (raise-usock-err err-code socket)))
+                 network-events)
+              (maybe-wsa-error rv socket)))))))
+
+  (defun os-wait-list-%wait (wait-list)
+    (ffi:deref-pointer (wait-list-%wait wait-list) 'ws-event))
+
+  (defun (setf os-wait-list-%wait) (value wait-list)
+    (setf (ffi:deref-pointer (wait-list-%wait wait-list) 'ws-event) value))
+
+  (defun free-wait-list (wl)
+    (when (wait-list-p wl)
+      (unless (null (wait-list-%wait wl))
+        (wsa-event-close (os-wait-list-%wait wl))
+        (ffi:free-foreign-object (wait-list-%wait wl))
+        (setf (wait-list-%wait wl) nil))))
+
+  (defun %setup-wait-list (wait-list)
+    (setf (wait-list-%wait wait-list)
+          (ffi:allocate-foreign-object 'ws-event))
+    (setf (os-wait-list-%wait wait-list)
+          (wsa-event-create))
+    (ext:set-finalizer wait-list #'free-wait-list))
+
+  (defun os-socket-handle (usocket)
+    (socket-handle usocket))
+
+) ; #+(and ecl-bytecmp windows)

sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/genera.lisp

@@ -0,0 +1,264 @@
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: USOCKET; Base: 10 -*-
+
+
+;;;; See LICENSE for licensing information.
+
+(in-package :usocket)
+
+(defclass genera-socket ()
+    ((foreign-address :initform 0 :initarg :foreign-address :accessor gs-foreign-address)
+     (foreign-port :initform 0 :initarg :foreign-port :accessor gs-foreign-port)
+     (local-address :initform 0 :initarg :local-address :accessor gs-local-address)
+     (local-port :initform 0 :initarg :local-port :accessor gs-local-port))
+  )
+
+(defclass genera-stream-socket (genera-socket)
+    ((stream :initform nil :initarg :stream :accessor gs-stream))
+  )
+
+(defclass genera-stream-server-socket (genera-socket)
+    ((backlog :initform nil :initarg :backlog :accessor gs-backlog)
+     (element-type :initform nil :initarg :element-type :accessor gs-element-type)
+     (pending-connections :initform nil :accessor gs-pending-connections))
+  )
+
+(defclass genera-datagram-socket (genera-socket)
+    ((connection :initform nil :initarg :connection :accessor gs-connection))
+  )
+
+(defun host-to-host-object (host)
+  (let ((host (host-to-hostname host)))
+    (cond ((string-equal host "localhost")
+	   net:*local-host*)
+	  ((ip-address-string-p host)
+	   (let ((quad (dotted-quad-to-vector-quad host)))
+	     ;;---*** NOTE: This test is temporary until we have a loopback interface
+	     (if (= (aref quad 0) 127)
+		 net:*local-host*
+		 (net:parse-host (format nil "INTERNET|~A" host)))))
+	  (t
+	   (net:parse-host host)))))
+
+(defun element-type-to-format (element-type protocol)
+  (cond ((null element-type)
+	 (ecase protocol
+	   (:stream :text)
+	   (:datagram :binary)))
+	((subtypep element-type 'character)
+	 :text)
+	(t :binary)))
+
+(defun handle-condition (condition &optional (socket nil) (host-or-ip nil))
+  (typecase condition
+    ;;---*** TODO: Add additional conditions as appropriate
+    (sys:connection-refused
+      (error 'connection-refused-error :socket socket))
+    ((or tcp::tcp-destination-unreachable-during-connection tcp::udp-destination-unreachable)
+      (error 'host-unreachable-error :socket socket))
+    (sys:host-not-responding-during-connection
+      (error 'timeout-error :socket socket))
+    (sys:unknown-host-name
+      (error 'ns-host-not-found-error :host-or-ip host-or-ip))
+    (sys:network-error
+      (error 'unknown-error :socket socket :real-error condition :errno -1))))
+
+(defun socket-connect (host port &key (protocol :stream) element-type
+			    timeout deadline (nodelay nil nodelay-p)
+			    local-host local-port)
+  (declare (ignore local-host))
+  (when deadline
+    (unsupported 'deadline 'socket-connect))
+  (when (and nodelay-p (not (eq nodelay :if-supported)))
+    (unsupported 'nodelay 'socket-connect))
+  (with-mapped-conditions (nil host)
+    (ecase protocol
+      (:stream
+	(let* ((host-object (host-to-host-object host))
+	       (format (element-type-to-format element-type protocol))
+	       (characters (eq format :text))
+	       (timeout (if timeout
+			    (* 60 timeout)
+			    tcp:*tcp-connect-timeout*))
+	       (stream (tcp:open-tcp-stream host-object port local-port
+					    :characters characters
+					    :ascii-translation characters
+					    :timeout timeout))
+	       (gs (make-instance 'genera-stream-socket
+				  :stream stream)))
+	  (setf (gs-foreign-address gs) (scl:send stream :foreign-address))
+	  (setf (gs-foreign-port gs) (scl:send stream :foreign-port))
+	  (setf (gs-local-address gs) (scl:send stream :local-address))
+	  (setf (gs-local-port gs) (scl:send stream :local-port))
+	  (make-stream-socket :socket gs :stream stream)))
+      (:datagram
+	;;---*** TODO
+	(unsupported 'datagram 'socket-connect)))))
+
+(defmethod socket-close ((usocket usocket))
+  (with-mapped-conditions (usocket)
+    (socket-close (socket usocket))))
+
+(defmethod socket-close ((socket genera-stream-socket))
+  (with-slots (stream) socket
+    (when stream
+      (scl:send (shiftf stream nil) :close nil))))
+
+(defmethod socket-close ((socket genera-stream-server-socket))
+  (with-slots (local-port pending-connections) socket
+    (when local-port
+      (tcp:remove-tcp-port-listener local-port))
+    (dolist (tcb pending-connections)
+      (tcp::reject-tcb tcb))))
+
+(defmethod socket-close ((socket genera-datagram-socket))
+  (with-slots (connection) socket
+    (when connection
+      (scl:send (shiftf connection nil) :close nil))
+    ;;---*** TODO: listening?
+    ))
+
+;;; Cribbed from TCP::MAKE-TCB
+(defun gensym-tcp-port ()
+  (loop as number = (incf tcp::*last-gensym-port-number*) then tcp::*last-gensym-port-number*
+	do (cond ((loop for existing-tcb in tcp::*tcb-list*
+			thereis (= number (tcp::tcb-local-port existing-tcb))))
+		 ((and (<= #.(expt 2 10) number) (< number #.(expt 2 16)))
+		  (return number))
+		 (t
+		  (setq tcp::*last-gensym-port-number* #.(expt 2 10))))))
+
+(defun socket-listen (host port &key (reuse-address nil reuse-address-p)
+				     (reuseaddress nil reuseaddress-p)
+				     (backlog 5) (element-type 'character))
+  (let ((host-object (host-to-host-object host))
+	(port (if (zerop port) (gensym-tcp-port) port))
+	(reuse-address (cond (reuse-address-p reuse-address)
+			     (reuseaddress-p reuseaddress)
+			     (t nil))))
+    (when (<= port 1024)
+      ;; Don't allow listening on "privileged" ports to mimic Unix/Linux semantics
+      (error 'operation-not-permitted-error :socket nil))
+    (when (tcp:tcp-port-protocol-name port)
+      ;; Can't replace a Genera server
+      (error 'address-in-use-error :socket nil))
+    (when (tcp:tcp-port-listener port)
+      (unless reuse-address
+	(error 'address-in-use-error :socket nil)))
+    (let ((gs (make-instance 'genera-stream-server-socket
+			     :backlog backlog
+			     :element-type element-type)))
+      (setf (gs-local-address gs)
+	    (loop for (network address) in (scl:send host-object :network-addresses)
+		  when (typep network 'tcp:internet-network)
+		    return address))
+      (setf (gs-local-port gs) port)
+      (flet ((add-to-queue (tcb)
+	       (cond ((and (not (zerop (gs-local-address gs)))
+			   (not (= (gs-local-address gs) (tcp::tcb-local-address tcb))))
+		      ;; Reject if not destined for the proper address
+		      (tcp::reject-tcb tcb))
+		     ((<= (length (gs-pending-connections gs)) (gs-backlog gs))
+		      (tcp::accept-tcb tcb)
+		      (tcp::tcb-travel-through-states tcb "Accept" nil :listen :syn-received)
+		      (setf (gs-pending-connections gs)
+			    (append (gs-pending-connections gs) (list tcb))))
+		      (t
+			;; Reject if backlog is full
+			(tcp::reject-tcb tcb)))))
+	(tcp:add-tcp-port-listener port #'add-to-queue))
+      (make-stream-server-socket gs :element-type element-type))))
+
+(defmethod socket-accept ((socket stream-server-usocket) &key element-type)
+  (with-slots (pending-connections) (socket socket)
+    (loop
+      (process:process-block "Wait for connection" #'(lambda ()
+						       (not (null pending-connections))))
+      (let ((tcb (pop pending-connections)))
+	(when tcb
+	  (let* ((format (element-type-to-format (or element-type (element-type socket))
+						 :stream))
+		 (characters (eq format :text))
+		 (stream (tcp::make-tcp-stream tcb
+					       :characters characters
+					       :ascii-translation characters))
+		 (gs (make-instance 'genera-stream-socket
+				    :stream stream)))
+	    (setf (gs-foreign-address gs) (scl:send stream :foreign-address))
+	    (setf (gs-foreign-port gs) (scl:send stream :foreign-port))
+	    (setf (gs-local-address gs) (scl:send stream :local-address))
+	    (setf (gs-local-port gs) (scl:send stream :local-port))
+	    (return (make-stream-socket :socket gs :stream stream))))))))
+
+(defmethod get-local-address ((usocket usocket))
+  (hbo-to-vector-quad (gs-local-address (socket usocket))))
+
+(defmethod get-peer-address ((usocket stream-usocket))
+  (hbo-to-vector-quad (gs-foreign-address (socket usocket))))
+
+(defmethod get-local-port ((usocket usocket))
+  (gs-local-port (socket usocket)))
+
+(defmethod get-peer-port ((usocket stream-usocket))
+  (gs-foreign-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)))
+
+(defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0))
+  ;;---*** TODO
+  (unsupported 'datagram 'socket-send))
+
+(defmethod socket-receive ((socket datagram-usocket) buffer length &key)
+  ;;---*** TODO
+  (unsupported 'datagram 'socket-receive))
+
+(defun get-host-by-address (address)
+  ) ;; TODO
+
+(defun get-hosts-by-name (name)
+  (with-mapped-conditions (nil name)
+    (let ((host-object (host-to-host-object name)))
+      (loop for (network address) in (scl:send host-object :network-addresses)
+	    when (typep network 'tcp:internet-network)
+	      collect (hbo-to-vector-quad address)))))
+
+(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 ()
+    (process:process-block-with-timeout timeout "Wait for input"
+      #'(lambda (wait-list)
+	  (let ((ready-sockets nil))
+	    (dolist (waiter (wait-list-waiters wait-list) ready-sockets)
+	      (setf (state waiter)
+		    (cond ((stream-usocket-p waiter)
+			   (if (listen (socket-stream waiter))
+			       :read
+			       nil))
+			  ((datagram-usocket-p waiter)
+			   (let ((connection (gs-connection (socket waiter))))
+			     (if (and connection
+				      (not (scl:send connection :connection-pending-p)))
+				 :read
+				 nil)))
+			  ((stream-server-usocket-p waiter)
+			   (if (gs-pending-connections (socket waiter))
+			       :read
+			       nil))))
+	      (when (not (null (state waiter)))
+		(setf ready-sockets t)))))
+      wait-list)
+    wait-list))
+

sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/iolib.lisp

@@ -0,0 +1,290 @@
+;;;; See LICENSE for licensing information.
+
+(in-package :usocket)
+
+(defparameter *backend* :iolib)
+
+(eval-when (:load-toplevel :execute)
+  (shadowing-import 'iolib/sockets:socket-option)
+  (export 'socket-option))
+
+(defparameter +iolib-error-map+
+ `((iolib/sockets:socket-address-in-use-error        . address-in-use-error)
+   (iolib/sockets:socket-address-family-not-supported-error . socket-type-not-supported-error)
+   (iolib/sockets:socket-address-not-available-error . address-not-available-error)
+   (iolib/sockets:socket-network-down-error          . network-down-error)
+   (iolib/sockets:socket-network-reset-error         . network-reset-error)
+   (iolib/sockets:socket-network-unreachable-error   . network-unreachable-error)
+   ;; (iolib/sockets:socket-no-network-error . ?)
+   (iolib/sockets:socket-connection-aborted-error    . connection-aborted-error)
+   (iolib/sockets:socket-connection-reset-error      . connection-reset-error)
+   (iolib/sockets:socket-connection-refused-error    . connection-refused-error)
+   (iolib/sockets:socket-connection-timeout-error    . timeout-error)
+   ;; (iolib/sockets:socket-connection-in-progress-error . ?)
+   (iolib/sockets:socket-endpoint-shutdown-error     . network-down-error)
+   (iolib/sockets:socket-no-buffer-space-error       . no-buffers-error)
+   (iolib/sockets:socket-host-down-error             . host-down-error)
+   (iolib/sockets:socket-host-unreachable-error      . host-unreachable-error)
+   ;; (iolib/sockets:socket-already-connected-error . ?)
+   (iolib/sockets:socket-not-connected-error         . connection-refused-error)
+   (iolib/sockets:socket-option-not-supported-error  . operation-not-permitted-error)
+   (iolib/syscalls:eacces                            . operation-not-permitted-error)
+   (iolib/sockets:socket-operation-not-supported-error . operation-not-supported-error)
+   (iolib/sockets:unknown-protocol                   . protocol-not-supported-error)
+   ;; (iolib/sockets:unknown-interface . ?)
+   (iolib/sockets:unknown-service                    . protocol-not-supported-error)
+   (iolib/sockets:socket-error                       . socket-error)
+
+   ;; Nameservice errors (src/sockets/dns/conditions.lisp)
+   (iolib/sockets:resolver-error                     . ns-error)
+   (iolib/sockets:resolver-fail-error                . ns-host-not-found-error)
+   (iolib/sockets:resolver-again-error               . ns-try-again-condition)
+   (iolib/sockets:resolver-no-name-error             . ns-no-recovery-error)
+   (iolib/sockets:resolver-unknown-error             . ns-unknown-error)
+   ))
+
+;; IOlib uses (SIMPLE-ARRAY (UNSIGNED-BYTE 16) (8)) to represent IPv6 addresses,
+;; while USOCKET shared code uses (SIMPLE-ARRAY (UNSIGNED-BYTE 8) (16)). Here we do the
+;; conversion.
+(defun iolib-vector-to-vector-quad (host)
+  (etypecase host
+    ((or (vector t 4)  ; IPv4
+         (array (unsigned-byte 8) (4)))
+     host)
+    ((or (vector t 8) ; IPv6
+         (array (unsigned-byte 16) (8)))
+      (loop with vector = (make-array 16 :element-type '(unsigned-byte 8))
+            for i below 16 by 2
+            for word = (aref host (/ i 2))
+            do (setf (aref vector i) (ldb (byte 8 8) word)
+                     (aref vector (1+ i)) (ldb (byte 8 0) word))
+            finally (return vector)))))
+
+(defun handle-condition (condition &optional (socket nil) (host-or-ip nil))
+  "Dispatch correct usocket condition."
+  (let* ((usock-error (cdr (assoc (type-of condition) +iolib-error-map+)))
+	 (usock-error (if (functionp usock-error)
+			  (funcall usock-error condition)
+                          usock-error)))
+    (if usock-error
+        (if (typep usock-error 'socket-error)
+            (cond ((subtypep usock-error 'ns-error)
+                  (error usock-error :socket socket :host-or-ip host-or-ip))
+                 (t
+                  (error usock-error :socket socket)))
+            (cond ((subtypep usock-error 'ns-condition)
+                  (signal usock-error :socket socket :host-or-ip host-or-ip))
+                 (t
+                  (signal usock-error :socket socket))))
+        (error 'unknown-error
+               :real-error condition
+               :socket socket))))
+
+(defun ipv6-address-p (host)
+  (iolib/sockets:ipv6-address-p (iolib/sockets:ensure-hostname host)))
+
+(defun socket-connect (host port &key (protocol :stream) (element-type 'character)
+                       timeout deadline
+                       (nodelay t) ;; nodelay == t is the ACL default
+                       local-host local-port)
+  (declare (ignore element-type deadline nodelay))
+  (with-mapped-conditions (nil host)
+    (let* ((remote (when (and host port) (iolib/sockets:ensure-hostname host)))
+	   (local  (when (and local-host local-port)
+		     (iolib/sockets:ensure-hostname local-host)))
+	   (ipv6-p (or (and remote (ipv6-address-p remote)
+		       (and local  (ipv6-address-p local)))))
+	   (socket (apply #'iolib/sockets:make-socket
+			  `(:type ,protocol
+			    :address-family :internet
+			    :ipv6 ,ipv6-p
+			    :connect ,(cond ((eq protocol :stream) :active)
+					    ((and host port)       :active)
+					    (t                     :passive))
+			    ,@(when local
+				`(:local-host ,local :local-port ,local-port))
+			    :nodelay nodelay))))
+      (when remote
+	(apply #'iolib/sockets:connect
+	       `(,socket ,remote :port ,port ,@(when timeout `(:wait ,timeout))))
+	(unless (iolib/sockets:socket-connected-p socket)
+	  (close socket)
+	  (error 'iolib/sockets:socket-error)))
+      (ecase protocol
+	(:stream
+	 (make-stream-socket :stream socket :socket socket))
+	(:datagram
+	 (make-datagram-socket socket :connected-p (and remote t)))))))
+
+(defmethod socket-close ((usocket usocket))
+  (close (socket usocket)))
+
+(defmethod socket-shutdown ((usocket stream-usocket) direction)
+  (with-mapped-conditions ()
+    (case direction
+      (:input
+       (iolib/sockets:shutdown (socket usocket) :read t))
+      (:output
+       (iolib/sockets:shutdown (socket usocket) :write t))
+      (t ; :io by default
+       (iolib/sockets:shutdown (socket usocket) :read t :write t)))))
+
+(defun socket-listen (host port
+                           &key reuseaddress reuse-address
+                           (backlog 5)
+                           (element-type 'character))
+  (declare (ignore element-type))
+  (with-mapped-conditions (nil host)
+    (make-stream-server-socket
+      (iolib/sockets:make-socket :connect :passive
+				 :address-family :internet
+				 :local-host (iolib/sockets:ensure-hostname host)
+				 :local-port port
+				 :backlog backlog
+				 :reuse-address (or reuse-address reuseaddress)))))
+
+(defmethod socket-accept ((usocket stream-server-usocket) &key element-type)
+  (declare (ignore element-type))
+  (with-mapped-conditions (usocket)
+    (let ((socket (iolib/sockets:accept-connection (socket usocket))))
+      (make-stream-socket :socket socket :stream socket))))
+
+(defmethod get-local-address ((usocket usocket))
+  (iolib-vector-to-vector-quad
+   (iolib/sockets:address-to-vector (iolib/sockets:local-host (socket usocket)))))
+
+(defmethod get-peer-address ((usocket stream-usocket))
+  (iolib-vector-to-vector-quad
+   (iolib/sockets:address-to-vector (iolib/sockets:remote-host (socket usocket)))))
+
+(defmethod get-local-port ((usocket usocket))
+  (iolib/sockets:local-port (socket usocket)))
+
+(defmethod get-peer-port ((usocket stream-usocket))
+  (iolib/sockets: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)))
+
+(defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0))
+  (apply #'iolib/sockets:send-to
+	 `(,(socket usocket) ,buffer :start ,offset :end ,(+ offset size)
+			     ,@(when (and host port)
+				 `(:remote-host ,(iolib/sockets:ensure-hostname host)
+				   :remote-port ,port)))))
+
+(defmethod socket-receive ((usocket datagram-usocket) buffer length &key start end)
+  (multiple-value-bind (buffer size host port)
+      (iolib/sockets:receive-from (socket usocket)
+				  :buffer buffer :size length :start start :end end)
+    (values buffer size (iolib-vector-to-vector-quad host) port)))
+
+(defun get-hosts-by-name (name)
+  (with-mapped-conditions (nil name)
+    (multiple-value-bind (address more-addresses)
+        (iolib/sockets:lookup-hostname name :ipv6 iolib/sockets:*ipv6*)
+      (mapcar #'(lambda (x) (iolib-vector-to-vector-quad
+                             (iolib/sockets:address-name x)))
+              (cons address more-addresses)))))
+
+(defun get-host-by-address (address)
+  (with-mapped-conditions (nil address)
+    nil)) ;; TODO
+
+(defvar *event-base*
+  (make-instance 'iolib/multiplex:event-base))
+
+(defun %setup-wait-list (wait-list)
+  (setf (wait-list-%wait wait-list)
+	(or *event-base*
+	    ;; iolib/multiplex:*default-multiplexer* is used here
+	    (make-instance 'iolib/multiplex:event-base))))
+
+(defun make-usocket-read-handler (usocket disconnector)
+  (lambda (fd event exception)
+    (declare (ignore fd event exception))
+    (handler-case
+	(if (eq (state usocket) :write)
+	    (setf (state usocket) :read-write)
+	  (setf (state usocket) :read))
+      (end-of-file ()
+	(funcall disconnector :close)))))
+
+(defun make-usocket-write-handler (usocket disconnector)
+  (lambda (fd event exception)
+    (declare (ignore fd event exception))
+    (handler-case
+	(if (eq (state usocket) :read)
+	    (setf (state usocket) :read-write)
+	  (setf (state usocket) :write))
+      (end-of-file ()
+	(funcall disconnector :close))
+      (iolib/streams:hangup ()
+	(funcall disconnector :close)))))
+
+(defun make-usocket-error-handler (usocket disconnector)
+  (lambda (fd event exception)
+    (declare (ignore fd event exception))
+    (handler-case
+	(setf (state usocket) nil)
+      (end-of-file ()
+	(funcall disconnector :close))
+      (iolib/streams:hangup ()
+	(funcall disconnector :close)))))
+
+(defun make-usocket-disconnector (event-base usocket)
+  (declare (ignore event-base))
+  (lambda (&rest events)
+    (let ((socket (socket usocket)))
+      ;; if were asked to close the socket, we do so here
+      (when (member :close events)
+	(close socket :abort t)))))
+
+(defun %add-waiter (wait-list waiter)
+  (let ((event-base (wait-list-%wait wait-list))
+	(fd (iolib/sockets:socket-os-fd (socket waiter))))
+    ;; reset socket state
+    (setf (state waiter) nil)
+    ;; set read handler
+    (unless (iolib/multiplex::fd-monitored-p event-base fd :read)
+      (iolib/multiplex:set-io-handler
+        event-base fd :read
+	(make-usocket-read-handler waiter
+				   (make-usocket-disconnector event-base waiter))))
+    ;; set write handler
+    #+ignore
+    (unless (iolib/multiplex::fd-monitored-p event-base fd :write)
+      (iolib/multiplex:set-io-handler
+        event-base fd :write
+	(make-usocket-write-handler waiter
+				    (make-usocket-disconnector event-base waiter))))
+    ;; set error handler
+    (unless (iolib/multiplex::fd-has-error-handler-p event-base fd)
+      (iolib/multiplex:set-error-handler
+        event-base fd
+	(make-usocket-error-handler waiter
+				    (make-usocket-disconnector event-base waiter))))))
+
+(defun %remove-waiter (wait-list waiter)
+  (let ((event-base (wait-list-%wait wait-list)))
+    (iolib/multiplex:remove-fd-handlers event-base
+					(iolib/sockets:socket-os-fd (socket waiter))
+					:read t
+					:write nil
+					:error t)))
+
+;; NOTE: `wait-list-waiters` returns all usockets
+(defun wait-for-input-internal (wait-list &key timeout)
+  (let ((event-base (wait-list-%wait wait-list)))
+    (handler-case
+	(iolib/multiplex:event-dispatch event-base :timeout timeout)
+      (iolib/streams:hangup ())
+      (end-of-file ()))
+    ;; close the event-base after use
+    (unless (eq event-base *event-base*)
+      (close event-base))))

sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/mcl.lisp

@@ -0,0 +1,271 @@
+;; MCL backend for USOCKET 0.4.1
+;; Terje Norderhaug <terje@in-progress.com>, January 1, 2009
+
+(in-package :usocket)
+
+(defun handle-condition (condition &optional socket (host-or-ip nil))
+  ; incomplete, needs to handle additional conditions
+  (flet ((raise-error (&optional socket-condition host-or-ip)
+           (if socket-condition
+               (cond ((typep socket-condition ns-error)
+                      (error socket-condition :socket socket :host-or-ip host-or-ip))
+                     (t
+                      (error socket-condition :socket socket)))
+               (error 'unknown-error :socket socket :real-error condition))))
+    (typecase condition
+      (ccl:host-stopped-responding
+       (raise-error 'host-down-error host-or-ip))
+      (ccl:host-not-responding
+       (raise-error 'host-unreachable-error host-or-ip))
+      (ccl:connection-reset 
+       (raise-error 'connection-reset-error))
+      (ccl:connection-timed-out
+       (raise-error 'timeout-error))
+      (ccl:opentransport-protocol-error
+       (raise-error 'protocol-not-supported-error))       
+      (otherwise
+       (raise-error condition host-or-ip)))))
+
+(defun socket-connect (host port &key (element-type 'character) timeout deadline nodelay 
+                            local-host local-port (protocol :stream))
+  (when (eq nodelay :if-supported)
+    (setf nodelay t))
+  (ecase protocol
+    (:stream
+     (with-mapped-conditions (nil host)
+       (let* ((socket
+               (make-instance 'active-socket
+		 :remote-host (when host (host-to-hostname host)) 
+                 :remote-port port
+                 :local-host (when local-host (host-to-hostname local-host)) 
+                 :local-port local-port
+                 :deadline deadline
+                 :nodelay nodelay
+                 :connect-timeout (and timeout (round (* timeout 60)))
+                 :element-type element-type))
+              (stream (socket-open-stream socket)))
+         (make-stream-socket :socket socket :stream stream))))
+    (:datagram
+     (with-mapped-conditions (nil (or host local-host))
+       (make-datagram-socket
+	 (ccl::open-udp-socket :local-address (and local-host (host-to-hbo local-host))
+			       :local-port local-port))))))
+
+(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))
+	 (socket (with-mapped-conditions ()
+		   (make-instance 'passive-socket 
+				  :local-port port
+				  :local-host (host-to-hbo host)
+				  :reuse-address reuseaddress
+				  :backlog backlog))))
+    (make-stream-server-socket socket :element-type element-type)))
+
+(defmethod socket-accept ((usocket stream-server-usocket) &key element-type)
+  (let* ((socket (socket usocket))
+         (stream (with-mapped-conditions (usocket)
+                   (socket-accept socket :element-type element-type))))
+    (make-stream-socket :socket socket :stream stream)))
+
+(defmethod socket-close ((usocket usocket))
+  (with-mapped-conditions (usocket)
+    (socket-close (socket usocket))))
+
+(defmethod socket-shutdown ((usocket usocket) direction)
+  (declare (ignore usocket direction))
+  ;; As far as I can tell there isn't a way to shutdown a socket in mcl.
+  (unsupported "shutdown" 'socket-shutdown))
+
+(defmethod ccl::stream-close ((usocket usocket))
+  (socket-close usocket))
+
+(defun get-hosts-by-name (name)
+  (with-mapped-conditions (nil name)
+    (list (hbo-to-vector-quad (ccl::get-host-address
+                               (host-to-hostname name))))))
+
+(defun get-host-by-address (address)
+  (with-mapped-conditions (nil address)
+    (ccl::inet-host-name (host-to-hbo address))))
+
+(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)))
+
+(defmethod get-local-address ((usocket usocket))
+  (hbo-to-vector-quad (ccl::get-host-address (or (local-host (socket usocket)) ""))))
+
+(defmethod get-local-port ((usocket usocket))
+  (local-port (socket usocket)))
+
+(defmethod get-peer-address ((usocket stream-usocket))
+  (hbo-to-vector-quad (ccl::get-host-address (remote-host (socket usocket)))))
+
+(defmethod get-peer-port ((usocket stream-usocket))
+  (remote-port (socket usocket)))
+
+(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)))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; BASIC MCL SOCKET IMPLEMENTATION
+
+(defclass socket ()
+  ((local-port :reader local-port :initarg :local-port)
+   (local-host :reader local-host :initarg :local-host)
+   (element-type :reader element-type :initform 'ccl::base-character :initarg :element-type)))
+
+(defclass active-socket (socket)
+  ((remote-host :reader remote-host :initarg :remote-host)
+   (remote-port :reader remote-port :initarg :remote-port)
+   (deadline :initarg :deadline)
+   (nodelay :initarg :nodelay)
+   (connect-timeout :reader connect-timeout :initform NIL :initarg :connect-timeout
+                    :type (or null fixnum) :documentation "ticks (60th of a second)")))
+
+(defmethod socket-open-stream ((socket active-socket))
+  (ccl::open-tcp-stream (or (remote-host socket)(ccl::local-interface-ip-address)) (remote-port socket)
+   :element-type (if (subtypep (element-type socket) 'character) 'ccl::base-character 'unsigned-byte)
+   :connect-timeout (connect-timeout socket)))
+
+(defmethod socket-close ((socket active-socket))
+  NIL)
+
+(defclass passive-socket (socket)
+  ((streams :accessor socket-streams :type list :initform NIL
+	    :documentation "Circular list of streams with first element the next to open")
+   (reuse-address :reader reuse-address :initarg :reuse-address)
+   (lock :reader socket-lock :initform (ccl:make-lock "Socket"))))
+
+(defmethod initialize-instance :after ((socket passive-socket) &key backlog)
+  (loop repeat backlog
+        collect (socket-open-listener socket) into streams
+        finally (setf (socket-streams socket)
+                      (cdr (rplacd (last streams) streams))))
+  (when (zerop (local-port socket))
+    (setf (slot-value socket 'local-port)
+          (or (ccl::process-wait-with-timeout "binding port" (* 10 60) 
+               #'ccl::stream-local-port (car (socket-streams socket)))
+              (error "timeout")))))
+
+(defmethod socket-accept ((socket passive-socket) &key element-type &aux (lock (socket-lock socket)))
+  (flet ((connection-established-p (stream)
+	   (ccl::with-io-buffer-locked ((ccl::stream-io-buffer stream nil))
+	     (let ((state (ccl::opentransport-stream-connection-state stream)))
+	       (not (eq :unbnd state))))))
+    (with-mapped-conditions ()
+      (ccl:with-lock-grabbed (lock nil "Socket Lock")
+	(let ((connection (shiftf (car (socket-streams socket))
+				  (socket-open-listener socket element-type))))
+	  (pop (socket-streams socket))
+	  (ccl:process-wait "Accepting" #'connection-established-p connection)
+	  connection)))))
+
+(defmethod socket-close ((socket passive-socket))
+  (loop
+    with streams = (socket-streams socket)
+    for (stream tail) on streams
+    do (close stream :abort T)
+    until (eq tail streams)
+    finally (setf (socket-streams socket) NIL)))
+
+(defmethod socket-open-listener (socket &optional element-type)
+  ; see http://code.google.com/p/mcl/issues/detail?id=28
+  (let* ((ccl::*passive-interface-address* (local-host socket))
+         (new (ccl::open-tcp-stream NIL (or (local-port socket) #$kOTAnyInetAddress) 
+                                    :reuse-local-port-p (reuse-address socket) 
+                                    :element-type (if (subtypep (or element-type (element-type socket))
+                                                                'character) 
+                                                    'ccl::base-character 
+                                                    'unsigned-byte))))
+    (declare (special ccl::*passive-interface-address*))
+    new))
+
+(defmethod input-available-p ((stream ccl::opentransport-stream))
+  (macrolet ((when-io-buffer-lock-grabbed ((lock &optional multiple-value-p) &body body)
+	       "Evaluates the body if and only if the lock is successfully grabbed"
+	       ;; like with-io-buffer-lock-grabbed but returns immediately instead of polling the lock
+	       (let ((needs-unlocking-p (gensym))
+		     (lock-var (gensym)))
+		 `(let* ((,lock-var ,lock)
+			 (ccl::*grabbed-io-buffer-locks* (cons ,lock-var ccl::*grabbed-io-buffer-locks*))
+			 (,needs-unlocking-p (needs-unlocking-p ,lock-var)))
+		    (declare (dynamic-extent ccl::*grabbed-io-buffer-locks*))
+		    (when ,needs-unlocking-p
+		      (,(if multiple-value-p 'multiple-value-prog1 'prog1)
+                        (progn ,@body)
+                        (ccl::%release-io-buffer-lock ,lock-var)))))))
+    (labels ((needs-unlocking-p (lock)
+	       (declare (type ccl::lock lock))
+	       ;; crucial - clears bogus lock.value as in grab-io-buffer-lock-out-of-line:
+	       (ccl::%io-buffer-lock-really-grabbed-p lock)
+	       (ccl:store-conditional lock nil ccl:*current-process*)))
+      "similar to stream-listen on buffered-input-stream-mixin but without waiting for lock"
+      (let ((io-buffer (ccl::stream-io-buffer stream)))
+	(or (not (eql 0 (ccl::io-buffer-incount io-buffer)))
+	    (ccl::io-buffer-untyi-char io-buffer)
+	    (locally (declare (optimize (speed 3) (safety 0)))
+	      (when-io-buffer-lock-grabbed ((ccl::io-buffer-lock io-buffer))
+       	        (funcall (ccl::io-buffer-listen-function io-buffer) stream io-buffer))))))))
+
+(defmethod connection-established-p ((stream ccl::opentransport-stream))
+  (ccl::with-io-buffer-locked ((ccl::stream-io-buffer stream nil))
+    (let ((state (ccl::opentransport-stream-connection-state stream)))
+      (not (eq :unbnd state)))))
+
+(defun wait-for-input-internal (wait-list &key timeout &aux result)
+  (labels ((ready-sockets (sockets)
+	     (dolist (sock sockets result)
+	       (when (cond ((stream-usocket-p sock)
+			    (input-available-p (socket-stream sock)))
+			   ((stream-server-usocket-p sock)
+			    (let ((ot-stream (first (socket-streams (socket sock)))))
+			      (or (input-available-p ot-stream)
+				  (connection-established-p ot-stream)))))
+		 (push sock result)))))
+    (with-mapped-conditions ()
+      (ccl:process-wait-with-timeout
+       "socket input"
+       (when timeout (truncate (* timeout 60)))
+       #'ready-sockets
+       (wait-list-waiters wait-list)))
+    (nreverse result)))
+
+;;; datagram socket methods
+
+(defmethod initialize-instance :after ((usocket datagram-usocket) &key)
+  (with-slots (socket send-buffer recv-buffer) usocket
+    (setq send-buffer
+	  (ccl::make-TUnitData (ccl::ot-conn-endpoint socket)))
+    (setq recv-buffer
+	  (ccl::make-TUnitData (ccl::ot-conn-endpoint socket)))))
+
+(defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0))
+  (with-mapped-conditions (usocket host)
+    (with-slots (socket send-buffer) usocket
+      (unless (and host port)
+	(unsupported 'host 'socket-send))
+      (ccl::send-message socket send-buffer buffer size host port offset))))
+
+(defmethod socket-receive ((usocket datagram-usocket) buffer length &key)
+  (with-mapped-conditions (usocket)
+    (with-slots (socket recv-buffer) usocket
+      (ccl::receive-message socket recv-buffer buffer length))))
+
+(defmethod socket-close ((socket datagram-usocket))
+  nil) ; TODO

sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/mezzano.lisp

@@ -0,0 +1,99 @@
+;;;; -*- Mode: Common-Lisp -*-
+
+;;;; See LICENSE for licensing information.
+
+(in-package :usocket)
+
+(defun handle-condition (condition &optional (socket nil))
+  (typecase condition
+    ;; TODO: Add additional conditions as appropriate
+    (mezzano.network.tcp:connection-timed-out
+     (error 'timeout-error :socket socket))))
+
+(defun socket-connect (host port &key (protocol :stream) element-type
+                                      timeout deadline (nodelay nil nodelay-p)
+                                      local-host local-port)
+  (declare (ignore local-host local-port))
+  (when deadline
+    (unsupported 'deadline 'socket-connect))
+  (when (and nodelay-p (not (eq nodelay :if-supported)))
+    (unsupported 'nodelay 'socket-connect))
+  (when timeout
+    (unsupported 'timeout 'socket-connect))
+  (with-mapped-conditions ()
+    (ecase protocol
+      (:stream
+       (let ((s (mezzano.network.tcp:tcp-stream-connect host port :element-type element-type)))
+         (make-stream-socket :socket s
+                             :stream s)))
+      (:datagram
+       ;; TODO:
+       (unsupported 'datagram 'socket-connect)))))
+
+(defun socket-listen (host port &key reuseaddress
+                                     (reuse-address nil reuse-address-supplied-p)
+                                     (backlog 5)
+                                     (element-type 'character))
+  (declare (ignore reuseaddress reuse-address reuse-address-supplied-p))
+  (let ((ip (mezzano.network.ip:make-ipv4-address host)))
+    (make-stream-server-socket (mezzano.network.tcp:tcp-listen ip port :backlog backlog)
+                               :element-type element-type)))
+
+(defun get-hosts-by-name (name)
+  (declare (ignore name)))
+
+(defun get-host-by-address (address)
+  (declare (ignore address)))
+
+(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)
+  (declare (ignore wait-list timeout)))
+
+(defmethod socket-close ((usocket stream-usocket))
+  (with-mapped-conditions ()
+    (close (socket-stream usocket))))
+
+(defmethod socket-close ((usocket stream-server-usocket))
+  (with-mapped-conditions ()
+    (mezzano.network.tcp:close-tcp-listener (socket usocket))))
+
+(defmethod socket-accept ((usocket stream-server-usocket) &key element-type)
+  (declare (ignore element-type))
+  (with-mapped-conditions (usocket)
+    (let ((s (mezzano.network.tcp:tcp-accept (socket usocket))))
+      (make-stream-socket :socket s
+                          :stream s))))
+
+(defmethod get-local-name ((usocket stream-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)))
+
+(defmethod get-local-address ((usocket stream-usocket))
+  (mezzano.network.ip:ipv4-address-to-string
+   (mezzano.network.tcp:tcp-connection-local-ip
+    (mezzano.network.tcp:tcp-stream-connection (socket usocket)))))
+
+(defmethod get-local-port ((usocket stream-usocket))
+  (mezzano.network.tcp:tcp-connection-local-port
+   (mezzano.network.tcp:tcp-stream-connection (socket usocket))))
+
+(defmethod get-peer-address ((usocket stream-usocket))
+  (mezzano.network.ip:ipv4-address-to-string
+   (mezzano.network.tcp:tcp-connection-remote-ip
+    (mezzano.network.tcp:tcp-stream-connection (socket usocket)))))
+
+(defmethod get-peer-port ((usocket stream-usocket))
+  (mezzano.network.tcp:tcp-connection-remote-port
+   (mezzano.network.tcp:tcp-stream-connection (socket usocket))))

sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/mocl.lisp

@@ -0,0 +1,155 @@
+;;;; See LICENSE for licensing information.
+
+(in-package :usocket)
+
+(defun handle-condition (condition &optional (socket nil) (host-or-ip nil))
+  "Dispatch correct usocket condition."
+  (declare (ignore socket))
+  (signal condition))
+
+(defun socket-connect (host port &key (protocol :stream) (element-type 'character)
+                       timeout deadline (nodelay t nodelay-specified)
+		       (local-host nil local-host-p)
+		       (local-port nil local-port-p))
+  (when (and nodelay-specified 
+             (not (eq nodelay :if-supported)))
+    (unsupported 'nodelay 'socket-connect))
+  (when deadline (unsupported 'deadline 'socket-connect))
+  (when timeout (unimplemented 'timeout 'socket-connect))
+  (when local-host-p
+     (unimplemented 'local-host 'socket-connect))
+  (when local-port-p
+     (unimplemented 'local-port 'socket-connect))
+
+  (let (socket)
+    (ecase protocol
+      (:stream
+       (setf socket (rt::socket-connect host port))
+       (let ((stream (rt::make-socket-stream socket :binaryp (not (eq element-type 'character)))))
+	 (make-stream-socket :socket socket :stream stream)))
+      (:datagram
+       (error 'unsupported
+              :feature '(protocol :datagram)
+              :context 'socket-connect)))))
+
+(defun socket-listen (host port
+                           &key reuseaddress
+                           (reuse-address nil reuse-address-supplied-p)
+                           (backlog 5)
+                           (element-type 'character))
+  (unimplemented 'socket-listen 'mocl))
+
+(defmethod socket-accept ((usocket stream-server-usocket) &key element-type)
+  (unimplemented 'socket-accept 'mocl))
+
+;; 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."
+  (rt::socket-shutdown usocket)
+  (rt::c-fclose usocket))
+
+(defmethod socket-close ((usocket stream-usocket))
+  "Close socket."
+  (close (socket-stream usocket)))
+
+;; (defmethod socket-close :after ((socket datagram-usocket))
+;;   (setf (%open-p socket) nil))
+
+(defmethod socket-shutdown ((usocket stream-usocket) direction)
+  (declare (ignore usocket direction))
+  ;; sure would be nice if there was some documentation for mocl...
+  (unimplemented "shutdown" 'socket-shutdown))
+
+;; (defmethod socket-send ((usocket datagram-usocket) buffer size &key host port)
+;;   (let ((s (socket usocket))
+;; 	(host (if host (host-to-hbo host)))
+;; 	(real-buffer (if (zerop offset)
+;; 			 buffer
+;; 			 (subseq buffer offset (+ offset size)))))
+;;     (multiple-value-bind (result errno)
+;; 	(ext:inet-socket-send-to s real-buffer size
+;; 				 :remote-host host :remote-port port)
+;;       (or result
+;; 	  (mocl-map-socket-error errno :socket usocket)))))
+
+;; (defmethod socket-receive ((socket datagram-usocket) buffer length &key)
+;;   (declare (values (simple-array (unsigned-byte 8) (*)) ; buffer
+;; 		   (integer 0)                          ; size
+;; 		   (unsigned-byte 32)                   ; host
+;; 		   (unsigned-byte 16)))                 ; port
+;;   (let ((s (socket socket)))
+;;     (let ((real-buffer (or buffer
+;; 			   (make-array length :element-type '(unsigned-byte 8))))
+;; 	  (real-length (or length
+;; 			   (length buffer))))
+;;       (multiple-value-bind (result errno remote-host remote-port)
+;; 	  (ext:inet-socket-receive-from s real-buffer real-length)
+;; 	(if result
+;; 	    (values real-buffer result remote-host remote-port)
+;; 	    (mocl-map-socket-error errno :socket socket))))))
+
+;; (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)
+  (rt::lookup-host name))
+
+;; (defun get-host-name ()
+;;   (unix:unix-gethostname))
+
+
+;;
+;;
+;;  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)
+  (unimplemented 'wait-for-input-internal 'mocl))

sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/openmcl.lisp

@@ -0,0 +1,268 @@
+;;;; 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)))
+
+(defparameter +openmcl-nameserver-error-map+
+  '((:no-recovery . ns-no-recovery-error)
+    (:try-again . ns-try-again-condition)
+    (:host-not-found . ns-host-not-found-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)
+    ;;### 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 (socket sock))))
+            (when fd ;; may be NIL if closed
+              (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)
+            (dolist (sock sockets)
+              (let ((fd (openmcl-socket:socket-os-fd (socket sock))))
+                (when (and fd (ccl::fd-is-set fd infds))
+                  (setf (state sock) :READ)))))
+          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 (host-or-ip nil))
+  (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))
+    (ccl:communication-deadline-expired
+       (error 'deadline-timeout-error :socket socket))
+    (ccl::socket-creation-error #| ugh! |#
+       (let* ((condition-id (ccl::socket-creation-error-identifier condition))
+	      (nameserver-error (cdr (assoc condition-id
+					    +openmcl-nameserver-error-map+))))
+	 (if nameserver-error
+             (if (typep nameserver-error 'serious-condition)
+                 (error nameserver-error :host-or-ip host-or-ip)
+                 (signal nameserver-error :host-or-ip host-or-ip))
+	   (raise-error-from-id condition-id socket condition))))))
+
+(defun to-format (element-type protocol)
+  (cond ((null element-type)
+	 (ecase protocol ; default value of different protocol
+	   (:stream :text)
+	   (:datagram :binary)))
+	((subtypep element-type 'character)
+	 :text)
+	(t :binary)))
+
+#-ipv6
+(defun socket-connect (host port &key (protocol :stream) element-type
+		       timeout deadline nodelay
+		       local-host local-port)
+  (when (eq nodelay :if-supported)
+    (setf nodelay t))
+  (with-mapped-conditions (nil host)
+    (ecase protocol
+      (:stream
+       (let ((mcl-sock
+	      (openmcl-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 protocol)
+					  :external-format ccl:*default-external-format*
+					  :deadline deadline
+					  :nodelay nodelay
+					  :connect-timeout timeout)))
+	 (make-stream-socket :stream mcl-sock :socket mcl-sock)))
+      (:datagram
+       (let* ((mcl-sock
+	       (openmcl-socket:make-socket :address-family :internet
+					   :type :datagram
+					   :local-host local-host
+					   :local-port local-port
+					   :input-timeout timeout
+					   :format (to-format element-type protocol)
+					   :external-format ccl:*default-external-format*))
+	      (usocket (make-datagram-socket mcl-sock)))
+	 (when (and host port)
+	   (ccl::inet-connect (ccl::socket-device mcl-sock)
+			      (ccl::host-as-inet-host host)
+			      (ccl::port-as-inet-port port "udp")))
+	 (setf (connected-p usocket) t)
+	 usocket)))))
+
+#-ipv6
+(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))
+	 (real-host (host-to-hostname host))
+         (sock (with-mapped-conditions (nil host)
+                  (apply #'openmcl-socket:make-socket
+                         (append (list :connect :passive
+                                       :reuse-address reuseaddress
+                                       :local-port port
+                                       :backlog backlog
+                                       :format (to-format element-type :stream))
+                                 (unless (eq host *wildcard-host*)
+                                   (list :local-host real-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 socket-shutdown ((usocket usocket) direction)
+  (with-mapped-conditions (usocket)
+    (openmcl-socket:shutdown (socket usocket) :direction direction)))
+
+#-ipv6
+(defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0))
+  (with-mapped-conditions (usocket host)
+    (if (and host port)
+	(openmcl-socket:send-to (socket usocket) buffer size
+				:remote-host (host-to-hbo host)
+				:remote-port port
+				:offset offset)
+	;; Clozure CL's socket function SEND-TO doesn't support operations on connected UDP sockets,
+	;; so we have to define our own.
+	(let* ((socket (socket usocket))
+	       (fd (ccl::socket-device socket)))
+	  (multiple-value-setq (buffer offset)
+	    (ccl::verify-socket-buffer buffer offset size))
+	  (ccl::%stack-block ((bufptr size))
+	    (ccl::%copy-ivector-to-ptr buffer offset bufptr 0 size)
+	    (ccl::socket-call socket "send"
+	      (ccl::with-eagain fd :output
+		(ccl::ignoring-eintr
+		  (ccl::check-socket-error (#_send fd bufptr size 0))))))))))
+
+(defmethod socket-receive ((usocket datagram-usocket) buffer length &key)
+  (with-mapped-conditions (usocket)
+    (openmcl-socket:receive-from (socket usocket) length :buffer buffer)))
+
+(defun usocket-host-address (address)
+  (cond
+    ((integerp address)
+     (hbo-to-vector-quad address))
+    ((and (arrayp address)
+          (= (length address) 16)
+          (every #'= address #(0 0 0 0 0 0 0 0 0 0 #xff #xff)))
+     (make-array 4 :displaced-to address :displaced-index-offset 12))
+    (t
+     address)))
+
+(defmethod get-local-address ((usocket usocket))
+  (usocket-host-address (openmcl-socket:local-host (socket usocket))))
+
+(defmethod get-peer-address ((usocket stream-usocket))
+  (usocket-host-address (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 (nil address)
+     (openmcl-socket:ipaddr-to-hostname (host-to-hbo address))))
+
+(defun get-hosts-by-name (name)
+  (with-mapped-conditions (nil name)
+     (list (hbo-to-vector-quad (openmcl-socket:lookup-hostname
+                                (host-to-hostname name))))))
+
+(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*))))
+      (input-available-p (wait-list-waiters wait-list)
+			 (when timeout ticks-timeout))
+      wait-list)))
+
+;;; Helper functions for option.lisp
+
+(defun get-socket-option-reuseaddr (socket)
+  (ccl::int-getsockopt (ccl::socket-device socket)
+                                  #$SOL_SOCKET #$SO_REUSEADDR))
+
+(defun set-socket-option-reuseaddr (socket value)
+  (ccl::int-setsockopt (ccl::socket-device socket)
+                                  #$SOL_SOCKET #$SO_REUSEADDR value))
+
+(defun get-socket-option-broadcast (socket)
+  (ccl::int-getsockopt (ccl::socket-device socket)
+                                  #$SOL_SOCKET #$SO_BROADCAST))
+
+(defun set-socket-option-broadcast (socket value)
+  (ccl::int-setsockopt (ccl::socket-device socket)
+                                  #$SOL_SOCKET #$SO_BROADCAST value))
+
+(defun get-socket-option-tcp-nodelay (socket)
+  (ccl::int-getsockopt (ccl::socket-device socket)
+                                  #$IPPROTO_TCP #$TCP_NODELAY))
+
+(defun set-socket-option-tcp-nodelay (socket value)
+  (ccl::int-setsockopt (ccl::socket-device socket)
+                                  #$IPPROTO_TCP #$TCP_NODELAY value))

sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/sbcl.lisp

@@ -0,0 +1,935 @@
+;;;; -*- Mode: Common-Lisp -*-
+
+;;;; See LICENSE for licensing information.
+
+(in-package :usocket)
+
+#+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))))))
+
+#+(and ecl (not ecl-bytecmp))
+(progn
+  #-:wsock
+  (ffi:clines
+   "#include <errno.h>"
+   "#include <sys/socket.h>"
+   "#include <unistd.h>")
+  #+:wsock
+  (ffi:clines
+   "#ifndef FD_SETSIZE"
+   "#define FD_SETSIZE 1024"
+   "#endif"
+   "#include <winsock2.h>")
+
+  (ffi:clines
+   #+:msvc "#include <time.h>"
+   #-:msvc "#include <sys/time.h>"
+   "#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 cerrno ()
+    (ffi:c-inline () () :int
+     "errno" :one-liner t))
+
+  (defun fd-setsize ()
+    (ffi:c-inline () () :fixnum
+     "FD_SETSIZE" :one-liner t))
+
+  (defun fdset-alloc ()
+    (ffi:c-inline () () :pointer-void
+     "ecl_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 cerrno
+                   fd-setsize
+                   fdset-alloc
+                   fdset-zero
+                   fdset-set
+                   fdset-clr
+                   fdset-fd-isset))
+
+  (defun get-host-name ()
+    (ffi:c-inline
+     () () :object
+     "{ char *buf = (char *) ecl_alloc_atomic(257);
+
+        if (gethostname(buf,256) == 0)
+          @(return) = make_simple_base_string(buf);
+        else
+          @(return) = Cnil;
+      }" :one-liner nil :side-effects nil))
+
+  (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;
+          struct timeval tv;
+          struct timeval tvs;
+          struct timeval tve;
+          unsigned long elapsed;
+          unsigned long remaining;
+          int retval = -1;
+
+          if (#0 != Cnil) {
+            tv.tv_sec = fixnnint(#0);
+            tv.tv_usec = #1;
+          }
+          remaining = ((tv.tv_sec*1000000) + tv.tv_usec);
+
+          do {
+              (void)gettimeofday(&tvs, NULL);   // start time
+
+              retval = select(#3 + 1, (fd_set*)#2, NULL, NULL,
+                           (#0 != Cnil) ? &tv : NULL);
+
+              if ( (retval < 0) && (errno == EINTR) && (#0 != Cnil) ) {
+                  (void)gettimeofday(&tve, NULL);            // end time
+                  elapsed = (tve.tv_sec - tvs.tv_sec)*1000000 + (tve.tv_usec - tvs.tv_usec);
+                  remaining = remaining - elapsed;
+                  if ( remaining < 0 ) {                     // already past timeout, just exit
+                      retval = 0;
+                      break;
+                  }
+
+                  tv.tv_sec = remaining / 1000000;
+                  tv.tv_usec = remaining - (tv.tv_sec * 1000000);
+              }
+
+          } while ((retval < 0) && (errno == EINTR));
+
+          @(return) = retval;
+" :one-liner nil)))
+        (cond
+          ((= 0 count)
+           (values nil nil))
+          ((< count 0)
+           ;; check for EAGAIN; these should not err
+           (values nil (cerrno)))
+          (t
+           (dolist (sock sockets)
+             (when (fdset-fd-isset rfds (sb-bsd-sockets:socket-file-descriptor
+                                         (socket sock)))
+               (setf (state sock) :READ))))))))
+) ; progn
+
+(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)
+    #-(or ecl clasp)
+    (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)
+    #-(or ecl clasp)
+    (sb-sys:io-timeout . timeout-error)
+    #+sbcl
+    (sb-ext:timeout . timeout-error)
+    (sb-bsd-sockets:socket-error . ,#'map-socket-error)
+
+    ;; Nameservice errors: mapped to unknown-error
+    #-(or ecl clasp)
+    (sb-bsd-sockets:no-recovery-error . ns-no-recovery-error)
+    #-(or ecl clasp)
+    (sb-bsd-sockets:try-again-error . ns-try-again-condition)
+    #-(or ecl clasp)
+    (sb-bsd-sockets:host-not-found-error . ns-host-not-found-error)))
+
+;; this function servers as a general template for other backends
+(defun handle-condition (condition &optional (socket nil) (host-or-ip nil))
+  "Dispatch correct usocket condition."
+  (typecase condition
+    (serious-condition
+     (let* ((usock-error (cdr (assoc (type-of condition) +sbcl-error-map+)))
+            (usock-error (if (functionp usock-error)
+                             (funcall usock-error condition)
+                             usock-error)))
+       (declare (type symbol usock-error))
+       (if usock-error
+           (cond ((subtypep usock-error 'ns-error)
+                  (error usock-error :socket socket :host-or-ip host-or-ip))
+                 (t
+                  (error usock-error :socket socket)))
+           (error 'unknown-error
+                  :real-error condition
+                  :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
+           (cond ((subtypep usock-cond 'ns-condition)
+                  (signal usock-cond :socket socket :host-or-ip host-or-ip))
+                 (t
+                  (signal usock-cond :socket socket)))
+           (signal 'unknown-condition
+                   :real-condition condition
+                   :socket socket))))))
+
+;;; "The socket stream ends up with a bogus name as it is created before
+;;; the socket is connected, making things harder to debug than they need
+;;; to be." -- Nikodemus Siivola <nikodemus@random-state.net>
+
+(defvar *dummy-stream*
+  (let ((stream (make-broadcast-stream)))
+    (close stream)
+    stream))
+
+;;; Amusingly, neither SBCL's own, nor GBBopen's WITH-TIMEOUT is asynch
+;;; unwind safe. The one I posted is -- that's what the WITHOUT-INTERRUPTS
+;;; and WITH-LOCAL-INTERRUPTS were for. :) But yeah, it's miles saner than
+;;; the SB-EXT:WITH-TIMEOUT. -- Nikodemus Siivola <nikodemus@random-state.net>
+
+#+(and sbcl (not win32))
+(defmacro %with-timeout ((seconds timeout-form) &body body)
+  "Runs BODY as an implicit PROGN with timeout of SECONDS. If
+timeout occurs before BODY has finished, BODY is unwound and
+TIMEOUT-FORM is executed with its values returned instead.
+
+Note that BODY is unwound asynchronously when a timeout occurs,
+so unless all code executed during it -- including anything
+down the call chain -- is asynch unwind safe, bad things will
+happen. Use with care."
+  (let ((exec (gensym)) (unwind (gensym)) (timer (gensym))
+	(timeout (gensym)) (block (gensym)))
+    `(block ,block
+       (tagbody
+	  (flet ((,unwind ()
+		   (go ,timeout))
+		 (,exec ()
+		   ,@body))
+	    (declare (dynamic-extent #',exec #',unwind))
+	    (let ((,timer (sb-ext:make-timer #',unwind)))
+	      (declare (dynamic-extent ,timer))
+	      (sb-sys:without-interrupts
+		  (unwind-protect
+		       (progn
+			 (sb-ext:schedule-timer ,timer ,seconds)
+			 (return-from ,block
+			   (sb-sys:with-local-interrupts
+			       (,exec))))
+		    (sb-ext:unschedule-timer ,timer)))))
+	  ,timeout
+	  (return-from ,block ,timeout-form)))))
+
+(defun get-hosts-by-name (name)
+  (with-mapped-conditions (nil name)
+    (multiple-value-bind (host4 host6)
+        (sb-bsd-sockets:get-host-by-name name)
+      (let ((addr4 (when host4
+                     (sb-bsd-sockets::host-ent-addresses host4)))
+            (addr6 (when host6
+                     (sb-bsd-sockets::host-ent-addresses host6))))
+        (append addr4 addr6)))))
+
+(defun socket-connect (host port &key (protocol :stream) (element-type 'character)
+                       timeout deadline (nodelay t nodelay-specified)
+                       local-host local-port
+		       &aux
+		       (sockopt-tcp-nodelay-p
+			(fboundp 'sb-bsd-sockets::sockopt-tcp-nodelay)))
+  (when deadline (unsupported 'deadline 'socket-connect))
+  #+(or ecl clasp)
+  (when timeout (unsupported 'timeout 'socket-connect))
+  (when (and nodelay-specified
+             ;; 20080802: ECL added this function to its sockets
+             ;; package today. There's no guarantee the functions
+             ;; we need are available, but we can make sure not to
+             ;; call them if they aren't
+             (not (eq nodelay :if-supported))
+             (not sockopt-tcp-nodelay-p))
+    (unsupported 'nodelay 'socket-connect))
+  (when (eq nodelay :if-supported)
+    (setf nodelay t))
+
+  (let* ((remote (when host
+                   (car (get-hosts-by-name (host-to-hostname host)))))
+         (local (when local-host
+                  (car (get-hosts-by-name (host-to-hostname local-host)))))
+         (ipv6 (or (and remote (= 16 (length remote)))
+                   (and local (= 16 (length local)))))
+         (socket (make-instance #+sbcl (if ipv6
+                                           'sb-bsd-sockets::inet6-socket
+                                           'sb-bsd-sockets:inet-socket)
+                                #+(or ecl clasp) 'sb-bsd-sockets:inet-socket
+                                :type protocol
+                                :protocol (case protocol
+                                            (:stream :tcp)
+                                            (:datagram :udp))))
+         usocket
+         ok)
+
+    (unwind-protect
+         (progn
+           (ecase protocol
+             (:stream
+              ;; If make a real socket stream before the socket is
+              ;; connected, it gets a misleading name so supply a
+              ;; dummy value to start with.
+              (setf usocket (make-stream-socket :socket socket :stream *dummy-stream*))
+              ;; binghe: use SOCKOPT-TCP-NODELAY as internal symbol
+              ;;         to pass compilation on ECL without it.
+              (when (and nodelay-specified sockopt-tcp-nodelay-p)
+                (setf (sb-bsd-sockets::sockopt-tcp-nodelay socket) nodelay))
+              (when (or local-host local-port)
+                (sb-bsd-sockets:socket-bind socket
+                                            (if ipv6
+                                                (or local (ipv6-host-to-vector "::0"))
+                                                (or local (host-to-vector-quad *wildcard-host*)))
+                                            (or local-port *auto-port*)))
+
+              (with-mapped-conditions (usocket host)
+		#+(and sbcl (not win32))
+		(labels ((connect ()
+                           (sb-bsd-sockets:socket-connect socket remote port)))
+		  (if timeout
+		      (%with-timeout (timeout (error 'sb-ext:timeout)) (connect))
+		      (connect)))
+		#+(or ecl clasp (and sbcl win32))
+		(sb-bsd-sockets:socket-connect socket remote port)
+                ;; Now that we're connected make the stream.
+                (setf (socket-stream usocket)
+                      (sb-bsd-sockets:socket-make-stream socket
+                        :input t :output t :buffering :full
+			:element-type element-type
+			;; Robert Brown <robert.brown@gmail.com> said on Aug 4, 2011:
+			;; ... This means that SBCL streams created by usocket have a true
+			;; serve-events property.  When writing large amounts of data to several
+			;; streams, the kernel will eventually stop accepting data from SBCL.
+			;; When this happens, SBCL either waits for I/O to be possible on
+			;; the file descriptor it's writing to or queues the data to be flushed later.
+			;; Because usocket streams specify serve-events as true, SBCL
+			;; always queues.  Instead, it should wait for I/O to be available and
+			;; write the remaining data to the socket.  That's what serve-events
+			;; equal to NIL gets you.
+			;;
+			;; Nikodemus Siivola <nikodemus@random-state.net> said on Aug 8, 2011:
+			;; It's set to T for purely historical reasons, and will soon change to
+			;; NIL in SBCL. (The docstring has warned of T being a temporary default
+			;; for as long as the :SERVE-EVENTS keyword argument has existed.)
+			:serve-events nil))))
+             (:datagram
+              (when (or local-host local-port)
+                (sb-bsd-sockets:socket-bind socket
+                                            (if ipv6
+                                                (or local (ipv6-host-to-vector "::0"))
+                                                (or local (host-to-vector-quad *wildcard-host*)))
+                                            (or local-port *auto-port*)))
+              (setf usocket (make-datagram-socket socket))
+              (when (and host port)
+                (with-mapped-conditions (usocket)
+                  (sb-bsd-sockets:socket-connect socket remote port)
+                  (setf (connected-p usocket) t)))))
+           (setf ok t))
+      ;; Clean up in case of an error.
+      (unless ok
+        (sb-bsd-sockets:socket-close socket :abort t)))
+    usocket))
+
+(defun socket-listen (host port
+                           &key reuseaddress
+                           (reuse-address nil reuse-address-supplied-p)
+                           (backlog 5)
+                           (element-type 'character))
+  (let* (#+sbcl
+	 (local (when host
+                  (car (get-hosts-by-name (host-to-hostname host)))))
+	 #+sbcl
+         (ipv6 (and local (= 16 (length local))))
+         (reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress))
+         (ip #+sbcl (if (and local (not (eq host *wildcard-host*)))
+                        local
+                        (hbo-to-vector-quad sb-bsd-sockets-internal::inaddr-any))
+             #+(or ecl clasp) (host-to-vector-quad host))
+         (sock (make-instance #+sbcl (if ipv6
+                                         'sb-bsd-sockets::inet6-socket
+                                         'sb-bsd-sockets:inet-socket)
+                              #+(or ecl clasp) 'sb-bsd-sockets:inet-socket
+                              :type :stream
+                              :protocol :tcp)))
+    (handler-case
+        (with-mapped-conditions (nil host)
+          (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))
+      (t (c)
+        ;; Make sure we don't leak filedescriptors
+        (sb-bsd-sockets:socket-close sock)
+        (error c)))))
+
+;;; "2. SB-BSD-SOCKETS:SOCKET-ACCEPT method returns NIL for EAGAIN/EINTR,
+;;; instead of raising a condition. It's always possible for
+;;; SOCKET-ACCEPT on non-blocking socket to fail, even after the socket
+;;; was detected to be ready: connection might be reset, for example.
+;;;
+;;; "I had to redefine SOCKET-ACCEPT method of STREAM-SERVER-USOCKET to
+;;; handle this situation. Here is the redefinition:" -- Anton Kovalenko <anton@sw4me.com>
+
+(defmethod socket-accept ((usocket stream-server-usocket) &key element-type)
+  (with-mapped-conditions (usocket)
+    (let ((socket (sb-bsd-sockets:socket-accept (socket usocket))))
+      (when socket
+        (prog1
+	  (make-stream-socket
+	   :socket socket
+	   :stream (sb-bsd-sockets:socket-make-stream
+		    socket
+		    :input t :output t :buffering :full
+		    :element-type (or element-type
+				      (element-type usocket))))
+
+          ;; next time wait for event again if we had EAGAIN/EINTR
+          ;; or else we'd enter a tight loop of failed accepts
+          #+win32
+          (setf (%ready-p usocket) nil))))))
+
+;; 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))))
+
+#+sbcl
+(defmethod socket-shutdown ((usocket stream-usocket) direction)
+  (with-mapped-conditions (usocket)
+    (sb-bsd-sockets::socket-shutdown (socket usocket) :direction direction)))
+
+#+ecl
+(defmethod socket-shutdown ((usocket stream-usocket) direction)
+  (let ((sock-fd (sb-bsd-sockets:socket-file-descriptor (socket usocket)))
+        (direction-flag (ecase direction
+                          (:input 0)
+                          (:output 1))))
+    (unless (zerop (ffi:c-inline (sock-fd direction-flag) (:int :int) :int
+                               "shutdown(#0, #1)" :one-liner t))
+      (error (map-errno-error (cerrno))))))
+
+#+clasp
+(defmethod socket-shutdown ((usocket stream-usocket) direction)
+  (let ((sock-fd (sb-bsd-sockets:socket-file-descriptor (socket usocket)))
+        (direction-flag (ecase direction
+                          (:input 0)
+                          (:output 1))))
+    (unless (zerop (sockets-internal:shutdown sock-fd direction-flag))
+      (error (map-errno-error (cerrno))))))
+
+(defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0))
+  (let ((remote (when host
+                  (car (get-hosts-by-name (host-to-hostname host))))))
+    (with-mapped-conditions (usocket host)
+      (let* ((s (socket usocket))
+             (dest (if (and host port) (list remote port) nil))
+             (real-buffer (if (zerop offset)
+                              buffer
+                              (subseq buffer offset (+ offset size)))))
+        (sb-bsd-sockets:socket-send s real-buffer size :address dest)))))
+
+(defmethod socket-receive ((usocket datagram-usocket) buffer length
+			   &key (element-type '(unsigned-byte 8)))
+  #+sbcl
+  (declare (values (simple-array (unsigned-byte 8) (*)) ; buffer
+		   (integer 0)                          ; size
+		   (simple-array (unsigned-byte 8) (*)) ; host
+		   (unsigned-byte 16)))                 ; port
+  (with-mapped-conditions (usocket)
+    (let ((s (socket usocket)))
+      (sb-bsd-sockets:socket-receive s buffer length :element-type element-type))))
+
+(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 (nil address)
+    (sb-bsd-sockets::host-ent-name
+        (sb-bsd-sockets:get-host-by-address address))))
+
+#+(and sbcl (not win32))
+(progn
+  (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 (wait-list-%wait sockets))
+           (sb-unix:fd-set
+            (sb-bsd-sockets:socket-file-descriptor socket)
+            rfds))
+         (multiple-value-bind
+             (secs musecs)
+             (split-timeout (or timeout 1))
+           (let* ((wait-list (wait-list-%wait sockets))
+                  count err)
+             (if (null wait-list)
+                 (setq count 0) ;; no need to call
+               (multiple-value-setq (count err)
+                 (sb-unix:unix-fast-select
+                  ;; "invalid number of arguments: 0" if wait-list is null.
+                  (1+ (reduce #'max wait-list
+                              :key #'sb-bsd-sockets:socket-file-descriptor))
+                  (sb-alien:addr rfds) nil nil
+                  (when timeout secs) (when timeout musecs))))
+             (if (null count) ; something wrong in #'sb-unix:unix-fast-select
+                 (unless (= err sb-unix:eintr)
+                   (error (map-errno-error err)))
+                 (when (< 0 count) ; do nothing if count = 0
+                   ;; process the result...
+                   (dolist (x (wait-list-waiters sockets))
+                     (when (sb-unix:fd-isset
+                            (sb-bsd-sockets:socket-file-descriptor
+                             (socket x))
+                            rfds)
+                       (setf (state x) :READ))))))))))
+) ; progn
+
+;;; WAIT-FOR-INPUT support for SBCL on Windows platform (Chun Tian (binghe))
+;;; Based on LispWorks version written by Erik Huelsmann.
+
+#+win32 ; shared by ECL and SBCL
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defconstant +wsa-wait-failed+ #xffffffff)
+  (defconstant +wsa-infinite+ #xffffffff)
+  (defconstant +wsa-wait-event-0+ 0)
+  (defconstant +wsa-wait-timeout+ 258))
+
+#+win32 ; shared by ECL and SBCL
+(progn
+  (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)
+
+  ;; Note: for ECL, socket-handle will return raw Windows Handle,
+  ;;       while SBCL returns OSF Handle instead.
+  (defun socket-handle (usocket)
+    (sb-bsd-sockets:socket-file-descriptor (socket usocket)))
+
+  (defun socket-ready-p (socket)
+    (if (typep socket 'stream-usocket)
+        (plusp (bytes-available-for-read socket))
+      (%ready-p socket)))
+
+  (defun waiting-required (sockets)
+    (notany #'socket-ready-p sockets))
+
+  (defun raise-usock-err (errno &optional socket)
+    (error 'unknown-error
+           :socket socket
+           :real-error errno))
+
+  (defun wait-for-input-internal (wait-list &key timeout)
+    (when (waiting-required (wait-list-waiters wait-list))
+      (let ((rv (wsa-wait-for-multiple-events 1 (wait-list-%wait wait-list)
+                                              nil
+                                              (if timeout
+                                                  (truncate (* 1000 timeout))
+                                                  +wsa-infinite+)
+                                              nil)))
+        (ecase rv
+          ((#.+wsa-wait-event-0+)
+           (update-ready-and-state-slots wait-list))
+          ((#.+wsa-wait-timeout+)) ; do nothing here
+          ((#.+wsa-wait-failed+)
+           (maybe-wsa-error rv))))))
+
+  (defun %add-waiter (wait-list waiter)
+    (let ((events (etypecase waiter
+                    (stream-server-usocket (logior fd-connect fd-accept fd-close))
+                    (stream-usocket (logior fd-read))
+                    (datagram-usocket (logior fd-read)))))
+      (maybe-wsa-error
+       (wsa-event-select (os-socket-handle waiter) (os-wait-list-%wait wait-list) events)
+       waiter)))
+
+  (defun %remove-waiter (wait-list waiter)
+    (maybe-wsa-error
+     (wsa-event-select (os-socket-handle waiter) (os-wait-list-%wait wait-list) 0)
+     waiter))
+) ; progn
+
+#+(and sbcl win32)
+(progn
+  ;; "SOCKET is defined as intptr_t in Windows headers; however, WS-SOCKET
+  ;; is defined as unsigned-int, i.e. 32-bit even on 64-bit platform.  It
+  ;; seems to be a good thing to redefine WS-SOCKET as SB-ALIEN:SIGNED,
+  ;; which is always machine word-sized (exactly as intptr_t;
+  ;; N.B. as of Windows/x64, long and signed-long are 32-bit, and thus not
+  ;; enough -- potentially)."
+  ;; -- Anton Kovalenko <anton@sw4me.com>, Mar 22, 2011
+  (sb-alien:define-alien-type ws-socket sb-alien:signed)
+
+  (sb-alien:define-alien-type ws-dword sb-alien:unsigned-long)
+  (sb-alien:define-alien-type ws-event sb-alien::hinstance)
+
+  (sb-alien:define-alien-type nil
+    (sb-alien:struct wsa-network-events
+      (network-events sb-alien:long)
+      (error-code (array sb-alien:int 10)))) ; 10 = fd-max-events
+
+  (sb-alien:define-alien-routine ("WSACreateEvent" wsa-event-create)
+      ws-event) ; return type only
+
+  (sb-alien:define-alien-routine ("WSACloseEvent" wsa-event-close)
+      (boolean #.sb-vm::n-machine-word-bits)
+    (event-object ws-event))
+
+  ;; not used
+  (sb-alien:define-alien-routine ("WSAResetEvent" wsa-reset-event)
+      (boolean #.sb-vm::n-machine-word-bits)
+    (event-object ws-event))
+
+  (sb-alien:define-alien-routine ("WSAEnumNetworkEvents" wsa-enum-network-events)
+      sb-alien:int
+    (socket ws-socket)
+    (event-object ws-event)
+    (network-events (* (sb-alien:struct wsa-network-events))))
+
+  (sb-alien:define-alien-routine ("WSAEventSelect" wsa-event-select)
+      sb-alien:int
+    (socket ws-socket)
+    (event-object ws-event)
+    (network-events sb-alien:long))
+
+  (sb-alien:define-alien-routine ("WSAWaitForMultipleEvents" wsa-wait-for-multiple-events)
+      ws-dword
+    (number-of-events ws-dword)
+    (events (* ws-event))
+    (wait-all-p (boolean #.sb-vm::n-machine-word-bits))
+    (timeout ws-dword)
+    (alertable-p (boolean #.sb-vm::n-machine-word-bits)))
+
+  (sb-alien:define-alien-routine ("ioctlsocket" wsa-ioctlsocket)
+      sb-alien:int
+    (socket ws-socket)
+    (cmd sb-alien:long)
+    (argp (* sb-alien:unsigned-long)))
+
+  (defun maybe-wsa-error (rv &optional socket)
+    (unless (zerop rv)
+      (raise-usock-err (sockint::wsa-get-last-error) socket)))
+
+  (defun os-socket-handle (usocket)
+    (sb-bsd-sockets:socket-file-descriptor (socket usocket)))
+
+  (defun bytes-available-for-read (socket)
+    (sb-alien:with-alien ((int-ptr sb-alien:unsigned-long))
+      (maybe-wsa-error (wsa-ioctlsocket (os-socket-handle socket) fionread (sb-alien:addr int-ptr))
+                       socket)
+      (prog1 int-ptr
+        (when (plusp int-ptr)
+          (setf (state socket) :read)))))
+
+  (defun map-network-events (func network-events)
+    (let ((event-map (sb-alien:slot network-events 'network-events))
+          (error-array (sb-alien:slot network-events 'error-code)))
+      (unless (zerop event-map)
+        (dotimes (i fd-max-events)
+          (unless (zerop (ldb (byte 1 i) event-map)) ;;### could be faster with ash and logand?
+            (funcall func (sb-alien:deref error-array i)))))))
+
+  (defun update-ready-and-state-slots (wait-list)
+    (loop with sockets = (wait-list-waiters wait-list)
+          for socket in sockets do
+      (if (%ready-p socket)
+          (progn
+            (setf (state socket) :READ))
+        (sb-alien:with-alien ((network-events (sb-alien:struct wsa-network-events)))
+          (let ((rv (wsa-enum-network-events (os-socket-handle socket)
+                                             (os-wait-list-%wait wait-list)
+                                             (sb-alien:addr network-events))))
+            (if (zerop rv)
+                (map-network-events
+                 #'(lambda (err-code)
+                     (if (zerop err-code)
+                         (progn
+                           (setf (state socket) :READ)
+                           (when (stream-server-usocket-p socket)
+                             (setf (%ready-p socket) t)))
+                       (raise-usock-err err-code socket)))
+                 network-events)
+              (maybe-wsa-error rv socket)))))))
+
+  (defun os-wait-list-%wait (wait-list)
+    (sb-alien:deref (wait-list-%wait wait-list)))
+
+  (defun (setf os-wait-list-%wait) (value wait-list)
+    (setf (sb-alien:deref (wait-list-%wait wait-list)) value))
+
+  ;; "Event handles are leaking in current SBCL backend implementation,
+  ;; because of SBCL-unfriendly usage of finalizers.
+  ;;
+  ;; "SBCL never calls a finalizer that closes over a finalized object: a
+  ;; reference from that closure prevents its collection forever. That's
+  ;; the case with USOCKET in %SETUP-WAIT-LIST.
+  ;;
+  ;; "I use the following redefinition of %SETUP-WAIT-LIST: 
+  ;;
+  ;; "Of course it may be rewritten with more clarity, but you can see the
+  ;; core idea: I'm closing over those components of WAIT-LIST that I need
+  ;; for finalization, not the wait-list itself. With the original
+  ;; %SETUP-WAIT-LIST, hunchentoot stops working after ~100k accepted
+  ;; connections; it doesn't happen with redefined %SETUP-WAIT-LIST."
+  ;;
+  ;; -- Anton Kovalenko <anton@sw4me.com>, Mar 22, 2011
+
+  (defun %setup-wait-list (wait-list)
+    (setf (wait-list-%wait wait-list) (sb-alien:make-alien ws-event))
+    (setf (os-wait-list-%wait wait-list) (wsa-event-create))
+    (sb-ext:finalize wait-list
+		     (let ((event-handle (os-wait-list-%wait wait-list))
+			   (alien (wait-list-%wait wait-list)))
+		       #'(lambda ()
+			   (wsa-event-close event-handle)
+			   (unless (null alien)
+			     (sb-alien:free-alien alien))))))
+
+) ; progn
+
+#+(and (or ecl clasp) (not win32))
+(progn
+  (defun wait-for-input-internal (wl &key timeout)
+    (with-mapped-conditions ()
+      (multiple-value-bind (secs usecs)
+          (split-timeout (or timeout 1))
+        (multiple-value-bind (result-fds err)
+            (read-select wl (when timeout secs) usecs)
+	  (declare (ignore result-fds))
+          (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)))
+) ; progn
+
+#+(and (or ecl clasp) win32 (not ecl-bytecmp))
+(progn
+  (defun maybe-wsa-error (rv &optional syscall)
+    (unless (zerop rv)
+      (sb-bsd-sockets::socket-error syscall)))
+
+  (defun %setup-wait-list (wl)
+    (setf (wait-list-%wait wl)
+          (ffi:c-inline () () :int
+           "WSAEVENT event;
+            event = WSACreateEvent();
+            @(return) = event;")))
+
+  (defun %add-waiter (wait-list waiter)
+    (let ((events (etypecase waiter
+                    (stream-server-usocket (logior fd-connect fd-accept fd-close))
+                    (stream-usocket (logior fd-read))
+                    (datagram-usocket (logior fd-read)))))
+      (maybe-wsa-error
+       (ffi:c-inline ((socket-handle waiter) (wait-list-%wait wait-list) events)
+                     (:fixnum :fixnum :fixnum) :fixnum
+        "int result;
+         result = WSAEventSelect((SOCKET)#0, (WSAEVENT)#1, (long)#2);
+         @(return) = result;")
+       '%add-waiter)))
+
+  (defun %remove-waiter (wait-list waiter)
+    (maybe-wsa-error
+     (ffi:c-inline ((socket-handle waiter) (wait-list-%wait wait-list))
+                   (:fixnum :fixnum) :fixnum
+      "int result;
+       result = WSAEventSelect((SOCKET)#0, (WSAEVENT)#1, 0L);
+       @(return) = result;")
+     '%remove-waiter))
+
+  ;; TODO: how to handle error (result) in this call?
+  (declaim (inline %bytes-available-for-read))
+  (defun %bytes-available-for-read (socket)
+    (ffi:c-inline ((socket-handle socket)) (:fixnum) :fixnum
+     "u_long nbytes;
+      int result;
+      nbytes = 0L;
+      result = ioctlsocket((SOCKET)#0, FIONREAD, &nbytes);
+      @(return) = nbytes;"))
+
+  (defun bytes-available-for-read (socket)
+    (let ((nbytes (%bytes-available-for-read socket)))
+      (when (plusp nbytes)
+	(setf (state socket) :read))
+      nbytes))
+
+  (defun update-ready-and-state-slots (wait-list)
+    (loop with sockets = (wait-list-waiters wait-list)
+          for socket in sockets do
+      (if (%ready-p socket)
+          (setf (state socket) :READ)
+        (let ((events (etypecase socket
+                        (stream-server-usocket (logior fd-connect fd-accept fd-close))
+                        (stream-usocket (logior fd-read))
+                        (datagram-usocket (logior fd-read)))))
+          ;; TODO: check the iErrorCode array
+          (multiple-value-bind (valid-p ready-p)
+              (ffi:c-inline ((socket-handle socket) events) (:fixnum :fixnum)
+                                                            (values :bool :bool)
+                ;; TODO: replace 0 (2nd arg) with (wait-list-%wait wait-list)
+                "WSANETWORKEVENTS network_events;
+                 int i, result;
+                 result = WSAEnumNetworkEvents((SOCKET)#0, 0, &network_events);
+                 if (!result) {
+                   @(return 0) = Ct;
+                   @(return 1) = (#1 & network_events.lNetworkEvents)? Ct : Cnil;
+                 } else {
+                   @(return 0) = Cnil;
+                   @(return 1) = Cnil;
+                 }")
+            (if valid-p
+                (when ready-p
+                  (setf (state socket) :READ)
+                  (when (stream-server-usocket-p socket)
+                    (setf (%ready-p socket) t)))
+              (sb-bsd-sockets::socket-error 'update-ready-and-state-slots)))))))
+
+  (defun wait-for-input-internal (wait-list &key timeout)
+    (when (waiting-required (wait-list-waiters wait-list))
+      (let ((rv (ffi:c-inline ((wait-list-%wait wait-list)
+                               (if timeout
+                                   (truncate (* 1000 timeout))
+                                   +wsa-infinite+))
+                              (:fixnum :fixnum) :fixnum
+                 "DWORD result;
+                  WSAEVENT events[1];
+                  events[0] = (WSAEVENT)#0;
+                  result = WSAWaitForMultipleEvents(1, events, NULL, #1, NULL);
+                  @(return) = result;")))
+        (ecase rv
+          ((#.+wsa-wait-event-0+)
+           (update-ready-and-state-slots (wait-list-waiters wait-list)))
+          ((#.+wsa-wait-timeout+)) ; do nothing here
+          ((#.+wsa-wait-failed+)
+           (sb-bsd-sockets::socket-error 'wait-for-input-internal))))))
+
+) ; progn

sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/scl.lisp

@@ -0,0 +1,266 @@
+;;;; 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) (host-or-ip nil))
+  "Dispatch correct usocket condition."
+  (typecase condition
+    (ext::socket-error
+     (scl-map-socket-error (ext::socket-errno condition)
+			   :socket socket
+			   :condition condition))))
+
+(defun socket-connect (host port &key (protocol :stream) (element-type 'character)
+                       timeout deadline (nodelay t nodelay-specified)
+		       (local-host nil local-host-p)
+		       (local-port nil local-port-p)
+		       &aux
+		       (patch-udp-p (fboundp 'ext::inet-socket-send-to)))
+  (when (and nodelay-specified 
+             (not (eq nodelay :if-supported)))
+    (unsupported 'nodelay 'socket-connect))
+  (when deadline (unsupported 'deadline 'socket-connect))
+  (when timeout (unsupported 'timeout 'socket-connect))
+  (when (and local-host-p (not patch-udp-p))
+     (unsupported 'local-host 'socket-connect :minimum "1.3.9"))
+  (when (and local-port-p (not patch-udp-p))
+     (unsupported 'local-port 'socket-connect :minimum "1.3.9"))
+
+  (let ((socket))
+    (ecase protocol
+      (:stream
+       (setf socket (let ((args (list (host-to-hbo host) port :kind protocol)))
+		      (when (and patch-udp-p (or local-host-p local-port-p))
+			(nconc args (list :local-host (when local-host
+							(host-to-hbo local-host))
+					  :local-port local-port)))
+		      (with-mapped-conditions (socket)
+			(apply #'ext:connect-to-inet-socket args))))
+       (let ((stream (sys:make-fd-stream socket :input t :output t
+					 :element-type element-type
+					 :buffering :full)))
+	 (make-stream-socket :socket socket :stream stream)))
+      (:datagram
+       (when (not patch-udp-p)
+	 (error 'unsupported
+		:feature '(protocol :datagram)
+		:context 'socket-connect
+		:minumum "1.3.9"))
+       (setf socket
+	     (if (and host port)
+		 (let ((args (list (host-to-hbo host) port :kind protocol)))
+		   (when (and patch-udp-p (or local-host-p local-port-p))
+		     (nconc args (list :local-host (when local-host
+						     (host-to-hbo local-host))
+				       :local-port local-port)))
+		   (with-mapped-conditions (socket)
+		     (apply #'ext:connect-to-inet-socket args)))
+		 (if (or local-host-p local-port-p)
+		     (with-mapped-conditions ()
+		       (ext:create-inet-listener (or local-port 0)
+						 protocol
+						 :host (when local-host
+							 (if (ip= local-host *wildcard-host*)
+							     0
+							     (host-to-hbo local-host)))))
+		     (with-mapped-conditions ()
+		       (ext:create-inet-socket protocol)))))
+       (let ((usocket (make-datagram-socket socket :connected-p (and host port t))))
+	 (ext:finalize usocket #'(lambda ()
+				   (when (%open-p usocket)
+				     (ext:close-socket socket))))
+	 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))
+         (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 socket-close :after ((socket datagram-usocket))
+  (setf (%open-p socket) nil))
+
+(defmethod socket-shutdown ((usocket usocket) direction)
+  (declare (ignore usocket direction))
+  (unsupported "shutdown" 'socket-shutdown))
+
+(defmethod socket-send ((usocket datagram-usocket) buffer size &key host port)
+  (let ((s (socket usocket))
+	(host (if host (host-to-hbo host)))
+	(real-buffer (if (zerop offset)
+			 buffer
+			 (subseq buffer offset (+ offset size)))))
+    (multiple-value-bind (result errno)
+	(ext:inet-socket-send-to s real-buffer size
+				 :remote-host host :remote-port port)
+      (or result
+	  (scl-map-socket-error errno :socket usocket)))))
+
+(defmethod socket-receive ((socket datagram-usocket) buffer length &key)
+  (declare (values (simple-array (unsigned-byte 8) (*)) ; buffer
+		   (integer 0)                          ; size
+		   (unsigned-byte 32)                   ; host
+		   (unsigned-byte 16)))                 ; port
+  (let ((s (socket socket)))
+    (let ((real-buffer (or buffer
+			   (make-array length :element-type '(unsigned-byte 8))))
+	  (real-length (or length
+			   (length buffer))))
+      (multiple-value-bind (result errno remote-host remote-port)
+	  (ext:inet-socket-receive-from s real-buffer real-length)
+	(if result
+	    (values real-buffer result remote-host remote-port)
+	    (scl-map-socket-error errno :socket socket))))))
+
+(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))
+
+
+;;
+;;
+;;  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)))
+         ((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)))
+                  ((endp sockets))
+                (let ((flags (sys:sap-ref-16 fds-sap (+ base 6))))
+                  (unless (zerop (logand flags unix::pollin))
+                    (setf (state (first sockets)) :READ))))))))))
+

sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/condition.lisp

@@ -0,0 +1,237 @@
+;;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-lisp; Package: USOCKET -*-
+;;;; See LICENSE for licensing information.
+
+(in-package :usocket)
+
+;; Condition signalled by operations with unsupported arguments
+;; For trivial-sockets compatibility.
+
+(define-condition insufficient-implementation (error)
+  ((feature :initarg :feature :reader feature)
+   (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'.
+
+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."))
+  (:report (lambda (c stream)
+	     (format stream "~A in ~A is unsupported."
+		     (feature c) (context c))
+	     (when (minimum c)
+	       (format stream " Minimum version (~A) is required."
+		       (minimum c)))))
+  (: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)
+  ()
+  (:report (lambda (c stream)
+	     (format stream "~A in ~A is unimplemented."
+		     (feature c) (context c))))
+  (: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
+
+(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 ())
+       (eval-when (:load-toplevel :execute)
+         (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
+   deadline-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
+               :initform nil)
+   (errno      :initarg :errno
+               :reader usocket-errno
+               :initform 0))
+  (:report (lambda (c stream)
+             (typecase c
+               (simple-condition
+                (format stream
+                        (simple-condition-format-control (usocket-real-error c))
+                        (simple-condition-format-arguments (usocket-real-error c))))
+               (otherwise
+                (format stream "The condition ~A occurred with errno: ~D."
+                        (usocket-real-error c)
+                        (usocket-errno c))))))
+  (:documentation "Error raised when there's no other - more applicable -
+error available."))
+
+(define-usocket-condition-classes
+  (ns-try-again-condition)
+  (ns-condition))
+
+(define-condition ns-unknown-condition (ns-condition)
+  ((real-condition :initarg :real-condition
+                   :accessor ns-real-condition
+                   :initform nil))
+  (: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
+               :initform nil))
+  (:report (lambda (c stream)
+             (typecase c
+               (simple-condition
+                (format stream
+                        (simple-condition-format-control (usocket-real-error c))
+                        (simple-condition-format-arguments (usocket-real-error c))))
+               (otherwise
+                (format stream "The condition ~A occurred." (usocket-real-error c))))))
+  (:documentation "Error raised when there's no other - more applicable -
+error available."))
+
+(defmacro with-mapped-conditions ((&optional socket host-or-ip) &body body)
+  `(handler-bind ((condition
+                   #'(lambda (c) (handle-condition c ,socket ,host-or-ip))))
+     ,@body))
+
+(defparameter +unix-errno-condition-map+
+  `(((11) . ns-try-again-condition) ;; EAGAIN
+    ((35) . ns-try-again-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)
+    ((54 104) . connection-reset-error)
+    ((53 103) . 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)))
+
+(defmacro unsupported (feature context &key minimum)
+  `(cerror "Ignore it and continue" 'unsupported
+	   :feature ,feature
+	   :context ,context
+	   :minimum ,minimum))
+
+(defmacro unimplemented (feature context)
+  `(signal 'unimplemented :feature ,feature :context ,context))
+
+;;; People may want to ignore all unsupported warnings, here it is.
+(defmacro ignore-unsupported-warnings (&body body)
+  `(handler-bind ((unsupported
+                   #'(lambda (c)
+                       (declare (ignore c)) (continue))))
+     (progn ,@body)))

sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/doc/intro.dita

@@ -0,0 +1,10 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE concept PUBLIC "-//OASIS//DTD DITA 1.3 Concept//EN" "technicalContent/dtd/concept.dtd" [
+]>
+
+
+
+<concept id = "id183II900U3B"><title>Introduction</title>
+<shortdesc></shortdesc>
+<prolog><author>Chun Tian</author></prolog>
+<conbody><p></p></conbody></concept>

sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/doc/reference.dita

@@ -0,0 +1,11 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE reference PUBLIC "-//OASIS//DTD DITA 1.3 Reference//EN" "technicalContent/dtd/reference.dtd" [
+]>
+
+
+
+<reference id = "id183II700VO0"
+    xmlns:ditaarch = "http://dita.oasis-open.org/architecture/2005/">
+<title>API References</title>
+<prolog><author>Chun Tian</author></prolog>
+<refbody><section><p></p></section></refbody></reference>

sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/doc/usocket.ditamap

@@ -0,0 +1,11 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE map PUBLIC "-//OASIS//DTD DITA 1.3 Map//EN" "technicalContent/dtd/map.dtd" [
+]>
+
+
+
+<map xmlns:ditaarch = "http://dita.oasis-open.org/architecture/2005/">
+<title>USOCKET Manual</title>
+<topicref href = "intro.dita" type = "concept"><topicmeta><navtitle></navtitle></topicmeta></topicref>
+<topicref href = "reference.dita" type = "reference"><topicmeta>
+<navtitle>API References</navtitle></topicmeta></topicref></map>

sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/notes/abcl-socket.txt

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

sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/notes/active-sockets-apis.txt

@@ -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
+

sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/notes/address-apis.txt

@@ -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
+
+

sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/notes/allegro-socket.txt

@@ -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
+

sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/notes/backends.txt

@@ -0,0 +1,60 @@
+                                                                -*- text -*-
+
+$Id$
+
+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 ]
+
+ - wait-for-input-internal (new in 0.4.x)
+
+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

sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/notes/clisp-sockets.txt

@@ -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  :-(
+

sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/notes/cmucl-sockets.txt

@@ -0,0 +1,69 @@
+http://cvs2.cons.org/ftp-area/cmucl/doc/cmu-user/internet.html
+
+$Id$
+
+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    
+

sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/notes/design.txt

@@ -0,0 +1,136 @@
+
+                                                        -*- text -*-
+
+$Id$
+
+
+                  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>

sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/notes/errors.txt

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

sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/notes/lw-sockets.txt

@@ -0,0 +1,41 @@
+
+$Id$
+
+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

sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/notes/openmcl-sockets.txt

@@ -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]

sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/notes/sb-bsd-sockets.txt

@@ -0,0 +1,114 @@
+http://www.xach.com/sbcl/sb-bsd-sockets.html
+
+$Id$
+
+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

sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/notes/usock-sockets.txt

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

sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/option.lisp

@@ -0,0 +1,353 @@
+;;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-lisp; Package: USOCKET -*-
+;;;; SOCKET-OPTION, a high-level socket option get/set framework
+
+;;;; See LICENSE for licensing information.
+
+(in-package :usocket)
+
+;; put here because option.lisp is for native backend only
+(defparameter *backend* :native)
+
+;;; Interface definition
+
+(defgeneric socket-option (socket option &key)
+  (:documentation
+   "Get a socket's internal options"))
+
+(defgeneric (setf socket-option) (new-value socket option &key)
+  (:documentation
+   "Set a socket's internal options"))
+
+;;; Handling of wrong type of arguments
+
+(defmethod socket-option ((socket usocket) (option t) &key)
+  (error 'type-error :datum option :expected-type 'keyword))
+
+(defmethod (setf socket-option) (new-value (socket usocket) (option t) &key)
+  (declare (ignore new-value))
+  (socket-option socket option))
+
+(defmethod socket-option ((socket usocket) (option symbol) &key)
+  (if (keywordp option)
+    (error 'unimplemented :feature option :context 'socket-option)
+    (error 'type-error :datum option :expected-type 'keyword)))
+
+(defmethod (setf socket-option) (new-value (socket usocket) (option symbol) &key)
+  (declare (ignore new-value))
+  (socket-option socket option))
+
+;;; Socket option: RECEIVE-TIMEOUT (SO_RCVTIMEO)
+
+(defmethod socket-option ((usocket stream-usocket)
+                          (option (eql :receive-timeout)) &key)
+  (declare (ignorable option))
+  (let ((socket (socket usocket)))
+    (declare (ignorable socket))
+    #+abcl
+    () ; TODO
+    #+allegro
+    () ; TODO
+    #+clisp
+    (socket:socket-options socket :so-rcvtimeo)
+    #+clozure
+    (ccl:stream-input-timeout socket)
+    #+cmu
+    (lisp::fd-stream-timeout (socket-stream usocket))
+    #+(or ecl clasp)
+    (sb-bsd-sockets:sockopt-receive-timeout socket)
+    #+lispworks
+    (get-socket-receive-timeout socket)
+    #+mcl
+    () ; TODO
+    #+mocl
+    () ; unknown
+    #+sbcl
+    (sb-impl::fd-stream-timeout (socket-stream usocket))
+    #+scl
+    ())) ; TODO
+
+(defmethod (setf socket-option) (new-value (usocket stream-usocket)
+                                           (option (eql :receive-timeout)) &key)
+  (declare (type number new-value) (ignorable new-value option))
+  (let ((socket (socket usocket))
+        (timeout new-value))
+    (declare (ignorable socket timeout))
+    #+abcl
+    () ; TODO
+    #+allegro
+    () ; TODO
+    #+clisp
+    (socket:socket-options socket :so-rcvtimeo timeout)
+    #+clozure
+    (setf (ccl:stream-input-timeout socket) timeout)
+    #+cmu
+    (setf (lisp::fd-stream-timeout (socket-stream usocket))
+          (coerce timeout 'integer))
+    #+(or ecl clasp)
+    (setf (sb-bsd-sockets:sockopt-receive-timeout socket) timeout)
+    #+lispworks
+    (set-socket-receive-timeout socket timeout)
+    #+mcl
+    () ; TODO
+    #+mocl
+    () ; unknown
+    #+sbcl
+    (setf (sb-impl::fd-stream-timeout (socket-stream usocket))
+          (coerce timeout 'single-float))
+    #+scl
+    () ; TODO
+    new-value))
+
+;;; Socket option: SEND-TIMEOUT (SO_SNDTIMEO)
+
+(defmethod socket-option ((usocket stream-usocket)
+                          (option (eql :send-timeout)) &key)
+  (declare (ignorable option))
+  (let ((socket (socket usocket)))
+    (declare (ignorable socket))
+    #+abcl
+    () ; TODO
+    #+allegro
+    () ; TODO
+    #+clisp
+    (socket:socket-options socket :so-sndtimeo)
+    #+clozure
+    (ccl:stream-output-timeout socket)
+    #+cmu
+    (lisp::fd-stream-timeout (socket-stream usocket))
+    #+(or ecl clasp)
+    (sb-bsd-sockets:sockopt-send-timeout socket)
+    #+lispworks
+    (get-socket-send-timeout socket)
+    #+mcl
+    () ; TODO
+    #+mocl
+    () ; unknown
+    #+sbcl
+    (sb-impl::fd-stream-timeout (socket-stream usocket))
+    #+scl
+    ())) ; TODO
+
+(defmethod (setf socket-option) (new-value (usocket stream-usocket)
+                                           (option (eql :send-timeout)) &key)
+  (declare (type number new-value) (ignorable new-value option))
+  (let ((socket (socket usocket))
+        (timeout new-value))
+    (declare (ignorable socket timeout))
+    #+abcl
+    () ; TODO
+    #+allegro
+    () ; TODO
+    #+clisp
+    (socket:socket-options socket :so-sndtimeo timeout)
+    #+clozure
+    (setf (ccl:stream-output-timeout socket) timeout)
+    #+cmu
+    (setf (lisp::fd-stream-timeout (socket-stream usocket))
+          (coerce timeout 'integer))
+    #+(or ecl clasp)
+    (setf (sb-bsd-sockets:sockopt-send-timeout socket) timeout)
+    #+lispworks
+    (set-socket-send-timeout socket timeout)
+    #+mcl
+    () ; TODO
+    #+mocl
+    () ; unknown
+    #+sbcl
+    (setf (sb-impl::fd-stream-timeout (socket-stream usocket))
+          (coerce timeout 'single-float))
+    #+scl
+    () ; TODO
+    new-value))
+
+;;; Socket option: REUSE-ADDRESS (SO_REUSEADDR), for TCP server
+
+(defmethod socket-option ((usocket stream-server-usocket)
+                          (option (eql :reuse-address)) &key)
+  (declare (ignorable option))
+  (let ((socket (socket usocket)))
+    (declare (ignorable socket))
+    #+abcl
+    () ; TODO
+    #+allegro
+    () ; TODO
+    #+clisp
+    (int->bool (socket:socket-options socket :so-reuseaddr))
+    #+clozure
+    (int->bool (get-socket-option-reuseaddr socket))
+    #+cmu
+    () ; TODO
+    #+lispworks
+    (get-socket-reuse-address socket)
+    #+mcl
+    () ; TODO
+    #+mocl
+    () ; unknown
+    #+(or ecl sbcl clasp)
+    (sb-bsd-sockets:sockopt-reuse-address socket)
+    #+scl
+    ())) ; TODO
+
+(defmethod (setf socket-option) (new-value (usocket stream-server-usocket)
+                                           (option (eql :reuse-address)) &key)
+  (declare (type boolean new-value) (ignorable new-value option))
+  (let ((socket (socket usocket)))
+    (declare (ignorable socket))
+    #+abcl
+    () ; TODO
+    #+allegro
+    (socket:set-socket-options socket option new-value)
+    #+clisp
+    (socket:socket-options socket :so-reuseaddr (bool->int new-value))
+    #+clozure
+    (set-socket-option-reuseaddr socket (bool->int new-value))
+    #+cmu
+    () ; TODO
+    #+lispworks
+    (set-socket-reuse-address socket new-value)
+    #+mcl
+    () ; TODO
+    #+mocl
+    () ; unknown
+    #+(or ecl sbcl clasp)
+    (setf (sb-bsd-sockets:sockopt-reuse-address socket) new-value)
+    #+scl
+    () ; TODO
+    new-value))
+
+;;; Socket option: BROADCAST (SO_BROADCAST), for UDP client
+
+(defmethod socket-option ((usocket datagram-usocket)
+                          (option (eql :broadcast)) &key)
+  (declare (ignorable option))
+  (let ((socket (socket usocket)))
+    (declare (ignorable socket))
+    #+abcl
+    () ; TODO
+    #+allegro
+    () ; TODO
+    #+clisp
+    (int->bool (socket:socket-options socket :so-broadcast))
+    #+clozure
+    (int->bool (get-socket-option-broadcast socket))
+    #+cmu
+    () ; TODO
+    #+(or ecl clasp)
+    () ; TODO
+    #+lispworks
+    () ; TODO
+    #+mcl
+    () ; TODO
+    #+mocl
+    () ; unknown
+    #+sbcl
+    (sb-bsd-sockets:sockopt-broadcast socket)
+    #+scl
+    ())) ; TODO
+
+(defmethod (setf socket-option) (new-value (usocket datagram-usocket)
+                                           (option (eql :broadcast)) &key)
+  (declare (type boolean new-value)
+           (ignorable new-value option))
+  (let ((socket (socket usocket)))
+    (declare (ignorable socket))
+    #+abcl
+    () ; TODO
+    #+allegro
+    (socket:set-socket-options socket option new-value)
+    #+clisp
+    (socket:socket-options socket :so-broadcast (bool->int new-value))
+    #+clozure
+    (set-socket-option-broadcast socket (bool->int new-value))
+    #+cmu
+    () ; TODO
+    #+(or ecl clasp)
+    () ; TODO
+    #+lispworks
+    () ; TODO
+    #+mcl
+    () ; TODO
+    #+mocl
+    () ; unknown
+    #+sbcl
+    (setf (sb-bsd-sockets:sockopt-broadcast socket) new-value)
+    #+scl
+    () ; TODO
+    new-value))
+
+;;; Socket option: TCP-NODELAY (TCP_NODELAY), for TCP client
+
+(defmethod socket-option ((usocket stream-usocket)
+                          (option (eql :tcp-no-delay)) &key)
+  (declare (ignorable option))
+  (socket-option usocket :tcp-nodelay))
+
+(defmethod socket-option ((usocket stream-usocket)
+                          (option (eql :tcp-nodelay)) &key)
+  (declare (ignorable option))
+  (let ((socket (socket usocket)))
+    (declare (ignorable socket))
+    #+abcl
+    () ; TODO
+    #+allegro
+    () ; TODO
+    #+clisp
+    (int->bool (socket:socket-options socket :tcp-nodelay))
+    #+clozure
+    (int->bool (get-socket-option-tcp-nodelay socket))
+    #+cmu
+    ()
+    #+(or ecl clasp)
+    (sb-bsd-sockets::sockopt-tcp-nodelay socket)
+    #+lispworks
+    (int->bool (get-socket-tcp-nodelay socket))
+    #+mcl
+    () ; TODO
+    #+mocl
+    () ; unknown
+    #+sbcl
+    (sb-bsd-sockets::sockopt-tcp-nodelay socket)
+    #+scl
+    ())) ; TODO
+
+(defmethod (setf socket-option) (new-value (usocket stream-usocket)
+                                           (option (eql :tcp-no-delay)) &key)
+  (declare (ignorable option))
+  (setf (socket-option usocket :tcp-nodelay) new-value))
+
+(defmethod (setf socket-option) (new-value (usocket stream-usocket)
+                                           (option (eql :tcp-nodelay)) &key)
+  (declare (type boolean new-value)
+           (ignorable new-value option))
+  (let ((socket (socket usocket)))
+    (declare (ignorable socket))
+    #+abcl
+    () ; TODO
+    #+allegro
+    (socket:set-socket-options socket :no-delay new-value)
+    #+clisp
+    (socket:socket-options socket :tcp-nodelay (bool->int new-value))
+    #+clozure
+    (set-socket-option-tcp-nodelay socket (bool->int new-value))
+    #+cmu
+    ()
+    #+(or ecl clasp)
+    (setf (sb-bsd-sockets::sockopt-tcp-nodelay socket) new-value)
+    #+lispworks
+    (progn
+      #-(or lispworks4 lispworks5.0)
+      (comm::set-socket-tcp-nodelay socket new-value)
+      #+(or lispworks4 lispworks5.0)
+      (set-socket-tcp-nodelay socket (bool->int new-value)))
+    #+mcl
+    () ; TODO
+    #+mocl
+    () ; unknown
+    #+sbcl
+    (setf (sb-bsd-sockets::sockopt-tcp-nodelay socket) new-value)
+    #+scl
+    () ; TODO
+    new-value))
+
+(eval-when (:load-toplevel :execute)
+  (export 'socket-option))

sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/package.lisp

@@ -0,0 +1,126 @@
+;;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-lisp; Package: CL-USER -*-
+;;;; See the LICENSE file for licensing information.
+
+(defpackage :usocket
+  (:use #-genera :common-lisp
+        #+genera :future-common-lisp
+	#+abcl :java
+	:split-sequence)
+  (:export   #:*version*
+             #:*wildcard-host*
+             #:*auto-port*
+
+             #:+max-datagram-packet-size+
+
+             #:socket-connect ; socket constructors and methods
+             #:socket-listen
+             #:socket-accept
+             #:socket-close
+             #:socket-shutdown
+             #:get-local-address
+             #:get-peer-address
+             #:get-local-port
+             #:get-peer-port
+             #:get-local-name
+             #:get-peer-name
+
+             #:socket-send    ; udp function (send)
+             #:socket-receive ; udp function (receive)
+
+             #: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
+             #:with-socket-listener
+
+             #:usocket ; socket object and accessors
+             #:stream-usocket
+             #:stream-server-usocket
+             #:socket
+             #:socket-stream
+             #:datagram-usocket
+             #:socket-state ; 0.6.4
+
+             ;; predicates (for version 0.6 or 1.0 ?)
+             #:usocket-p
+             #:stream-usocket-p
+             #:stream-server-usocket-p
+             #:datagram-usocket-p
+
+             #:host-byte-order ; IPv4 utility functions
+             #:hbo-to-dotted-quad
+             #:hbo-to-vector-quad
+             #:vector-quad-to-dotted-quad
+             #:dotted-quad-to-vector-quad
+
+             #:vector-to-ipv6-host ; IPv6 utility functions
+             #:ipv6-host-to-vector
+
+             #:ip= ; IPv4+IPv6 utility function
+             #: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
+             #:socket-warning ; warnings (udp)
+
+             #:insufficient-implementation ; conditions regarding usocket support level
+             #:unsupported
+             #:unimplemented
+
+             #:socket-server
+             #:*remote-host*
+             #:*remote-port*
+
+             ;; added in 0.7.1
+             #:get-host-by-name
+             #:get-hosts-by-name
+             #:get-random-host-by-name
+             #:ns-host-not-found-error
+             #:ns-no-recovery-error
+             #:ns-try-again-condition
+             #:default-udp-handler
+             #:default-tcp-handler
+             #:echo-tcp-handler ;; server handlers
+
+             ;; added in 0.8.0
+             #:*backend*
+             #:*default-event-base*
+             #:host-to-hostname
+
+             ;; these're socket-related conditions from IOlib
+             #:ADDRESS-NOT-AVAILABLE-ERROR #:HOST-DOWN-ERROR
+             #:OPERATION-NOT-SUPPORTED-ERROR #:SOCKET-OPTION
+             #:NETWORK-DOWN-ERROR #:INVALID-SOCKET-ERROR
+             #:SOCKET-TYPE-NOT-SUPPORTED-ERROR #:DEADLINE-TIMEOUT-ERROR
+             #:SHUTDOWN-ERROR #:HOST-UNREACHABLE-ERROR
+             #:NETWORK-UNREACHABLE-ERROR #:CONNECTION-ABORTED-ERROR
+             #:BAD-FILE-DESCRIPTOR-ERROR #:PROTOCOL-NOT-SUPPORTED-ERROR
+             #:CONNECTION-RESET-ERROR #:TIMEOUT-ERROR
+             #:ADDRESS-IN-USE-ERROR #:NO-BUFFERS-ERROR
+             #:INVALID-SOCKET-STREAM-ERROR #:INTERRUPTED-CONDITION
+             #:INVALID-ARGUMENT-ERROR #:OPERATION-NOT-PERMITTED-ERROR
+             #:NETWORK-RESET-ERROR #:CONNECTION-REFUSED-ERROR
+
+             ;; added in 0.8.2
+             #:host-or-ip
+             ))

sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/server.lisp

@@ -0,0 +1,112 @@
+;;;; See LICENSE for licensing information.
+
+(in-package :usocket)
+
+(defvar *server*)
+
+(defun socket-server (host port function &optional arguments
+                      &key in-new-thread (protocol :stream)
+                           ;; for udp
+                           (timeout 1) (max-buffer-size +max-datagram-packet-size+)
+                           ;; for tcp
+                           element-type (reuse-address t) multi-threading
+                           name)
+  (let* ((real-host (or host *wildcard-host*))
+         (socket (ecase protocol
+                   (:stream
+                    (apply #'socket-listen
+                           `(,real-host ,port
+                             ,@(when element-type `(:element-type ,element-type))
+                             ,@(when reuse-address `(:reuse-address ,reuse-address)))))
+                   (:datagram
+                    (socket-connect nil nil :protocol :datagram
+                                    :local-host real-host
+                                    :local-port port)))))
+    (labels ((real-call ()
+               (ecase protocol
+                 (:stream
+                  (tcp-event-loop socket function arguments
+                                  :element-type element-type
+                                  :multi-threading multi-threading))
+                 (:datagram
+                  (udp-event-loop socket function arguments
+                                  :timeout timeout
+                                  :max-buffer-size max-buffer-size)))))
+      (if in-new-thread
+	  (values (bt:make-thread #'real-call :name (or name "USOCKET Server")) socket)
+	(progn
+	  (setq *server* socket)
+	  (real-call))))))
+
+(defvar *remote-host*)
+(defvar *remote-port*)
+
+(defun default-udp-handler (buffer) ; echo
+  (declare (type (simple-array (unsigned-byte 8) *) buffer))
+  buffer)
+
+(defun udp-event-loop (socket function &optional arguments
+                       &key timeout max-buffer-size)
+  (let ((buffer (make-array max-buffer-size :element-type '(unsigned-byte 8) :initial-element 0))
+        (sockets (list socket)))
+    (unwind-protect
+        (loop do
+          (multiple-value-bind (return-sockets real-time)
+              (wait-for-input sockets :timeout timeout)
+            (declare (ignore return-sockets))
+            (when real-time
+              (multiple-value-bind (recv n *remote-host* *remote-port*)
+                  (socket-receive socket buffer max-buffer-size)
+                (declare (ignore recv))
+                (if (plusp n)
+                    (progn
+                      (let ((reply
+                             (apply function (subseq buffer 0 n) arguments)))
+                        (when reply
+                          (replace buffer reply)
+                          (let ((n (socket-send socket buffer (length reply)
+                                                :host *remote-host*
+                                                :port *remote-port*)))
+                            (when (minusp n)
+                              (error "send error: ~A~%" n))))))
+                  (error "receive error: ~A" n))))
+            #+scl (when thread:*quitting-lisp* (return))
+            #+(and cmu mp) (mp:process-yield)))
+      (socket-close socket)
+      (values))))
+
+(defun default-tcp-handler (stream) ; null
+  (declare (type stream stream))
+  (format stream "Hello world!~%"))
+
+(defun echo-tcp-handler (stream)
+  (loop
+     (when (listen stream)
+       (let ((line (read-line stream nil)))
+	 (write-line line stream)
+	 (force-output stream)))))
+
+(defun tcp-event-loop (socket function &optional arguments
+                       &key element-type multi-threading)
+  (let ((real-function #'(lambda (client-socket &rest arguments)
+                           (unwind-protect
+                               (multiple-value-bind (*remote-host* *remote-port*) (get-peer-name client-socket)
+                                 (apply function (socket-stream client-socket) arguments))
+                             (close (socket-stream client-socket))
+                             (socket-close client-socket)
+                             nil))))
+    (unwind-protect
+        (loop do
+          (let* ((client-socket (apply #'socket-accept
+                                       `(,socket ,@(when element-type `(:element-type ,element-type)))))
+                 (client-stream (socket-stream client-socket)))
+            (if multi-threading
+                (bt:make-thread (lambda () (apply real-function client-socket arguments))
+                                :name "USOCKET Client")
+              (prog1 (apply real-function client-socket arguments)
+                (close client-stream)
+                (socket-close client-socket)))
+            #+scl (when thread:*quitting-lisp* (return))
+            #+(and cmu mp) (mp:process-yield)))
+      (socket-close socket)
+      (values))))

sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/test/package.lisp

@@ -0,0 +1,11 @@
+;;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-lisp; Package: CL-USER -*-
+;;;; See the LICENSE file for licensing information.
+
+(in-package :cl-user)
+
+(defpackage :usocket-test
+  (:use :common-lisp
+	:usocket
+	:regression-test)
+  (:export #:do-tests
+	   #:run-usocket-tests))

sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/test/test-condition.lisp

@@ -0,0 +1,28 @@
+;;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-lisp; Package: USOCKET-TEST -*-
+;;;; See LICENSE for licensing information.
+
+(in-package :usocket-test)
+
+(deftest ns-host-not-found-error.1
+  (with-caught-conditions (usocket:ns-host-not-found-error nil)
+    (usocket:socket-connect "xxx" 123)
+    t)
+  nil)
+
+(deftest timeout-error.1
+  (with-caught-conditions (usocket:timeout-error nil)
+    (usocket:socket-connect "common-lisp.net" 81 :timeout 0)
+    t)
+  nil)
+
+(deftest connection-refused-error.1
+  (with-caught-conditions (usocket:connection-refused-error nil)
+    (usocket:socket-connect "common-lisp.net" 81)
+    t)
+  nil)
+
+(deftest operation-not-permitted-error.1
+  (with-caught-conditions (usocket:operation-not-permitted-error nil)
+    (usocket:socket-listen "0.0.0.0" 81)
+    t)
+  nil)

sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/test/test-datagram.lisp

@@ -0,0 +1,124 @@
+;;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-lisp; Package: USOCKET-TEST -*-
+;;;; See LICENSE for licensing information.
+
+(in-package :usocket-test)
+
+(defvar *echo-server*)
+(defvar *echo-server-port*)
+
+(defun start-server ()
+  (multiple-value-bind (thread socket)
+      (socket-server "127.0.0.1" 0 #'identity nil
+			     :in-new-thread t
+			     :protocol :datagram)
+    (setq *echo-server* thread
+	  *echo-server-port* (get-local-port socket))))
+
+(defparameter *max-buffer-size* 32)
+
+(defvar *send-buffer*
+  (make-array *max-buffer-size* :element-type '(unsigned-byte 8) :initial-element 0))
+
+(defvar *receive-buffer*
+  (make-array *max-buffer-size* :element-type '(unsigned-byte 8) :initial-element 0))
+
+(defun clean-buffers ()
+  (fill *send-buffer* 0)
+  (fill *receive-buffer* 0))
+
+;;; UDP Send Test #1: connected socket
+(deftest udp-send.1
+  (progn
+    (unless (and *echo-server* *echo-server-port*)
+      (start-server))
+    (let ((s (socket-connect "127.0.0.1" *echo-server-port* :protocol :datagram)))
+      (clean-buffers)
+      (replace *send-buffer* #(1 2 3 4 5))
+      (socket-send s *send-buffer* 5)
+      (wait-for-input s :timeout 3)
+      (multiple-value-bind (buffer size host port)
+	  (socket-receive s *receive-buffer* *max-buffer-size*)
+	(declare (ignore buffer size host port))
+	(reduce #'+ *receive-buffer* :start 0 :end 5))))
+  15)
+
+;;; UDP Send Test #2: unconnected socket
+(deftest udp-send.2
+  (progn
+    (unless (and *echo-server* *echo-server-port*)
+      (start-server))
+    (let ((s (socket-connect nil nil :protocol :datagram)))
+      (clean-buffers)
+      (replace *send-buffer* #(1 2 3 4 5))
+      (socket-send s *send-buffer* 5 :host "127.0.0.1" :port *echo-server-port*)
+      (wait-for-input s :timeout 3)
+      (multiple-value-bind (buffer size host port)
+	  (socket-receive s *receive-buffer* *max-buffer-size*)
+	(declare (ignore buffer size host port))
+	(reduce #'+ *receive-buffer* :start 0 :end 5))))
+  15)
+
+(deftest mark-h-david ; Mark H. David's remarkable UDP test code
+  (let* ((host "localhost")
+	 (port 1111)
+	 (server-sock
+	  (socket-connect nil nil :protocol ':datagram :local-host host :local-port port))
+	 (client-sock
+	  (socket-connect host port :protocol ':datagram))
+	 (octet-vector
+	  (make-array 2 :element-type '(unsigned-byte 8) :initial-contents `(,(char-code #\O) ,(char-code #\K))))
+	 (recv-octet-vector
+	  (make-array 2 :element-type '(unsigned-byte 8))))
+    (socket-send client-sock octet-vector 2)
+    (socket-receive server-sock recv-octet-vector 2)
+    (prog1 (and (equalp octet-vector recv-octet-vector)
+		recv-octet-vector)
+      (socket-close server-sock)
+      (socket-close client-sock)))
+  #(79 75))
+
+(deftest frank-james ; Frank James' test code for LispWorks/UDP
+  (with-caught-conditions (#+win32 CONNECTION-RESET-ERROR
+			   #-win32 CONNECTION-REFUSED-ERROR
+			   nil)
+    (let ((sock (socket-connect "localhost" 1234
+                                        :protocol ':datagram :element-type '(unsigned-byte 8))))
+      (unwind-protect
+          (progn
+            (socket-send sock (make-array 16 :element-type '(unsigned-byte 8) :initial-element 0) 16)
+            (let ((buffer (make-array 16 :element-type '(unsigned-byte 8) :initial-element 0)))
+              (socket-receive sock buffer 16)))
+        (socket-close sock))))
+  nil)
+
+(defun frank-wfi-test ()
+  (let ((s (socket-connect nil nil :protocol :datagram
+                                   :element-type '(unsigned-byte 8)
+                                   :local-port 8001)))
+    (unwind-protect
+        (do ((i 0 (1+ i))
+             (buffer (make-array 1024 :element-type '(unsigned-byte 8)
+                                 :initial-element 0))
+             (now (get-universal-time))
+             (done nil))
+            ((or done (= i 4))
+             nil)
+          (format t "~Ds ~D Waiting state ~S~%" (- (get-universal-time) now) i (usocket::state s))
+          (when (wait-for-input s :ready-only t :timeout 5)
+            (format t "~D state ~S~%" i (usocket::state s))
+            (handler-bind 
+                ((error (lambda (c) 
+                          (format t "socket-receive error: ~A~%" c)
+                          (break)
+                          nil)))
+              (multiple-value-bind (buffer count remote-host remote-port)
+                  (socket-receive s buffer 1024)
+                (handler-bind
+                    ((error (lambda (c)
+                               (format t "socket-send error: ~A~%" c)
+                               (break))))                             
+                  (when buffer 
+                    (socket-send s (subseq buffer 0 count) count
+                                         :host remote-host
+                                         :port remote-port)))))))
+      (socket-close s))))

sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/test/test-usocket.lisp

@@ -0,0 +1,179 @@
+;;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-lisp; Package: USOCKET-TEST -*-
+;;;; See LICENSE for licensing information.
+
+;;;; Usage: (usoct:run-usocket-tests) or (usoct:do-tests)
+
+(in-package :usocket-test)
+
+(defparameter +non-existing-host+ "1.2.3.4")
+(defparameter +unused-local-port+ 15213)
+
+(defparameter *fake-usocket*
+  (usocket::make-stream-socket :socket :my-socket
+                               :stream :my-stream))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defvar *common-lisp-net*
+    (get-host-by-name "common-lisp.net")))
+
+(defvar *local-ip*)
+
+(defmacro with-caught-conditions ((expect throw) &body body)
+  `(catch 'caught-error
+     (handler-case
+         (handler-bind ((unsupported
+                         #'(lambda (c)
+                             (declare (ignore c)) (continue))))
+           (progn ,@body))
+       (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)))
+       (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 (socket *fake-usocket*) :my-socket)
+(deftest make-socket.2 (socket-stream *fake-usocket*) :my-stream)
+
+(deftest socket-no-connect.1
+  (with-caught-conditions (socket-error nil)
+    (socket-connect "127.0.0.1" +unused-local-port+ :timeout 1)
+    t)
+  nil)
+
+(deftest socket-no-connect.2
+  (with-caught-conditions (socket-error nil)
+    (socket-connect #(127 0 0 1) +unused-local-port+ :timeout 1)
+    t)
+  nil)
+
+(deftest socket-no-connect.3
+  (with-caught-conditions (socket-error nil)
+    (socket-connect 2130706433 +unused-local-port+ :timeout 1) ;; == #(127 0 0 1)
+    t)
+  nil)
+
+(deftest socket-failure.1
+  (with-caught-conditions (timeout-error nil)
+    (socket-connect 2130706433 +unused-local-port+ :timeout 1) ;; == #(127 0 0 1)
+    :unreach)
+  nil)
+
+(deftest socket-failure.2
+  (with-caught-conditions (timeout-error nil)
+    (socket-connect +non-existing-host+ 80 :timeout 1) ;; 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 (socket-connect "common-lisp.net" 80)))
+      (unwind-protect
+          (when (typep sock 'usocket) t)
+        (socket-close sock))))
+  t)
+
+(deftest socket-connect.2
+  (with-caught-conditions (nil nil)
+    (let ((sock (socket-connect *common-lisp-net* 80)))
+      (unwind-protect
+          (when (typep sock 'usocket) t)
+        (socket-close sock))))
+  t)
+
+(deftest socket-connect.3
+  (with-caught-conditions (nil nil)
+    (let ((sock (socket-connect (usocket::host-byte-order *common-lisp-net*) 80)))
+      (unwind-protect
+          (when (typep sock 'usocket) t)
+        (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 (socket-connect "common-lisp.net" 80)))
+      (unwind-protect
+          (progn
+            (format (socket-stream sock)
+                    "GET / HTTP/1.0~2%")
+            (force-output (socket-stream sock))
+            (subseq (read-line (socket-stream sock)) 0 4))
+        (socket-close sock))))
+  "HTTP")
+
+(deftest socket-name.1
+  (with-caught-conditions (nil nil)
+    (let ((sock (socket-connect *common-lisp-net* 80)))
+      (unwind-protect
+          (get-peer-address sock)
+        (socket-close sock))))
+  #.*common-lisp-net*)
+
+(deftest socket-name.2
+  (with-caught-conditions (nil nil)
+    (let ((sock (socket-connect *common-lisp-net* 80)))
+      (unwind-protect
+          (get-peer-port sock)
+        (socket-close sock))))
+  80)
+
+(deftest socket-name.3
+  (with-caught-conditions (nil nil)
+    (let ((sock (socket-connect *common-lisp-net* 80)))
+      (unwind-protect
+          (get-peer-name sock)
+        (socket-close sock))))
+  #.*common-lisp-net* 80)
+
+#+ignore
+(deftest socket-name.4
+  (with-caught-conditions (nil nil)
+    (let ((sock (socket-connect *common-lisp-net* 80)))
+      (unwind-protect
+          (equal (get-local-address sock) *local-ip*)
+        (socket-close sock))))
+  t)
+
+(deftest socket-shutdown.1
+    (with-caught-conditions (nil nil)
+      (let ((sock (socket-connect *common-lisp-net* 80)))
+        (unwind-protect
+             (usocket::ignore-unsupported-warnings
+               (socket-shutdown sock :input))
+          (socket-close sock))
+        t))
+  t)
+
+(deftest socket-shutdown.2
+    (with-caught-conditions (nil nil)
+      (let ((sock (socket-connect *common-lisp-net* 80)))
+        (unwind-protect
+             (usocket::ignore-unsupported-warnings
+               (socket-shutdown sock :output))
+          (socket-close sock))
+        t))
+  t)
+
+(defun run-usocket-tests ()
+  (do-tests))

sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/test/udp-one-shot.lisp

@@ -0,0 +1,86 @@
+;;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-lisp; Package: USOCKET-TEST -*-
+
+(in-package :usocket-test)
+
+;; Test code from "INVALID-ARGUMENT-ERROR on socket-receive (#48)"
+
+;; Author: @4lph4-Ph4un
+;; Environment: SBCL 1.4.16, WSL on Windows 10
+
+(defun UDP-one-shot-V1 (&optional (port 1232))
+  (let ((socket (usocket:socket-connect
+		 nil
+		 nil
+		 :protocol     :datagram
+		 :element-type '(unsigned-byte 8)
+		 :local-host   "127.0.0.1"
+		 :local-port   port))
+	(buffer (make-array 8 :element-type '(unsigned-byte 8))))
+    (unwind-protect
+	 (multiple-value-bind (received size remote-host remote-port)
+	     ;; NOTE: An explicit buffer can be given. If the length
+	     ;; is nil buffer's length will be used.
+	     (usocket:socket-receive socket buffer 8)
+	   (format t "~A~%" received)
+	   (usocket:socket-send socket
+				(reverse received)
+				size
+				:host remote-host
+				:port remote-port))
+      (usocket:socket-close socket))))
+
+#|
+Backtrace:
+  0: (USOCKET::HANDLE-CONDITION #<SB-BSD-SOCKETS:INVALID-ARGUMENT-ERROR {100375B833}> #<USOCKET:DATAGRAM-USOCKET {100375B773}>)
+      Locals:
+        CONDITION = #<SB-BSD-SOCKETS:INVALID-ARGUMENT-ERROR {100375B833}>
+        SOCKET = #<USOCKET:DATAGRAM-USOCKET {100375B773}>
+  1: (SB-KERNEL::%SIGNAL #<SB-BSD-SOCKETS:INVALID-ARGUMENT-ERROR {100375B833}>)
+      Locals:
+        CONDITION = #<SB-BSD-SOCKETS:INVALID-ARGUMENT-ERROR {100375B833}>
+        HANDLER-CLUSTERS = (((#<SB-KERNEL::CLASSOID-CELL SB-IMPL::EVAL-ERROR> . #<CLOSURE # {7F0C5FD9DE0B}>)) ((#<SB-KERNEL::CLASSOID-CELL SB-C:COMPILER-ERROR> . #<FUNCTION # {5222748B}>)) ..)
+  2: (ERROR SB-BSD-SOCKETS:INVALID-ARGUMENT-ERROR :ERRNO 22 :SYSCALL "recvfrom")
+      Locals:
+        CONDITION = #<SB-BSD-SOCKETS:INVALID-ARGUMENT-ERROR {100375B833}>
+        #:G8039 = SB-BSD-SOCKETS:INVALID-ARGUMENT-ERROR
+        SB-DEBUG::MORE = (:ERRNO 22 :SYSCALL "recvfrom")
+  3: (SB-BSD-SOCKETS:SOCKET-ERROR "recvfrom" 22)
+      Locals:
+        ERRNO = 22
+        WHERE = "recvfrom"
+  4: ((FLET SB-BSD-SOCKETS::WITH-SOCKET-ADDR-THUNK :IN SB-BSD-SOCKETS:SOCKET-RECEIVE) #<SB-ALIEN-INTERNALS:ALIEN-VALUE :SAP #X7F0C58001230 :TYPE (* (SB-ALIEN:STRUCT SB-BSD-SOCKETS-INTERNAL::SOCKADDR-IN (SB..
+      Locals:
+        SB-BSD-SOCKETS::COPY-BUFFER = #<SB-ALIEN-INTERNALS:ALIEN-VALUE :SAP #X7F0C58001250 :TYPE (* (ARRAY (SB-ALIEN:UNSIGNED 8) 1))>
+        SB-BSD-SOCKETS::SIZE = 16
+        SB-BSD-SOCKETS::SOCKADDR = #<SB-ALIEN-INTERNALS:ALIEN-VALUE :SAP #X7F0C58001230 :TYPE (* ..)>
+  5: (SB-BSD-SOCKETS::CALL-WITH-SOCKET-ADDR #<SB-BSD-SOCKETS:INET-SOCKET 127.0.0.1:1232, fd: 3 {100375B203}> NIL #<CLOSURE (FLET SB-BSD-SOCKETS::WITH-SOCKET-ADDR-THUNK :IN SB-BSD-SOCKETS:SOCKET-RECEIVE) {7..
+      Locals:
+        SOCKADDR = #<SB-ALIEN-INTERNALS:ALIEN-VALUE :SAP #X7F0C58001230 :TYPE (* ..)>
+        SOCKADDR-ARGS = NIL
+        SOCKET = #<SB-BSD-SOCKETS:INET-SOCKET 127.0.0.1:1232, fd: 3 {100375B203}>
+        THUNK = #<CLOSURE (FLET SB-BSD-SOCKETS::WITH-SOCKET-ADDR-THUNK :IN SB-BSD-SOCKETS:SOCKET-RECEIVE) {7F0C5FD9DB8B}>
+  6: ((:METHOD SB-BSD-SOCKETS:SOCKET-RECEIVE (SB-BSD-SOCKETS:SOCKET T T)) #<SB-BSD-SOCKETS:INET-SOCKET 127.0.0.1:1232, fd: 3 {100375B203}> #(0 0 0 0 0 0 ...) 8 :OOB NIL :PEEK NIL :WAITALL NIL :DONTWAIT NIL..
+      Locals:
+        #:.DEFAULTING-TEMP. = (UNSIGNED-BYTE 8)
+        SB-BSD-SOCKETS::BUFFER = #(0 0 0 0 0 0 ...)
+        SB-BSD-SOCKETS::BUFFER#1 = #(0 0 0 0 0 0 ...)
+        SB-BSD-SOCKETS::DONTWAIT = NIL
+        SB-BSD-SOCKETS::ELEMENT-TYPE = (UNSIGNED-BYTE 8)
+        LENGTH = 8
+        LENGTH#1 = 8
+        SB-BSD-SOCKETS::OOB = NIL
+        SB-BSD-SOCKETS::PEEK = NIL
+        SB-BSD-SOCKETS:SOCKET = #<SB-BSD-SOCKETS:INET-SOCKET 127.0.0.1:1232, fd: 3 {100375B203}>
+        SB-BSD-SOCKETS::WAITALL = NIL
+  7: ((:METHOD USOCKET:SOCKET-RECEIVE (USOCKET:DATAGRAM-USOCKET T T)) #<USOCKET:DATAGRAM-USOCKET {100375B773}> #(0 0 0 0 0 0 ...) 8 :ELEMENT-TYPE (UNSIGNED-BYTE 8)) [fast-method]
+      Locals:
+        USOCKET::BUFFER = #(0 0 0 0 0 0 ...)
+        USOCKET::ELEMENT-TYPE = (UNSIGNED-BYTE 8)
+        LENGTH = 8
+        USOCKET:SOCKET = #<USOCKET:DATAGRAM-USOCKET {100375B773}>
+  8: (MASTER-CLASS/SRC/SERVER-03:UDP-ONE-SHOT-V1 1232)
+      Locals:
+        PORT = 1232
+        SOCKET = #<USOCKET:DATAGRAM-USOCKET {100375B773}>
+|#
+

sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/test/wait-for-input.lisp

@@ -0,0 +1,140 @@
+;;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-lisp; Package: USOCKET-TEST -*-
+;;;; See LICENSE for licensing information.
+
+(in-package :usocket-test)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defparameter *wait-for-input-timeout* 2))
+
+(deftest wait-for-input.1
+  (with-caught-conditions (nil nil)
+    (let ((sock (usocket:socket-connect *common-lisp-net* 80))
+          (time (get-universal-time)))
+      (unwind-protect
+          (progn (usocket:wait-for-input sock :timeout *wait-for-input-timeout*)
+            (- (get-universal-time) time))
+        (usocket:socket-close sock))))
+  #.*wait-for-input-timeout*)
+
+(deftest wait-for-input.2
+  (with-caught-conditions (nil nil)
+    (let ((sock (usocket:socket-connect *common-lisp-net* 80))
+          (time (get-universal-time)))
+      (unwind-protect
+          (progn (usocket:wait-for-input sock :timeout *wait-for-input-timeout* :ready-only t)
+            (- (get-universal-time) time))
+        (usocket:socket-close sock))))
+  #.*wait-for-input-timeout*)
+
+(deftest wait-for-input.3
+  (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~2%")
+            (force-output (usocket:socket-stream sock))
+            (usocket:wait-for-input sock :timeout *wait-for-input-timeout*)
+            (subseq (read-line (usocket:socket-stream sock)) 0 4))
+        (usocket:socket-close sock))))
+  "HTTP")
+
+;;; Advanced W-F-I tests by Elliott Slaughter <elliottslaughter@gmail.com>
+
+(defvar *socket-server-port* 0)
+(defvar *socket-server-listen* nil)
+(defvar *socket-server-connection*)
+(defvar *socket-client-connection*)
+(defvar *output-p* t)
+
+(defun stage-1 ()
+  (unless *socket-server-listen*
+    (setf *socket-server-listen*
+	  (socket-listen *wildcard-host* 0 :element-type '(unsigned-byte 8)))
+    (setf *socket-server-port* (get-local-port *socket-server-listen*)))
+
+  (setf *socket-server-connection*
+	(when (wait-for-input *socket-server-listen* :timeout 0 :ready-only t)
+	  (socket-accept *socket-server-listen*)))
+  
+  (when *output-p* ; should be NIL
+    (format t "First time (before client connects) is ~s.~%"
+	    *socket-server-connection*))
+
+  *socket-server-connection*)
+
+;; TODO: original test code have addition (:TIMEOUT 0) when doing the SOCKET-CONNECT,
+;; it seems cannot work on SBCL/Windows, need to investigate, but here we ignore it.
+
+(defun stage-2 ()
+  (setf *socket-client-connection*
+        (socket-connect "localhost" *socket-server-port* :protocol :stream
+			 :element-type '(unsigned-byte 8)))
+  (setf *socket-server-connection*
+	(when (wait-for-input *socket-server-listen* :timeout 0 :ready-only t)
+	  #+(and win32 (or lispworks ecl sbcl))
+          (when *output-p*
+            (format t "%READY-P: ~D~%" (usocket::%ready-p *socket-server-listen*)))
+	  (socket-accept *socket-server-listen*)))
+
+  (when *output-p* ; should be a usocket object
+    (format t "Second time (after client connects) is ~s.~%"
+	    *socket-server-connection*))
+
+  *socket-server-connection*)
+
+(defun stage-3 ()
+  (setf *socket-server-connection*
+	(when (wait-for-input *socket-server-listen* :timeout 0 :ready-only t)
+	  #+(and win32 (or lispworks ecl sbcl))
+          (when *output-p*
+            (format t "%READY-P: ~D~%" (usocket::%ready-p *socket-server-listen*)))
+	  (socket-accept *socket-server-listen*)))
+
+  (when *output-p* ; should be NIL again
+    (format t "Third time (before second client) is ~s.~%"
+	    *socket-server-connection*))
+
+  *socket-server-connection*)
+
+(deftest elliott-slaughter.1
+    (let ((*output-p* nil))
+      (let* ((s-1 (stage-1)) (s-2 (stage-2)) (s-3 (stage-3)))
+	(prog1 (and (null s-1) (usocket::usocket-p s-2) (null s-3))
+	  (socket-close *socket-server-listen*)
+	  (setf *socket-server-listen* nil))))
+  t)
+
+#|
+
+Issue elliott-slaughter.2 (WAIT-FOR-INPUT/win32 on TCP socket)
+
+W-F-I correctly found the inputs, but :READY-ONLY didn't work.
+
+|#
+(defun receive-each (connections)
+  (let ((ready (usocket:wait-for-input connections :timeout 0 :ready-only t)))
+    (loop for connection in ready
+       collect (read-line (usocket:socket-stream connection)))))
+
+(defun receive-all (connections)
+  (loop for messages = (receive-each connections)
+     then (receive-each connections)
+     while messages append messages))
+
+(defun send (connection message)
+  (format (usocket:socket-stream connection) "~a~%" message)
+  (force-output (usocket:socket-stream connection)))
+
+(defun server ()
+  (let* ((listen (usocket:socket-listen usocket:*wildcard-host* 12345))
+         (connection (usocket:socket-accept listen)))
+    (loop for messages = (receive-all connection) then (receive-all connection)
+       do (format t "Got messages:~%~s~%" messages)
+       do (sleep 1/50))))
+
+(defun client ()
+  (let ((connection (usocket:socket-connect "localhost" 12345)))
+    (loop for i from 0
+       do (send connection (format nil "This is message ~a." i))
+       do (sleep 1/100))))

sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/usocket-server.asd

@@ -0,0 +1,14 @@
+;;;; -*- Mode: Lisp -*-
+;;;;
+;;;; See the LICENSE file for licensing information.
+
+(in-package :asdf)
+
+(defsystem usocket-server
+    :name "usocket (server)"
+    :author "Chun Tian (binghe)"
+    :version (:read-file-form "version.sexp")
+    :licence "MIT"
+    :description "Universal socket library for Common Lisp (server side)"
+    :depends-on (:usocket :bordeaux-threads)
+    :components ((:file "server")))

sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/usocket-test.asd

@@ -0,0 +1,23 @@
+;;;; -*- Mode: Lisp -*-
+
+;;;; See the LICENSE file for licensing information.
+
+(defsystem usocket-test
+    :name "usocket test"
+    :author "Erik Enge"
+    :maintainer "Chun Tian (binghe)"
+    :version (:read-file-form "version.sexp")
+    :licence "MIT"
+    :description "Tests for usocket"
+    :depends-on (:usocket-server
+		 :rt)
+    :components ((:module "test"
+		  :serial t
+		  :components ((:file "package")
+			       (:file "test-usocket")
+			       (:file "test-condition")
+			       (:file "test-datagram")
+			       (:file "wait-for-input")))))
+
+(defmethod perform ((op test-op) (c (eql (find-system :usocket-test))))
+  (funcall (intern "DO-TESTS" "USOCKET-TEST")))

sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/usocket.asd

@@ -0,0 +1,58 @@
+;;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-lisp; -*-
+;;;;
+;;;; See the LICENSE file for licensing information.
+
+(in-package :asdf)
+
+;;; NOTE: the key "art" here is, no need to recompile any file when switching
+;;; between a native backend and IOlib backend. -- Chun Tian (binghe)
+
+#+sample
+(pushnew :usocket-iolib *features*)
+
+(defsystem usocket
+    :name "usocket (client, with server symbols)"
+    :author "Erik Enge & Erik Huelsmann"
+    :maintainer "Chun Tian (binghe) & Hans Huebner"
+    :version (:read-file-form "version.sexp")
+    :licence "MIT"
+    :description "Universal socket library for Common Lisp"
+    :depends-on (:split-sequence
+		 #+(and (or sbcl ecl)
+			(not usocket-iolib)) :sb-bsd-sockets
+		 #+usocket-iolib :iolib)
+    :components ((:file "package")
+		 (:module "vendor" :depends-on ("package")
+		  :components (#+mcl (:file "kqueue")
+			       #+mcl (:file "OpenTransportUDP")))
+		 (:file "usocket" :depends-on ("vendor"))
+		 (:file "condition" :depends-on ("usocket"))
+		 #-usocket-iolib
+		 (:module "backend" :depends-on ("condition")
+		  :components (#+abcl		(:file "abcl")
+			       #+(or allegro cormanlisp)
+						(:file "allegro")
+			       #+clisp		(:file "clisp")
+			       #+(or openmcl clozure)
+						(:file "openmcl")
+			       #+clozure	(:file "clozure" :depends-on ("openmcl"))
+			       #+cmu		(:file "cmucl")
+			       #+(or sbcl ecl clasp)
+                                                (:file "sbcl")
+			       #+ecl		(:file "ecl" :depends-on ("sbcl"))
+			       #+clasp		(:file "clasp" :depends-on ("sbcl"))
+			       #+lispworks	(:file "lispworks")
+			       #+mcl		(:file "mcl")
+			       #+mocl		(:file "mocl")
+			       #+scl		(:file "scl")
+			       #+genera		(:file "genera")
+			       #+mezzano	(:file "mezzano")))
+		 #-usocket-iolib
+		 (:file "option" :depends-on ("backend"))
+		 #+usocket-iolib
+		 (:module "backend" :depends-on ("condition")
+		  :components ((:file "iolib")))))
+
+(defmethod perform ((op test-op) (c (eql (find-system :usocket))))
+  (oos 'load-op ':usocket-test)
+  (oos 'test-op ':usocket-test))

sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/usocket.lisp

@@ -0,0 +1,727 @@
+;;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-lisp; Package: USOCKET -*-
+;;;; 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.  If this variable is passed to socket-listen, IPv6 capable
+  systems will also listen for IPv6 connections.")
+
+(defparameter *auto-port* 0
+  "Port number to pass when an auto-assigned port number is wanted.")
+
+(defparameter *version* #.(asdf:component-version (asdf:find-system :usocket))
+  "usocket version string")
+
+(defconstant +max-datagram-packet-size+ 65507
+  "The theoretical maximum amount of data in a UDP datagram.
+
+The IPv4 UDP packets have a 16-bit length constraint, and IP+UDP header has 28-byte.
+
+IP_MAXPACKET = 65535,       /* netinet/ip.h */
+sizeof(struct ip) = 20,     /* netinet/ip.h */
+sizeof(struct udphdr) = 8,  /* netinet/udp.h */
+
+65535 - 20 - 8 = 65507
+
+(But for UDP broadcast, the maximum message size is limited by the MTU size of the underlying link)")
+
+(defclass usocket ()
+  ((socket
+    :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
+    :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 win32 (or sbcl ecl lispworks))
+   (%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.
+
+Sockets should be closed using the `socket-close' method."))
+
+(defgeneric socket-state (socket)
+  (:documentation "NIL          - not ready
+:READ        - ready to read
+:READ-WRITE  - ready to read and write
+:WRITE       - ready to write"))
+
+(defmethod socket-state ((socket usocket))
+  (state socket))
+
+(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'."))
+  (:documentation "Socket which listens for stream connections to
+be initiated from remote sockets."))
+
+(defclass datagram-usocket (usocket)
+  ((connected-p :type boolean
+                :accessor connected-p
+                :initarg :connected-p)
+   #+(or cmu scl lispworks mcl
+         (and clisp ffi (not rawsock)))
+   (%open-p     :type boolean
+                :accessor %open-p
+                :initform t
+                :documentation "Flag to indicate if usocket is open,
+for GC on implementions operate on raw socket fd.")
+   #+(or lispworks mcl
+         (and clisp ffi (not rawsock)))
+   (recv-buffer :documentation "Private RECV buffer.")
+   #+(or lispworks mcl)
+   (send-buffer :documentation "Private SEND buffer."))
+  (:documentation "UDP (inet-datagram) socket"))
+
+(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))
+
+(defun make-socket (&key socket)
+  "Create a usocket socket type from implementation specific socket."
+  (unless socket
+    (error 'invalid-socket-error))
+  (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'."))
+
+(defmethod socket-close :before ((usocket usocket))
+  (when (wait-list usocket)
+    (remove-waiter (wait-list usocket) usocket)))
+
+;; also see http://stackoverflow.com/questions/4160347/close-vs-shutdown-socket
+(defgeneric socket-shutdown (usocket direction)
+  (:documentation "Shutdown communication on the socket in DIRECTION.
+
+After a shutdown no input and/or output of the indicated DIRECTION
+can be performed on the `usocket'.
+
+DIRECTION should be either :INPUT or :OUTPUT or :IO"))
+
+(defgeneric socket-send (usocket buffer length &key host port)
+  (:documentation "Send packets through a previously opend `usocket'."))
+
+(defgeneric socket-receive (usocket buffer length &key)
+  (:documentation "Receive packets from a previously opend `usocket'.
+
+Returns 4 values: (values buffer size host port)"))
+
+(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."))
+
+(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)
+             ,@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 ,@socket-connect-args))
+     ,(if (null stream-var)
+          `(progn ,@body)
+           `(let ((,stream-var (socket-stream ,socket-var)))
+              ,@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)
+     ,@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 ,@socket-listen-args))
+     ,@body))
+
+(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
+
+(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 wl) ; wl is returned
+      (add-waiter wl x))))
+
+(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 wait-list 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
+                                         &aux (single-socket-p
+                                               (usocket-p socket-or-sockets)))
+  "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.
+
+Without the READY-ONLY arg, WAIT-FOR-INPUT will return all sockets in
+the original list you passed it. This prevents a new list from being
+consed up. Some users of USOCKET were reluctant to use it if it
+wouldn't behave that way, expecting it to cost significant performance
+to do the associated garbage collection.
+
+Without the READY-ONLY arg, you need to check the socket STATE slot for
+the values documented in usocket.lisp in the usocket class."
+
+  ;; for NULL sockets, return NIL with respect of TIMEOUT.
+  (when (null socket-or-sockets)
+    (when timeout
+      (sleep timeout))
+    (return-from wait-for-input nil))
+
+  ;; create a new wait-list if it's not created by the caller.
+  (unless (wait-list-p socket-or-sockets)
+    ;; OPTIMIZATION: in case socket-or-sockets is an atom, create the wait-list
+    ;; only once and store it into the usocket itself.   
+    (let ((wl (if (and single-socket-p
+                       (wait-list socket-or-sockets))
+                  (wait-list socket-or-sockets) ; reuse the per-usocket wait-list
+                (make-wait-list (if (listp socket-or-sockets)
+                                    socket-or-sockets (list socket-or-sockets))))))
+      (multiple-value-bind (sockets to-result)
+          (wait-for-input wl :timeout timeout :ready-only ready-only)
+        ;; in case of single socket, keep the wait-list
+        (unless single-socket-p
+          (remove-all-waiters wl))
+        (return-from wait-for-input
+          (values (if ready-only sockets socket-or-sockets) to-result)))))
+
+  (let* ((start (get-internal-real-time))
+         (sockets-ready 0))
+    (dolist (x (wait-list-waiters socket-or-sockets))
+      (when (setf (state x)
+                  #+(and win32 (or sbcl ecl)) nil ; they cannot rely on LISTEN
+                  #-(and win32 (or sbcl ecl))
+                  (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 theready- socket isn't ready, but there's space left in the
+    ;; buffer.  socket-or-sockets is not destructed.
+    (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))))))
+      ;; two return values:
+      ;; 1) the original wait-list, or available sockets (ready-only)
+      ;; 2) remaining timeout
+      (values (cond (ready-only
+                     (cond (single-socket-p
+                            (if (null (state (car (wait-list-waiters socket-or-sockets))))
+                                nil ; nothing left if the only socket is not waiting
+                              (wait-list-waiters socket-or-sockets)))
+                           (t (remove-if #'null (wait-list-waiters socket-or-sockets) :key #'state))))
+                    (t socket-or-sockets))
+              to-result))))
+
+;;
+;; 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 ,start))
+
+(defmacro ip-to-octet-buffer (ip buffer &key (start 0))
+  `(integer-to-octet-buffer (host-byte-order ,ip) ,buffer 4 :start ,start))
+
+(defmacro port-from-octet-buffer (buffer &key (start 0))
+  `(octet-buffer-to-integer ,buffer 2 :start ,start))
+
+(defmacro ip-from-octet-buffer (buffer &key (start 0))
+  `(octet-buffer-to-integer ,buffer 4 :start ,start))
+
+;;
+;; IPv4 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 ip-address-string-p (string)
+  "Return a true value if the given string could be an IP address."
+  (every (lambda (char)
+           (or (digit-char-p char)
+               (eql char #\.)))
+         string))
+
+(defun hbo-to-dotted-quad (integer) ; exported
+  "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) ; exported
+  "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) ; exported
+  (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) ; exported
+  (let ((list (list-of-strings-to-integers (split-sequence #\. string))))
+    (vector (first list) (second list) (third list) (fourth list))))
+
+(defgeneric host-byte-order (address)) ; exported
+
+(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 #\. string))))
+    (+ (* (first list) 256 256 256) (* (second list) 256 256)
+       (* (third list) 256) (fourth list))))
+
+(defmethod host-byte-order ((vector vector)) ; IPv4 only
+  "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) ; this assume input integer is already host-byte-order
+
+;;
+;; IPv6 utility functions
+;;
+
+(defun vector-to-ipv6-host (vector) ; exported
+  (with-output-to-string (*standard-output*)
+    (loop with zeros-collapsed-p
+          with collapsing-zeros-p
+          for i below 16 by 2
+          for word = (+ (ash (aref vector i) 8)
+                        (aref vector (1+ i)))
+          do (cond
+               ((and (zerop word)
+                     (not collapsing-zeros-p)
+                     (not zeros-collapsed-p))
+                (setf collapsing-zeros-p t))
+               ((or (not (zerop word))
+                    zeros-collapsed-p)
+                (when collapsing-zeros-p
+                  (write-string ":")
+                  (setf collapsing-zeros-p nil
+                        zeros-collapsed-p t))
+                (format t "~:[~;:~]~X" (plusp i) word)))
+          finally (when collapsing-zeros-p
+                    (write-string "::")))))
+
+(defun split-ipv6-address (string)
+  (let ((pos 0)
+        word
+        double-colon-seen-p
+        words-before-double-colon
+        words-after-double-colon)
+    (loop
+      (multiple-value-setq (word pos) (parse-integer string :radix 16 :junk-allowed t :start pos))
+      (labels ((at-end-p ()
+                 (= pos (length string)))
+               (looking-at-colon-p ()
+                 (char= (char string pos) #\:))
+               (ensure-colon ()
+                 (unless (looking-at-colon-p)
+                   (error "unsyntactic IPv6 address string ~S, expected a colon at position ~D"
+                          string pos))
+                 (incf pos)))
+        (cond
+          ((null word)
+           (when double-colon-seen-p
+             (error "unsyntactic IPv6 address string ~S, can only have one double-colon filler mark"
+                    string))
+           (setf double-colon-seen-p t))
+          (double-colon-seen-p
+           (push word words-after-double-colon))
+          (t
+           (push word words-before-double-colon)))
+        (if (at-end-p)
+            (return (list (nreverse words-before-double-colon) (nreverse words-after-double-colon)))
+            (ensure-colon))))))
+
+(defun ipv6-host-to-vector (string) ; exported
+  (assert (> (length string) 2) ()
+          "Unsyntactic IPv6 address literal ~S, expected at least three characters" string)
+  (destructuring-bind (words-before-double-colon words-after-double-colon)
+      (split-ipv6-address (concatenate 'string
+                                       (when (eql (char string 0) #\:)
+                                         "0")
+                                       string
+                                       (when (eql (char string (1- (length string))) #\:)
+                                         "0")))
+    (let ((number-of-words-specified (+ (length words-before-double-colon) (length words-after-double-colon))))
+      (assert (<= number-of-words-specified 8) ()
+              "Unsyntactic IPv6 address literal ~S, too many colon separated address components" string)
+      (assert (or (= number-of-words-specified 8) words-after-double-colon) ()
+              "Unsyntactic IPv6 address literal ~S, too few address components and no double-colon filler found" string)
+      (loop with vector = (make-array 16 :element-type '(unsigned-byte 8))
+            for i below 16 by 2
+            for word in (append words-before-double-colon
+                                (make-list (- 8 number-of-words-specified) :initial-element 0)
+                                words-after-double-colon)
+            do (setf (aref vector i) (ldb (byte 8 8) word)
+                     (aref vector (1+ i)) (ldb (byte 8 0) word))
+            finally (return vector)))))
+
+;; exported since 0.8.0
+(defun host-to-hostname (host) ; host -> string
+  "Translate a string, vector quad or 16 byte IPv6 address to a
+stringified hostname."
+  (etypecase host
+    (string host)      ; IPv4 or IPv6
+    ((or (vector t 4)  ; IPv4
+         (array (unsigned-byte 8) (4)))
+     (vector-quad-to-dotted-quad host))
+    ((or (vector t 16) ; IPv6
+         (array (unsigned-byte 8) (16)))
+     (vector-to-ipv6-host host))
+    (integer (hbo-to-dotted-quad host)) ; integer input is IPv4 only
+    (null "0.0.0.0")))                  ; null is IPv4
+
+(defun ip= (ip1 ip2) ; exported
+  (etypecase ip1
+    (string (string= ip1                  ; IPv4 or IPv6
+                     (host-to-hostname ip2)))
+    ((or (vector t 4)                     ; IPv4
+         (array (unsigned-byte 8) (4))    ; IPv4
+         (vector t 16)                    ; IPv6
+         (array (unsigned-byte 8) (16)))  ; IPv6
+     (equalp ip1 ip2))
+    (integer (= ip1                       ; IPv4 only
+                (host-byte-order ip2))))) ; convert ip2 to integer (hbo)
+
+(defun ip/= (ip1 ip2) ; exported
+  (not (ip= ip1 ip2)))
+
+;;
+;; DNS helper functions
+;;
+
+(defun get-host-by-name (name)
+  "0.7.1+: if there're IPv4 addresses, return the first IPv4 address."
+  (let* ((hosts (get-hosts-by-name name))
+         (pos (position-if #'(lambda (ip) (= 4 (length ip))) hosts)))
+    (if pos (elt hosts pos)
+      (car hosts))))
+
+(defun get-random-host-by-name (name)
+  "0.7.1+: if there're IPv4 addresses, only return a random IPv4 address."
+  (let* ((hosts (get-hosts-by-name name))
+         (ipv4-hosts (remove-if-not #'(lambda (ip) (= 4 (length ip))) hosts)))
+    (cond (ipv4-hosts
+           (elt ipv4-hosts (random (length ipv4-hosts))))
+          (hosts
+           (elt hosts (random (length hosts)))))))
+
+(defun host-to-vector-quad (host) ; internal
+  "Translate a host specification (vector quad, dotted quad or domain name)
+to a vector quad."
+  (etypecase host
+    (string (let* ((ip (when (ip-address-string-p host)
+                         (dotted-quad-to-vector-quad host))))
+              (if (and ip (= 4 (length ip)))
+                  ;; valid IP dotted quad? not sure
+                  ip
+                (get-random-host-by-name host))))
+    ((or (vector t 4)
+         (array (unsigned-byte 8) (4)))
+     host)
+    (integer (hbo-to-vector-quad host))))
+
+(defun host-to-hbo (host) ; internal
+  (etypecase host
+    (string (let ((ip (when (ip-address-string-p host)
+                        (dotted-quad-to-vector-quad host))))
+              (if (and ip (= 4 (length ip)))
+                  (host-byte-order ip)
+                  (host-to-hbo (get-host-by-name host)))))
+    ((or (vector t 4)
+         (array (unsigned-byte 8) (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 nodelay some-other-keys...) ..)
+;;
+(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.
+
+`nodelay' Allows to disable/enable Nagle's algorithm (http://en.wikipedia.org/wiki/Nagle%27s_algorithm).
+If this parameter is omitted, the behaviour is inherited from the
+CL implementation (in most cases, Nagle's algorithm is
+enabled by default, but for example in ACL it is disabled).
+If the parameter is specified, one of these three values is possible:
+  T - Disable Nagle's algorithm; signals an UNSUPPORTED
+      condition if the implementation does not support explicit
+      manipulation with that option.
+  NIL - Leave Nagle's algorithm enabled on the socket;
+      signals an UNSUPPORTED condition if the implementation does
+      not support explicit manipulation with that option.
+  :IF-SUPPORTED - Disables Nagle's algorithm if the implementation
+      allows this, otherwises just ignore this option.
+
+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 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*' or NIL is
+passed for `host', the socket will be bound to all available
+interfaces for 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.
+")
+
+;;; Small utility functions mapping true/false to 1/0, moved here from option.lisp
+
+(proclaim '(inline bool->int int->bool))
+
+(defun bool->int (bool) (if bool 1 0))
+(defun int->bool (int) (= 1 int))

sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/vendor/OpenTransportUDP.lisp

@@ -0,0 +1,146 @@
+;;;-*-Mode: LISP; Package: CCL -*-
+;;
+;;; OpenTransportUDP.lisp
+;;; Copyright 2012 Chun Tian (binghe) <binghe.lisp@gmail.com>
+
+;;; UDP extension to OpenTransport.lisp (with some TCP patches)
+
+(in-package "CCL")
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (require :opentransport))
+
+;; MCL Issue 28: Passive TCP streams should be able to listen to the loopback interface
+;; see http://code.google.com/p/mcl/issues/detail?id=28 for details
+
+(defparameter *passive-interface-address* NIL
+  "Address to use for passive connections - optionally bind to loopback address while opening a tcp stream")
+
+(advise local-interface-ip-address
+  (or *passive-interface-address* (:do-it))
+  :when :around :name 'override-local-interface-ip-address)
+
+;; MCL Issue 29: Passive TCP connections on OS assigned ports
+;; see http://code.google.com/p/mcl/issues/detail?id=29 for details
+(advise ot-conn-tcp-passive-connect
+  (destructuring-bind (conn port &optional (allow-reuse t)) arglist
+    (declare (ignore allow-reuse))
+    (if (eql port #$kOTAnyInetAddress)
+	;; Avoids registering a proxy for port 0 but instead registers one for the true port:
+	(multiple-value-bind (proxy result)
+	    (let* ((*opentransport-class-proxies* NIL) ; makes ot-find-proxy return NIL
+		   (result (:do-it)) ;; pushes onto *opentransport-class-proxies*
+		   (proxy (prog1
+			      (pop *opentransport-class-proxies*)
+			    (assert (not *opentransport-class-proxies*))))
+		   (context (cdr proxy))
+		   (tmpconn (make-ot-conn :context context 
+					  :endpoint (pref context :ot-context.ref)))
+		   (localaddress (ot-conn-tcp-get-addresses tmpconn)))
+	      (declare (dynamic-extent tmpconn))
+	      ;; replace original set in body of function
+	      (setf (ot-conn-local-address conn) localaddress)
+	      (values
+	       (cons localaddress context)
+	       result))
+	  ;; need to be outside local binding of *opentransport-class-proxies* 
+	  (without-interrupts
+	      (push proxy *opentransport-class-proxies*))
+	  result)
+	(:do-it)))
+  :when :around :name 'ot-conn-tcp-passive-connect-any-address)
+
+(defun open-udp-socket (&key local-address local-port)
+  (init-opentransport)
+  (let (endpoint ; TODO: opentransport-alloc-endpoint-from-freelist
+	(err #$kOTNoError)
+	(configptr (ot-cloned-configuration traps::$kUDPName)))
+    (rlet ((errP :osstatus))
+      (setq endpoint #+carbon-compat (#_OTOpenEndpointInContext configptr 0 (%null-ptr) errP *null-ptr*)
+	             #-carbon-compat (#_OTOpenEndpoint configptr 0 (%null-ptr) errP)
+	    err (pref errP :osstatus))
+      (if (eql err #$kOTNoError)
+	  (let* ((context (ot-make-endpoint-context endpoint nil nil)) ; no notifier, not minimal
+		 (conn (make-ot-conn :context context :endpoint endpoint)))
+	    (macrolet ((check-ot-error-return (error-context)
+			 `(unless (eql (setq err (pref errP :osstatus)) #$kOTNoError)
+			    (values (ot-error err ,error-context)))))
+	      (setf (ot-conn-bindreq conn) 
+		    #-carbon-compat (#_OTAlloc endpoint #$T_BIND #$T_ADDR errP)
+		    #+carbon-compat (#_OTAllocInContext endpoint #$T_BIND #$T_ADDR errP *null-ptr*)
+		    )
+	      (check-ot-error-return :alloc)
+	      (setf (ot-conn-bindret conn) 
+		    #-carbon-compat (#_OTAlloc endpoint #$T_BIND #$T_ADDR errP)
+		    #+carbon-compat (#_OTAllocInContext endpoint #$T_BIND #$T_ADDR errP *null-ptr*)
+		    )
+	      (check-ot-error-return :alloc)
+	      (setf (ot-conn-options conn) 
+		    #-carbon-compat (#_OTAlloc endpoint #$T_OPTMGMT #$T_OPT errP)
+		    #+carbon-compat (#_OTAllocInContext endpoint #$T_OPTMGMT #$T_OPT errP *null-ptr*)
+		    )
+	      (check-ot-error-return :alloc))
+	    ;; BIND to local address (for UDP server)
+	    (when local-port ; local-address
+	      (let* ((host (or local-address (local-interface-ip-address)))
+		     (port (tcp-service-port-number local-port))
+		     (localaddress `(:tcp ,host ,port))
+		     (bindreq (ot-conn-bindreq conn))
+		     (bindret (ot-conn-bindret conn)))
+		(let* ((netbuf (pref bindreq :tbind.addr)))
+		  (declare (dynamic-extent netbuf))
+		  (setf (pref netbuf :tnetbuf.len) (record-length :inetaddress)
+			(pref bindreq :tbind.qlen) 5)       ; arbitrary qlen
+		  (#_OTInitInetAddress (pref netbuf :tnetbuf.buf) port host)
+		  (setf (pref context :ot-context.completed) nil)
+		  (unless (= (setq err (#_OTBind endpoint bindreq bindret)) #$kOTNoError)
+		    (ot-error err :bind)))
+		(setf (ot-conn-local-address conn) localaddress)))
+	    conn)
+	(ot-error err :create)))))
+
+(defun make-TUnitData (endpoint)
+  "create the send/recv buffer for UDP sockets"
+  (let ((err #$kOTNoError))
+    (rlet ((errP :osstatus))
+      (macrolet ((check-ot-error-return (error-context)
+		   `(unless (eql (setq err (pref errP :osstatus)) #$kOTNoError)
+		      (values (ot-error err ,error-context)))))
+	(let ((udata #-carbon-compat (#_OTAlloc endpoint #$T_UNITDATA #$T_ALL errP)
+		     #+carbon-compat (#_OTAllocInContext endpoint #$T_UNITDATA #$T_ALL errP *null-ptr*)))
+	  (check-ot-error-return :alloc)
+	  udata)))))
+
+(defun send-message (conn data buffer size host port &optional (offset 0))
+  ;; prepare dest address
+  (let ((addr (pref data :tunitdata.addr)))
+    (declare (dynamic-extent addr))
+    (setf (pref addr :tnetbuf.len) (record-length :inetaddress))
+    (#_OTInitInetAddress (pref addr :tnetbuf.buf) port host))
+  ;; prepare data buffer
+  (let* ((udata (pref data :tunitdata.udata))
+	 (outptr (pref udata :tnetbuf.buf)))
+    (declare (dynamic-extent udata))
+    (%copy-ivector-to-ptr buffer offset outptr 0 size)
+    (setf (pref udata :tnetbuf.len) size))
+  ;; send the packet
+  (let* ((endpoint (ot-conn-endpoint conn))
+	 (result (#_OTSndUData endpoint data)))
+    (the fixnum result)))
+
+(defun receive-message (conn data buffer length)
+  (let* ((endpoint (ot-conn-endpoint conn))
+	 (err (#_OTRcvUData endpoint data *null-ptr*)))
+    (if (eql err #$kOTNoError)
+	(let* (;(addr (pref data :tunitdata.addr))
+	       (udata (pref data :tunitdata.udata))
+	       (inptr (pref udata :tnetbuf.buf))
+	       (read-bytes (pref udata :tnetbuf.len))
+	       (buffer (or buffer (make-array read-bytes :element-type '(unsigned-byte 8))))
+	       (length (or length (length buffer)))
+	       (actual-size (min read-bytes length)))
+	  (%copy-ptr-to-ivector inptr 0 buffer 0 actual-size)
+	  (values buffer
+		  actual-size
+		  0 0)) ; TODO: retrieve address and port
+      (ot-error err :receive)))) ; TODO: use OTRcvUDErr instead

sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/vendor/kqueue.lisp

@@ -0,0 +1,506 @@
+;;;-*-Mode: LISP; Package: CCL -*-
+;;
+;; KQUEUE.LISP
+;;
+;; KQUEUE - BSD kernel event notification mechanism support for Common LISP.
+;; Copyright (C) 2007 Terje Norderhaug <terje@in-progress.com>
+;; Released under LGPL - see <http://www.gnu.org>.
+;; Alternative licensing available upon request.
+;; 
+;; DISCLAIMER: The user of this module should understand that executing code is a potentially hazardous 
+;; activity, and that many dangers and obstacles, marked or unmarked, may exist within this code.
+;; As a condition of your use of the module, you assume all risk of personal injury, death, or property
+;; loss, and all other bad things that may happen, even if caused by negligence, ignorance or stupidity.
+;; The author is is no way responsible, and besides, does not have "deep pockets" nor any spare change.
+;;
+;; Version: 0.20 alpha (July 26, 2009) - subject to major revisions, so consider yourself warned.
+;; Tested with Macintosh Common LISP 5.1 and 5.2, but is intended to be platform and system independent in the future.
+;;
+;; Email feedback and improvements to <terje@in-progress.com>.
+;; Updated versions will be available from <http://www.in-progress.com/src/>.
+;;
+;; RELATED IMPLEMENTATIONS
+;; There is another kevent.lisp for other platforms by Risto Laakso (merge?).
+;; Also a Scheme kevent.ss by Jose Antonio Ortega.
+;;
+;; SEE ALSO:
+;; http://people.freebsd.org/~jlemon/papers/kqueue.pdf
+;; http://developer.apple.com/samplecode/FileNotification/index.html
+;; The Man page for kqueue() or kevent().
+;; PyKQueue - Python OO interface to KQueue.
+;; LibEvent - an event notification library in C by Niels Provos.
+;; Liboop - another abstract library in C on top of kevent or other kernel notification.
+
+#| HISTORY:
+
+2007-Oct-18 terje version 0.1 released on the Info-MCL mailing list.
+2008-Aug-21 terje load-framework-bundle is not needed under MCL 5.2
+2008-Aug-21 terje rename get-addr to lookup-function-in-bundle (only for pre MCL 5.2)
+2009-Jul-19 terje uses kevent-error condition and strerror.
+2009-Jul-24 terje reports errors unless nil-if-not-found in lookup-function-in-bundle. 
+2009-Jul-24 terje kevent :variant for C's intptr_t type for 64bit (and osx 10.5) compatibility.
+2009-Jul-25 terje 64bit support, dynamically determined for PPC. Kudos to Glen Foy for helping out.
+2009-Jul-25 terje make-kevent function.
+|#
+
+#| IMPLEMENTATION NOTES:
+
+kevents are copied into and from the kernel, so the records don't have to be kept in the app!
+kevents does not work in OSX before 10.3.
+*kevent-record* has to be explcitly set to :kevent64 to work on 64bit intel macs.
+Consider using sysctlbyname() to test for 64bit, 
+ combining hw.cpu64bit_capable, hw.optional.x86_64 and hw.optional.64bitops
+|#
+
+(in-package :ccl)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+#-ccl-5.2 ; has been added to MCL 5.2
+(defmethod load-framework-bundle ((framework-name string) &key (load-executable t))
+  ;; FRAMWORK CALL FUNCTIONALITY FROM BSD.LISP
+  ;; (C) 2003 Brendan Burns <bburns@cs.umass.edu>
+  ;; Released under LGPL.
+  (with-cfstrs ((framework framework-name))
+    (let ((err 0)
+          (baseURL nil)
+          (bundleURL nil)
+          (result nil))
+      (rlet ((folder :fsref))
+        ;; Find the folder holding the bundle
+        (setf err (#_FSFindFolder #$kOnAppropriateDisk #$kFrameworksFolderType 
+                   t folder))
+        
+        ;; if everything's cool, make a URL for it
+        (when (zerop err)
+          (setf baseURL (#_CFURLCreateFromFSRef (%null-ptr) folder))
+          (if (%null-ptr-p baseURL) 
+            (setf err #$coreFoundationUnknownErr)))
+        
+        ;; if everything's cool, make a URL for the bundle
+        (when (zerop err)
+          (setf bundleURL (#_CFURLCreateCopyAppendingPathComponent (%null-ptr) 
+                           baseURL framework nil))
+          (if (%null-ptr-p bundleURL) 
+            (setf err #$coreFoundationUnknownErr)))
+        
+        ;; if everything's cool, load it
+        (when (zerop err)
+          (setf result (#_CFBundleCreate (%null-ptr) bundleURL))
+          (if (%null-ptr-p result)
+            (setf err #$coreFoundationUnknownErr)))
+        
+        ;; if everything's cool, and the user wants it loaded, load it
+        (when (and load-executable (zerop err))
+          (if (not (#_CFBundleLoadExecutable result))
+            (setf err #$coreFoundationUnknownErr)))
+        
+        ;; if there's an error, but we've got a pointer, free it and clear result
+        (when (and (not (zerop err)) (not (%null-ptr-p result)))
+          (#_CFRelease result)
+          (setf result nil))
+        
+        ;; free the URLs if there non-null
+        (when (not (%null-ptr-p bundleURL))
+          (#_CFRelease bundleURL))
+        (when (not (%null-ptr-p baseURL))
+          (#_CFRelease baseURL))
+        
+        ;; return pointer + error value
+        (values result err)))))
+
+#+ignore
+(defun get-addr (bundle name)
+  (let* ((addr (#_CFBundleGetFunctionPointerForName bundle name)))
+    (rlet ((buf :long))
+      (setf (%get-ptr buf) addr)
+      (ash (%get-signed-long buf) -2))))
+
+#-ccl-5.2
+(defun lookup-function-in-bundle (name bundle &optional nil-if-not-found)
+  (with-cfstrs ((str name))
+    (let* ((addr (#_CFBundleGetFunctionPointerForName bundle str)))
+      (if (%null-ptr-p addr)
+        (unless nil-if-not-found
+          (error "Couldn't resolve address of foreign function ~s" name))
+        (rlet ((buf :long)) ;; mcl 5.2 uses %fixnum-from-macptr here
+          (setf (%get-ptr buf) addr)
+          (ash (%get-signed-long buf) -2))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Convenient way to declare BSD system calls
+
+#+ignore
+(defparameter *system-bundle*
+  #+ccl-5.2 (get-bundle-for-framework-name "System.framework")
+  #-ccl-5.2
+  (let ((bundle (load-framework-bundle "System.framework")))
+    (terminate-when-unreachable bundle (lambda (b)(#_CFRelease b)))
+    bundle))
+
+(defmacro declare-bundle-ff (name name-string &rest arglist &aux (fn (gensym (format nil "ff_~A_" (string name)))))
+  ;; Is there an existing define-trap like macro for this? or could one be modified for use with bundles?
+  `(progn
+     (defloadvar ,fn
+       (let* ((bundle #+ccl-5.2 (get-bundle-for-framework-name "System.framework")
+                      #-ccl-5.2
+                      (let ((bundle (load-framework-bundle "System.framework")))
+                        (terminate-when-unreachable bundle (lambda (b)(#_CFRelease b)))
+                        bundle)))
+         (lookup-function-in-bundle ,name-string bundle)))
+     ,(let ((args (do ((arglist arglist (cddr arglist))
+                      (result))
+                     ((not (cdr arglist)) (nreverse result))
+                   (push (second arglist) result))))        
+       `(defun ,name ,args
+          (ppc-ff-call ,fn ,@arglist)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(declare-bundle-ff %system-kqueue "kqueue" 
+                   :signed-fullword) ;; returns a file descriptor no!
+
+(defun system-kqueue ()
+  (let ((kq (%system-kqueue)))
+    (if (= kq -1)
+      (ecase (%system-errno)
+        (12 (error "The kernel failed to allocate enough memory for the kernel queue")) ; ENOMEM
+        (24 (error "The per-process descriptor table is full")) ; EMFILE
+        (23 (error "The system file table is full"))) ; ENFILE 
+      kq)))
+
+(declare-bundle-ff %system-kevent "kevent"
+                  :unsigned-fullword kq
+                  :address ke
+                  :unsigned-fullword nke
+                  :address ko
+                  :unsigned-fullword nko
+                  :address timeout
+                  :signed-fullword)
+
+(declare-bundle-ff %system-open "open" 
+                   :address name 
+                   :unsigned-fullword mode
+                   :unsigned-fullword arg 
+                   :signed-fullword)
+ 
+(declare-bundle-ff %system-close "close"
+                   :unsigned-fullword fd 
+                   :signed-fullword)
+
+(declare-bundle-ff %system-errno* "__error" 
+                   :signed-fullword)
+
+(declare-bundle-ff %system-strerror "strerror" 
+                   :signed-fullword errno
+                   :address)
+
+(defun %system-errno ()
+  (%get-fixnum (%int-to-ptr (%system-errno*))))
+
+; (%system-errno)
+
+(defconstant $O-EVTONLY #x8000)
+; (defconstant $O-NONBLOCK #x800 "Non blocking mode")
+
+(defun system-open (posix-namestring)
+  "Low level open function, as in C, returns an fd number"
+  (with-cstrs ((name posix-namestring))
+    (%system-open name $O-EVTONLY 0)))
+
+(defun system-close (fd)
+  (%system-close fd))
+
+(defrecord timespec
+  (sec :unsigned-long)
+  (usec :unsigned-long))
+
+(defVar *kevent-record* nil)
+
+(def-ccl-pointers determine-64bit-kevents ()
+  (setf *kevent-record*
+       (if (ccl::gestalt #$gestaltPowerPCProcessorFeatures
+                        #+ccl-5.2 #$gestaltPowerPCHas64BitSupport #-ccl-5.2 6)
+          :kevent32
+          :kevent64)))
+
+(defrecord :kevent32
+  (ident :unsigned-long) ; uintptr_t
+  (filter :short)
+  (flags :unsigned-short)
+  (fflags :unsigned-long)
+  (data :long)  ; intptr_t
+  (udata :pointer))
+
+(defrecord :kevent64
+  (:variant ; uintptr_t
+   ((ident64 :uint64))
+   ((ident :unsigned-long)))
+  (filter :short)
+  (flags :unsigned-short)
+  (fflags :unsigned-long)
+  (:variant  ; intptr_t
+   ((data64 :sint64))
+   ((data :long)))
+  (:variant ; RMCL :pointer is 32bit
+   ((udata64 :uint64))
+   ((udata :pointer))))
+
+(defun make-kevent (&key (ident 0) (filter 0) (flags 0) (fflags 0) (data 0) (udata *null-ptr*))
+   (ecase *kevent-record*
+      (:kevent64   
+       (make-record kevent64
+                    :ident ident
+                    :filter filter 
+                    :flags flags
+                    :fflags fflags
+                    :data data 
+                    :udata udata))
+      (:kevent32
+       (make-record kevent32
+                    :ident ident
+                    :filter filter 
+                    :flags flags
+                    :fflags fflags
+                    :data data 
+                    :udata udata))))
+
+(defun kevent-rref (ke field)
+   (ecase *kevent-record*
+      (:kevent32
+       (ecase field
+          (:ident (rref ke :kevent32.ident))
+          (:filter (rref ke :kevent32.filter))
+          (:flags (rref ke :kevent32.flags))
+          (:fflags (rref ke :kevent32.fflags))
+          (:data (rref ke :kevent32.data))
+          (:udata (rref ke :kevent32.udata))))
+      (:kevent64
+       (ecase field
+          (:ident (rref ke :kevent64.ident))
+          (:filter (rref ke :kevent64.filter))
+          (:flags (rref ke :kevent64.flags))
+          (:fflags (rref ke :kevent64.fflags))
+          (:data (rref ke :kevent64.data))
+          (:udata (rref ke :kevent64.udata))))))
+
+(defun kevent-filter (ke)
+   (kevent-rref ke :filter))
+
+(defun kevent-flags (ke)
+   (kevent-rref ke :flags))
+
+(defun kevent-data (ke)
+   (kevent-rref ke :data))
+
+
+;; FILTER TYPES:
+
+(eval-when (:compile-toplevel :load-toplevel :execute) ; added by binghe
+
+(defconstant $kevent-read-filter -1 "Data available to read")
+(defconstant $kevent-write-filter -2 "Writing is possible")
+(defconstant $kevent-aio-filter -3 "AIO system call has been made")
+(defconstant $kevent-vnode-filter -4 "Event occured on a file descriptor")
+(defconstant $kevent-proc-filter -5 "Process performed one or more of the requested events")
+(defconstant $kevent-signal-filter -6 "Attempted to deliver a signal to a process")
+(defconstant $kevent-timer-filter -7 "Establishes an arbitrary timer")
+(defconstant $kevent-netdev-filter -8 "Event occured on a network device")
+(defconstant $kevent-filesystem-filter -9)
+
+) ; eval-when
+
+; FLAGS:
+
+(defconstant $kevent-add #x01)
+(defconstant $kevent-delete #x02)
+(defconstant $kevent-enable #x04)
+(defconstant $kevent-disable #x08)
+(defconstant $kevent-oneshot #x10)
+(defconstant $kevent-clear #x20)
+(defconstant $kevent-error #x4000)
+(defconstant $kevent-eof #x8000 "EV_EOF")
+
+;; FFLAGS:
+
+(defconstant $kevent-file-delete #x01 "The file was unlinked from the file system")
+(defconstant $kevent-file-write #x02 "A write occurred on the file")
+(defconstant $kevent-file-extend #x04 "The file was extended")
+(defconstant $kevent-file-attrib #x08 "The file had its attributes changed")
+(defconstant $kevent-file-link #x10 "The link count on the file changed")
+(defconstant $kevent-file-rename #x20 "The file was renamed")
+(defconstant $kevent-file-revoke #x40 "Access to the file was revoked or the file system was unmounted")
+(defconstant $kevent-file-all (logior $kevent-file-delete $kevent-file-write $kevent-file-extend
+                                      $kevent-file-attrib $kevent-file-link $kevent-file-rename $kevent-file-revoke))
+
+
+(defconstant $kevent-net-linkup #x01 "Link is up")
+(defconstant $kevent-net-linkdown #x02 "Link is down")
+(defconstant $kevent-net-linkinvalid #x04 "Link state is invalid")
+(defconstant $kevent-net-added #x08 "IP adress added")
+(defconstant $kevent-net-deleted #x10 "IP adress deleted")
+
+(define-condition kevent-error (simple-error)
+  ((errno :initform NIL :initarg :errno)
+   (ko :initform nil :type (or null kevent) :initarg :ko)
+   (syserr :initform (%system-errno)))
+  (:report 
+   (lambda (c s)
+     (with-slots (errno ko syserr) c
+       (format s "kevent system call error ~A [~A]" errno syserr) 
+       (when errno 
+          (format s "(~A)" (%get-cstring (%system-strerror errno))))
+       (when ko
+          (format s " for ")
+          (let ((*standard-output* s))
+            (print-record ko *kevent-record*)))))))
+
+(defun %kevent (kq &optional ke ko (timeout 0))
+  (check-type kq integer)
+  (rlet ((&timeout :timespec :sec timeout :usec 1))
+    (let ((num (with-timer ;; does not seem to make a difference...  
+                 (%system-kevent kq (or ke (%null-ptr))(if ke 1 0)(or ko (%null-ptr))(if ko 1 0) &timeout))))
+      ; "If an error occurs while processing an element of the changelist and there 
+      ; is enough room in the eventlist, then the event will be placed in the eventlist with 
+      ; EV_ERROR set in flags and the system error in data."
+      (when (and ko (plusp (logand $kevent-error (kevent-flags ko))))
+        (error 'kevent-error 
+                              :errno (kevent-data ko)
+               :ko ko))
+      ; "Otherwise, -1 will be returned, and errno will be set to indicate the error condition."
+      (when (= num -1)
+        ;; hack - opentransport provides the constants for the errors documented for the call 
+        (case (%system-errno)
+          (0 (error "kevent system call failed with an unspecified error")) ;; should not happen!
+          (13 (error "The process does not have permission to register a filter")) 
+          (14 (error "There was an error reading or writing the kevent structure"))  ; EFAULT
+          (9 (error "The specified descriptor is invalid")) ; EBADF
+          (4 (error "A signal was delivered before the timeout expired and before any events were placed on the kqueue for return.")) ; EINTR
+          (22 (error "The specified time limit or filter is invalid")) ; EINVAL
+          (2 (error "The event could not be found to be modified or deleted")) ; ENOENT
+          (12 (error "No memory was available to register the event")) ; ENOMEM
+          (78 (error "The specified process to attach to does not exist"))) ; ESRCH
+        ;; shouldn't get here... 
+        (errchk (%system-errno))
+        (error "error ~A" (%system-errno)))
+      (unless (zerop num)
+         (values ko num)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; CLOS INTERFACE
+
+(defclass kqueue ()
+  ((kq :initform (system-kqueue) 
+       :documentation "file descriptor referencing the kqueue")
+   (fds :initform NIL)) ;; ## better if kept on top level, perhaps as a hash table...
+  (:documentation "A kernal event notification channel"))
+
+(defmethod initialize-instance :after ((q kqueue) &rest rest)
+  (declare (ignore rest))
+  (terminate-when-unreachable q 'kqueue-close))
+
+(defmethod kqueue-close ((q kqueue))
+  (with-slots (kq fds) q
+    (when (or kq fds) ;; allow repeated close
+      (system-close kq)
+      (setf fds NIL)
+      (setf kq NIL))))
+
+(defmethod kqueue-poll ((q kqueue))
+  "Polls a kqueue for kevents"
+  ;; may not have to be cleared, but just in case:
+  (flet ((kqueue-poll2 (ko)
+           (let ((result (with-slots (kq) q
+                            (without-interrupts 
+                             (%kevent kq NIL ko)))))
+             (when result
+                (let ((type  (kevent-filter result)))
+                  (ecase type
+                     (0 (values))
+                     (#.$kevent-read-filter
+                          (values
+                           :read
+                           (kevent-rref result :ident)
+                           (kevent-rref result :flags)
+                           (kevent-rref result :fflags)
+                           (kevent-rref result :data)
+                           (kevent-rref result :udata)))
+                      (#.$kevent-write-filter :write)
+                      (#.$kevent-aio-filter :aio)
+                      (#.$kevent-vnode-filter
+                           (values
+                            :vnode
+                            (cdr (assoc (kevent-rref result :ident) (slot-value q 'fds)))
+                            (kevent-rref result :flags)
+                            (kevent-rref result :fflags)
+                            (kevent-rref result :data)
+                            (kevent-rref result :udata)))
+                      (#.$kevent-filesystem-filter :filesystem)))))))
+    (ecase *kevent-record*
+       (:kevent64
+        (rlet ((ko :kevent64 :ident 0 :filter 0 :flags 0 :fflags 0 :data 0 :udata (%null-ptr)))
+          (kqueue-poll2 ko)))
+       (:kevent32
+        (rlet ((ko :kevent32 :ident 0 :filter 0 :flags 0 :fflags 0 :data 0 :udata (%null-ptr)))
+          (kqueue-poll2 ko))))))
+
+(defmethod kqueue-subscribe ((q kqueue) &key ident filter (flags 0) (fflags 0) (data 0) (udata (%null-ptr)))
+  (let ((ke (make-kevent :ident ident
+                         :filter filter 
+                         :flags flags
+                         :fflags fflags
+                         :data data 
+                         :udata udata)))
+    (with-slots (kq) q
+       (without-interrupts
+        (%kevent kq ke)))))
+
+(defmethod kqueue-vnode-subscribe ((q kqueue) pathname)
+  "Makes the queue report an event when there is a change to a directory or file" 
+  (let* ((namestring (posix-namestring (full-pathname pathname)))
+         (fd (system-open namestring)))
+    (with-slots (fds) q
+      (push (cons fd pathname) fds))
+    (kqueue-subscribe q 
+                      :ident fd 
+                      :filter $kevent-vnode-filter 
+                      :flags (logior $kevent-add $kevent-clear) 
+                      :fflags $kevent-file-all)
+    namestring))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+#+test
+(defun kevent-d (pathname &optional (*standard-output* (fred)))
+  "Report changes to a file or directory"
+  (loop
+    with kqueue = (make-instance 'kqueue)
+    with sub = (kqueue-vnode-subscribe kqueue pathname) 
+    for i from 1 to 60
+    for result = (multiple-value-list (kqueue-poll kqueue))
+    unless (equal result '(NIL))
+    do (progn
+         (format T "~A~%" result)
+         (force-output))
+    ; do (process-allow-schedule)
+    do (sleep 1)
+    finally (write-line "Done")
+    ))
+
+#|
+
+; Report changes to this file in a fred window (save this document to see what happens):
+
+(process-run-function "kevent-d" #'kevent-d *loading-file-source-file*
+                      (fred))
+
+; Reports files added or removed from the directory of this file:
+
+(process-run-function "kevent-d" #'kevent-d 
+                      (make-pathname :directory (pathname-directory *loading-file-source-file*))
+                      (fred))
+|#
+
+
+
+

sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/version.sexp

@@ -0,0 +1 @@
+"0.8.3"