[bknr-cvs] r2450 - in branches/trunk-reorg/thirdparty/acl-compat: . allegro clisp cmucl lispworks mcl sbcl scl
hhubner at common-lisp.net
hhubner at common-lisp.net
Thu Feb 7 08:21:53 UTC 2008
Author: hhubner
Date: Thu Feb 7 03:21:48 2008
New Revision: 2450
Added:
branches/trunk-reorg/thirdparty/acl-compat/
branches/trunk-reorg/thirdparty/acl-compat/CREDITS
branches/trunk-reorg/thirdparty/acl-compat/ChangeLog
branches/trunk-reorg/thirdparty/acl-compat/README
branches/trunk-reorg/thirdparty/acl-compat/acl-compat-cmu.system
branches/trunk-reorg/thirdparty/acl-compat/acl-compat-common-lisp-lw.lisp
branches/trunk-reorg/thirdparty/acl-compat/acl-compat-corman.lisp
branches/trunk-reorg/thirdparty/acl-compat/acl-compat.asd
branches/trunk-reorg/thirdparty/acl-compat/acl-excl-common.lisp
branches/trunk-reorg/thirdparty/acl-compat/acl-excl-corman.lisp
branches/trunk-reorg/thirdparty/acl-compat/acl-mp-corman.lisp
branches/trunk-reorg/thirdparty/acl-compat/acl-mp-package.lisp
branches/trunk-reorg/thirdparty/acl-compat/acl-socket-corman.lisp
branches/trunk-reorg/thirdparty/acl-compat/acl-ssl-streams.lisp
branches/trunk-reorg/thirdparty/acl-compat/acl-ssl.lisp
branches/trunk-reorg/thirdparty/acl-compat/allegro/
branches/trunk-reorg/thirdparty/acl-compat/allegro/acl-excl.lisp
branches/trunk-reorg/thirdparty/acl-compat/allegro/acl-mp.lisp
branches/trunk-reorg/thirdparty/acl-compat/allegro/acl-socket.lisp
branches/trunk-reorg/thirdparty/acl-compat/allegro/acl-sys.lisp
branches/trunk-reorg/thirdparty/acl-compat/chunked-stream-mixin.lisp
branches/trunk-reorg/thirdparty/acl-compat/chunked.lisp (contents, props changed)
branches/trunk-reorg/thirdparty/acl-compat/clisp/
branches/trunk-reorg/thirdparty/acl-compat/clisp/acl-excl.lisp
branches/trunk-reorg/thirdparty/acl-compat/clisp/acl-mp.lisp
branches/trunk-reorg/thirdparty/acl-compat/clisp/acl-socket.lisp
branches/trunk-reorg/thirdparty/acl-compat/clisp/acl-sys.lisp
branches/trunk-reorg/thirdparty/acl-compat/cmucl/
branches/trunk-reorg/thirdparty/acl-compat/cmucl/acl-excl.lisp
branches/trunk-reorg/thirdparty/acl-compat/cmucl/acl-mp.lisp
branches/trunk-reorg/thirdparty/acl-compat/cmucl/acl-socket.lisp
branches/trunk-reorg/thirdparty/acl-compat/cmucl/acl-sys.lisp
branches/trunk-reorg/thirdparty/acl-compat/defsys.lisp
branches/trunk-reorg/thirdparty/acl-compat/lispworks/
branches/trunk-reorg/thirdparty/acl-compat/lispworks/acl-excl.lisp
branches/trunk-reorg/thirdparty/acl-compat/lispworks/acl-mp.lisp
branches/trunk-reorg/thirdparty/acl-compat/lispworks/acl-socket.lisp
branches/trunk-reorg/thirdparty/acl-compat/lispworks/acl-sys.lisp
branches/trunk-reorg/thirdparty/acl-compat/lw-buffering.lisp
branches/trunk-reorg/thirdparty/acl-compat/mcl/
branches/trunk-reorg/thirdparty/acl-compat/mcl/acl-excl.lisp
branches/trunk-reorg/thirdparty/acl-compat/mcl/acl-mp.lisp
branches/trunk-reorg/thirdparty/acl-compat/mcl/acl-socket-mcl.lisp
branches/trunk-reorg/thirdparty/acl-compat/mcl/acl-socket-openmcl.lisp
branches/trunk-reorg/thirdparty/acl-compat/mcl/acl-sys.lisp
branches/trunk-reorg/thirdparty/acl-compat/mcl/mcl-stream-fix.lisp
branches/trunk-reorg/thirdparty/acl-compat/mcl/mcl-timers.lisp
branches/trunk-reorg/thirdparty/acl-compat/packages.lisp
branches/trunk-reorg/thirdparty/acl-compat/sbcl/
branches/trunk-reorg/thirdparty/acl-compat/sbcl/acl-excl.lisp
branches/trunk-reorg/thirdparty/acl-compat/sbcl/acl-mp.lisp
branches/trunk-reorg/thirdparty/acl-compat/sbcl/acl-socket.lisp
branches/trunk-reorg/thirdparty/acl-compat/sbcl/acl-sys.lisp
branches/trunk-reorg/thirdparty/acl-compat/scl/
branches/trunk-reorg/thirdparty/acl-compat/scl/acl-excl.lisp
branches/trunk-reorg/thirdparty/acl-compat/scl/acl-mp.lisp
branches/trunk-reorg/thirdparty/acl-compat/scl/acl-socket.lisp
branches/trunk-reorg/thirdparty/acl-compat/scl/acl-sys.lisp
branches/trunk-reorg/thirdparty/acl-compat/test-acl-socket.lisp (contents, props changed)
Log:
add acl-compat
Added: branches/trunk-reorg/thirdparty/acl-compat/CREDITS
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/CREDITS Thu Feb 7 03:21:48 2008
@@ -0,0 +1,59 @@
+-*- text -*-
+
+CREDITS; a.k.a. the history of Portable AllegroServe
+
+This was written by Rudi Schlatte, who (knowing himself) is sure he
+forgot some important contributors. Please mail me (rudi at
+constantly.at) to point out any inconsistencies, don't be shy!
+
+* Corman Lisp
+
+The code that started it all. Chris Double took Allegro's
+open-sourced code, got it to run on Corman Lisp and released the
+code.. After Portable AllegroServe got off the ground, he re-arranged
+his port so that it fit in the structure of acl-compat.
+
+* Xanalys LispWorks
+
+Jochen Schmidt ported Chris Double's AllegroServe port to LispWorks,
+laid the groundwork for the "Portable" part of paserve and started
+the SourceForge project.
+
+* cmucl
+
+cmucl was the third Lisp implementation to run Portable
+AllegroServe. The port was done by Rudi Schlatte during his military
+service out of sheer boredom.
+
+* Digitool MCL
+
+John DeSoi contributed this port and kept it working when the antics
+of other developers broke his code once again.
+
+* OpenMCL
+
+Also done by John DeSoi. Gary Byers himself later contributed code to
+support OpenMCL's OS-level threads (OpenMCL version 14 and up) in an
+efficient way.
+
+* sbcl
+
+This port was done by Rudi Schlatte, using Daniel Barlow's sbcl
+multiprocessing code in the McCLIM GUI project as inspiration.
+
+* clisp
+
+Also by Rudi Schlatte. Since clisp has no support for threads,
+neither does acl-compat on this platform. Code can still be
+compiled, however.
+
+* Scieneer Common Lisp
+
+This port was contributed by Douglas Crosher.
+
+* Allegro Common Lisp
+
+It may seem strange to implement an API on top of itself, but Kevin
+Rosenberg's implementation makes it possible to run systems that use
+acl-compat on ACL itself without source changes.
+
Added: branches/trunk-reorg/thirdparty/acl-compat/ChangeLog
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/ChangeLog Thu Feb 7 03:21:48 2008
@@ -0,0 +1,354 @@
+2006-01-22 Rudi Schlatte <rudi at constantly.at>
+
+ * sbcl/acl-mp.lisp (defun/sb-thread): silence compilation style
+ warning on single-threaded sbcl
+
+ * sbcl/acl-excl.lisp (filesys-type): Fix bogus variable name :(
+
+2006-01-21 Rudi Schlatte <rudi at constantly.at>
+
+ * sbcl/acl-excl.lisp (filesys-type, filesys-inode): use sb-posix
+ instead of sbcl internals
+
+2005-08-05 Gabor Melis <mega at hotpop.com>
+
+ * sbcl/acl-mp.lisp: updated to use the thread object api
+ available since sbcl 0.9.2
+
+2004-02-17 Rudi Schlatte <rudi at SLAW40.kfunigraz.ac.at>
+
+ * acl-excl-common.lisp (match-regexp): Make :return :index return
+ values same as ACL
+
+2004-02-16 Rudi Schlatte <rudi at 62-99-252-74.C-GMITTE.Xdsl-line.inode.at>
+
+ * acl-compat.asd:
+ - Add some meta-information to system definition
+ - Fix bug: all but the first :depends-on arguments are silently
+ ignored. :/
+
+2004-02-16 Rudi Schlatte <rudi at constantly.at>
+
+ * packages.lisp: Remove references to nregex package.
+
+ * acl-excl-common.lisp (match-regexp, compile-regexp): Implement
+ using cl-ppcre.
+
+ * acl-compat.asd: Eliminate meta and nregex, use cl-ppcre instead.
+
+2004-02-14 Rudi Schlatte <rudi at constantly.at>
+
+ * acl-compat.asd: Make Gray streams loading on cmucl a little bit
+ saner (but only a little bit)
+
+ * chunked-stream-mixin.lisp: Don't add to *features*, remove
+ provide form.
+
+2004-02-08 Rudi Schlatte <rudi at constantly.at>
+
+ * acl-compat.asd: Introduce dependency on puri, remove meta and
+ uri.lisp
+
+2004-02-02 Rudi Schlatte <rudi at constantly.at>
+
+ * cmucl/acl-mp.lisp (process-run-function): Give the new process
+ a run reason, so that it doesn't hang from the start.
+
+ * cmucl/acl-socket.lisp (get-fd): Added method for server-socket.
+
+2004-01-28 Rudi Schlatte <rudi at constantly.at>
+
+ * packages.lisp: excl -> acl-compat.excl
+
+ * lispworks/acl-socket.lisp: ditto.
+
+2004-01-27 Rudi Schlatte <rudi at constantly.at>
+
+ * chunked-stream-mixin.lisp: replace excl: package prefix with
+ acl-compat.excl:
+
+2004-01-26 Rudi Schlatte <rudi at constantly.at>
+
+ * mcl/acl-excl.lisp (fixnump): new function.
+
+ * packages.lisp (:acl-compat.excl): Remove "excl" nickname.
+
+ * clisp/acl-excl.lisp (fixnump): new function.
+
+2004-01-24 Rudi Schlatte <rudi at constantly.at>
+
+ * acl-excl-common.lisp (string-to-octets): null-terminate vector
+ when asked to.
+
+ * cmucl/acl-excl.lisp, lispworks/acl-excl.lisp, mcl/acl-excl.lisp,
+ sbcl/acl-excl.lisp, scl/acl-excl.lisp: Move write-vector,
+ string-to-octets to commmon file.
+
+ * acl-excl-common.lisp: Moved write-vector, string-to-octets from
+ implementation-specific files.
+
+2004-01-19 Rudi Schlatte <rudi at constantly.at>
+
+ * scl/acl-excl.lisp, sbcl/acl-excl.lisp, mcl/acl-excl.lisp,
+ lispworks/acl-excl.lisp, cmucl/acl-excl.lisp,
+ clisp/acl-excl.lisp: Remove common functionality from
+ implementation-specific files, dammit!
+
+ * acl-compat.asd: Added acl-excl-common.
+
+ * acl-excl-common.lisp: New file.
+
+2004-01-18 Rudi Schlatte <rudi at 62-99-252-74.C-GMITTE.Xdsl-line.inode.at>
+
+ * acl-excl-corman.lisp (intern*), sbcl/acl-excl.lisp (intern*),
+ mcl/acl-excl.lisp (intern*), lispworks/acl-excl.lisp (intern*),
+ cmucl/acl-excl.lisp (intern*), clisp/acl-excl.lisp (intern*),
+ scl/acl-excl.lisp (intern*): Don't upcase symbol before interning
+ (thanks to Marco Baringer, whose code was broken by this). Now
+ I'm motivated to factor out common code from all the backends ...
+
+ * cmucl/acl-mp.lisp (apply-with-bindings): Fix "How did this ever
+ work" typo; thanks to Marco Baringer.
+
+2004-01-11 Rudi Schlatte <rudi at constantly.at>
+
+ * sbcl/acl-socket.lisp (make-socket): Handle :local-port nil,
+ don't bind socket in that case (let os choose a port)
+
+2004-01-11 Rudi Schlatte <rudi at constantly.at>
+
+ * packages.lisp (defpackage acl-compat.excl): Export some symbols
+ for mcl, too
+
+ * mcl/acl-excl.lisp (run-shell-command): Implement (largely
+ untested for now, needed for cgi support)
+
+ * mcl/acl-sys.lisp (command-line-argument,
+ command-line-arguments): Implement for OpenMCL
+
+ * mcl/acl-mp.lisp (wait-for-input-available): Implement. Needed
+ for cgi support.
+
+ * mcl/acl-socket-openmcl.lisp (server-socket): Remove :type slot
+ argument.
+
+ * sbcl/acl-socket.lisp (make-socket): Add reuse-address argument.
+
+ * cmucl/acl-socket.lisp (make-socket): Add reuse-address argument.
+
+ * acl-compat.asd: Load sb-posix for sbcl.
+
+2003-12-15 Rudi Schlatte <rudi at constantly.at>
+
+ NOTE: this checkin has a reasonable chance of breaking (and mcl
+ (not openmcl))
+
+ * mcl/acl-socket-openmcl.lisp: Remove package definition,
+ implement chunked transfer encoding (accepting a speed loss in the
+ process)
+
+ * mcl/acl-excl.lisp, mcl/acl-mp.lisp, mcl/acl-sys.lisp: remove
+ package definitions
+
+ * uri.lisp: deftype also at load time; openmcl breaks otherwise
+
+ * packages.lisp: mcl doesn't have stream-(read,write)-sequence
+
+ * lw-buffering.lisp: formatting frobs.
+
+ * acl-compat.asd: Merge mcl defsystem with the others.
+
+ * sbcl/acl-socket.lisp: Use acl-compat.socket package name.
+
+2003-12-02 Rudi Schlatte <rudi at SLAW40.kfunigraz.ac.at>
+
+ * meta.lisp (enable-meta-syntax): Save current readtable before
+ installing *meta-readtable*.
+
+2003-12-01 Rudi Schlatte <rudi at constantly.at>
+
+ * chunked-stream-mixin.lisp: Merge Lispworks patch from Edi Weitz
+ (paserve-help 2003-11-28)
+
+2003-11-27 Rudi Schlatte <rudi at constantly.at>
+
+ * chunked-stream-mixin.lisp (gray-stream:stream-fill-buffer):
+ LispWorks refill-buffer does not always return the amount of
+ bytes read (reported by Edi Weitz to paserve-discuss
+ 2003-11-26). Treat its return value as a boolean.
+
+ * lw-buffering.lisp (stream-fill-buffer): Remove cmucl-specific
+ read-n-bytes call because it does block after all :(
+
+ * chunked-stream-mixin.lisp (gray-stream:stream-fill-buffer): Fix
+ for Lispworks client mode contributed by Edi Weitz to
+ paserve-discuss list on 2003-11-25
+
+ * sbcl/acl-mp.lisp: Single-threaded "implementation" of process-name
+
+2003-09-19 Rudi Schlatte <rudi at constantly.at>
+
+ * sbcl/acl-mp.lisp: Merged threading patch from Brian Downing
+ (posted to portableaserve-discuss 2003-09-12)
+
+ * clisp/acl-excl.lisp, clisp/acl-socket.lisp: Eliminate compile
+ failures, activate chunked support for clisp (forwarded by Kevin
+ M. Rosenberg from Debian)
+
+2003-08-31 Rudi Schlatte <rudi at constantly.at>
+
+ * acl-compat.asd: Remove old cmu-read-sequence cruft, bug is fixed
+ in reasonably recent cmucl
+
+ * lw-buffering.lisp (stream-fill-buffer): Use package-external
+ symbol that doesn't break on CVS cmucl
+
+2003-08-30 Rudi Schlatte <rudi at 62-99-252-74.C-GMITTE.Xdsl-line.inode.at>
+
+ * cmucl/acl-socket.lisp (make-socket): set reuse-address option.
+
+ * lw-buffering.lisp (stream-fill-buffer): Implement b/nb semantics
+ for cmucl as well. client mode should now neither hang trying to
+ read closed streams nor give spurious errors for slow servers.
+
+2003-08-17 Rudi Schlatte <rudi at constantly.at>
+
+ * sbcl/acl-mp.lisp (with-timeout): Eliminate unused-variable
+ warning.
+
+2003-05-13 Rudi Schlatte <rudi at constantly.at>
+
+ * cmucl/acl-sys.lisp, cmucl/acl-socket.lisp, cmucl/acl-excl.lisp:
+ Use correct package names in in-package forms (Reported by Johan
+ Parin)
+
+ * packages.lisp (acl-compat.system): Add nickname acl-compat.sys,
+ remove commented-out nicknames.
+
+ * lispworks/acl-sys.lisp: push MSWINDOWS onto *features* if
+ appropriate (Thanks to Alain Picard for the report).
+
+2003-05-11 Rudi Schlatte <rudi at constantly.at>
+
+ * acl-compat.asd: Don't load read-/write-sequence patches on cmucl
+ 18e.
+
+2003-05-06 Rudi Schlatte <rudi at constantly.at>
+
+ * lw-buffering.lisp (stream-fill-buffer): Implement
+ blocking/non-blocking semantics (read at least one byte per
+ fill-buffer call). Otherwise we'd get spurious EOFs with slow
+ servers.
+
+ * chunked-stream-mixin.lisp (gray-stream:stream-fill-buffer):
+ Return a sensible value (amount of bytes that can be read before
+ next call to fill-buffer).
+
+2003-05-03 Rudi Schlatte <rudi at constantly.at>
+
+ * chunked-stream-mixin.lisp (gray-stream:stream-fill-buffer): Make
+ input-chunking work, refactor somewhat to make all slot changes in
+ one place.
+
+2003-05-02 Rudi Schlatte <rudi at constantly.at>
+
+ * acl-compat.asd (acl-compat): Current cmucl versions handle Gray
+ streams in (read,write)-sequence -- remove hack
+
+2003-04-30 Rudi Schlatte <rudi at constantly.at>
+
+ * sbcl/acl-mp.lisp (with-timeout): Use timeout symbols from the
+ ext package; latest cvs exports them
+
+ * cmucl/acl-mp.lisp: Use acl-compat.mp package name.
+
+ * acl-compat.asd et al: The Great Renaming: begin move of
+ implementation-dependent files into subdirectories
+
+2003-04-27 Rudi Schlatte <rudi at constantly.at>
+
+ * acl-socket-sbcl.lisp: Implemented peername lookup (by storing
+ the socket in the plist of the bivalent stream object for now)
+
+2003-04-26 Rudi Schlatte <rudi at constantly.at>
+
+ * acl-mp-sbcl.lisp: Add initial support for multi-threaded sbcl
+
+2003-04-08 Rudi Schlatte <rudi at constantly.at>
+
+ * uri.lisp (render-uri): Reinstate with-output-to-string logic;
+ render-uri has to handle nil as a stream value.
+
+2003-04-03 Rudi Schlatte <rudi at constantly.at>
+
+ * uri.lisp (render-uri, print-object): Further frob printing of
+ URIs, inspired by patch of Harley Gorrell
+
+2003-04-02 Rudi Schlatte <rudi at constantly.at>
+
+ * uri.lisp (render-uri): Fix printing URIs in the presence of #\~
+ (Thanks to Harley Gorrell)
+
+2003-03-24 Rudi Schlatte <rudi at constantly.at>
+
+ * lw-buffering.lisp (stream-write-buffer, stream-flush-buffer):
+ Eliminate "wait" parameter to regain api-compatibility with lispworks
+ (stream-finish-output, stream-force-output): Call (finish|force)-output
+ here instead of using "wait" parameter of stream-flush-buffer
+
+ * chunked-stream-mixin.lisp: some documentation added, formatting,
+ eliminate use of "wait" parameter on stream-write-buffer etc.
+
+2003-02-28 Rudi Schlatte <rudi at constantly.at>
+
+ * acl-socket-sbcl.lisp:
+ (remote-host, remote-port, local-host, local-port): Change return
+ value to something convertible to an (invalid) inet address
+
+ * acl-compat.asd, packages.lisp: Support sbcl 0.7.13 single-threaded
+
+2002-12-26 Rudi Schlatte <rudi at constantly.at>
+
+ * lw-buffering.lisp (write-elements): end argument value can be
+ nil (fix contributed by Simon Andras 2002-12-24)
+
+ * meta.lisp: Switch to new-style eval-when times
+
+ * lw-buffering.lisp: Switch to new-style eval-when times
+ (defstruct buffer-state): Add type declarations
+ (stream-fill-buffer): Remove bug for non-cmucl case (need
+ unblocking read-sequence)
+
+ * chunked-stream-mixin.lisp: Add defgeneric forms
+
+ * acl-socket-sbcl.lisp: Enable chunked transfer encoding support
+
+2002-12-23 Rudi Schlatte <rudi at constantly.at>
+
+ * packages.lisp, acl-sys-sbcl.lisp: Various sbcl fixes
+
+2002-12-18 Rudi Schlatte <rudi at constantly.at>
+
+ * packages.lisp: Add package definition of
+ de.dataheaven.chunked-stream-mixin, remove nicknames for
+ acl-compat.system
+
+2002-12-17 Rudi Schlatte <rudi at constantly.at>
+
+ * (Module): Added first stab at sbcl support (some stub
+ functions, basic page serving works)
+
+2002-12-13 Rudi Schlatte <rudi at constantly.at>
+
+ * lw-buffering.lisp (stream-write-sequence): Make publish-multi
+ work (provide default value for start arg).
+
+ * acl-excl-cmu.lisp (write-vector): ditto.
+
+2002-12-03 Rudi Schlatte <rudi at constantly.at>
+
+ * acl-compat.asd: load lw-buffering in every implementation except
+ lispworks
+
+ * packages.lisp: define gray-stream package for every
+ implementation
Added: branches/trunk-reorg/thirdparty/acl-compat/README
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/README Thu Feb 7 03:21:48 2008
@@ -0,0 +1,33 @@
+-*- text -*-
+
+acl-compat is a library that implements parts of the Allegro Common
+Lisp (ACL) API for areas that are not covered by the ANSI Common Lisp
+standard itself (e.g. sockets, threading). The motivation for
+creating and maintaining acl-compat is to get the web server
+AllegroServe (that was released by Franz Inc under the LLGPL) running
+on a wide range of Lisp implementations, with as few source changes to
+its core code as possible.
+
+acl-compat names its packages by prepending the corresponding ACL
+package name with the string "ACL-COMPAT.". For example, the ACL
+threading API symbols are exported from the package ACL-COMPAT.MP.
+Ideally, ACL-specific code could run on any supported Lisp
+implementation only by changing package references.
+
+Of course, the present situation is not ideal. :( Functionality is
+only implemented on an as-needed basis, implemented functions don't
+handle all argument combinations properly, etc. On the other hand,
+enough is implemented to support a web and application server that
+exercises a wide range of functionality (client and server sockets,
+threading, etc.).
+
+
+To load acl-compat:
+
+- install asdf (see < http://www.cliki.net/asdf >) and make sure it's
+ loaded.
+
+- load acl-compat.asd
+
+- evaluate (asdf:operate 'asdf:load-op :acl-compat)
+
Added: branches/trunk-reorg/thirdparty/acl-compat/acl-compat-cmu.system
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/acl-compat-cmu.system Thu Feb 7 03:21:48 2008
@@ -0,0 +1,36 @@
+;;; -*- mode: lisp -*-
+
+(in-package :CL-USER)
+
+;; Stig: we're a debian-package if clc is present
+;; Rudi: Not if kludge-no-cclan is also present
+#+(and common-lisp-controller (not kludge-no-cclan))
+(setf (logical-pathname-translations "acl-compat")
+ '(("**;*.*.*" "cl-library:;acl-compat;**;*.*.*")))
+
+(mk:defsystem "ACL-COMPAT"
+ :source-pathname (make-pathname :directory
+ (pathname-directory *load-truename*)) ;"acl-compat:"
+; :source-extension "lisp"
+; :binary-pathname nil
+; :binary-extension nil
+ :components ((:file "nregex")
+ (:file "packages" :depends-on ("nregex"))
+ (:file "lw-buffering" :depends-on ("packages"))
+ (:file "acl-mp-cmu" :depends-on ("packages"))
+ (:file "acl-excl-cmu" :depends-on ("packages" "nregex"))
+ (:file "cmu-read-sequence")
+ (:file "acl-socket-cmu"
+ :depends-on ("packages" "acl-excl-cmu"
+ "chunked-stream-mixin"
+ "cmu-read-sequence"))
+ (:file "acl-sys-cmu" :depends-on ("packages"))
+ (:file "meta")
+ (:file "uri" :depends-on ("meta"))
+ (:file "chunked-stream-mixin"
+ :depends-on ("packages" "acl-excl-cmu"
+ "lw-buffering")))
+ ;; Stig: if we're CMU and a debian-package, we need graystreams
+ #+(and cmu common-lisp-controller)
+ :depends-on
+ #+(and cmu common-lisp-controller) (cmucl-graystream))
Added: branches/trunk-reorg/thirdparty/acl-compat/acl-compat-common-lisp-lw.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/acl-compat-common-lisp-lw.lisp Thu Feb 7 03:21:48 2008
@@ -0,0 +1,21 @@
+(defpackage acl-compat-common-lisp
+ (:use common-lisp)
+ (:shadow make-hash-table)
+ (:export make-hash-table))
+
+(in-package :acl-compat-common-lisp)
+
+(defun make-hash-table (&rest args &key test size rehash-size rehash-threshold (hash-function nil h-f-p)
+ (values t) weak-keys)
+ (declare (ignore hash-function))
+ (when h-f-p (error "User defined hash-functions are not supported."))
+ (let ((table (apply #'cl:make-hash-table :allow-other-keys t args)))
+ (hcl:set-hash-table-weak table
+ (if weak-keys
+ (if (eq values :weak)
+ :both
+ :key)
+ (if (eq values :weak)
+ :value
+ nil)))
+ table))
\ No newline at end of file
Added: branches/trunk-reorg/thirdparty/acl-compat/acl-compat-corman.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/acl-compat-corman.lisp Thu Feb 7 03:21:48 2008
@@ -0,0 +1,13 @@
+(require 'gray-streams)
+(in-package :cl-user)
+
+(defvar *acl-compat-directory* "d:/projects/lisp/portableaserve/acl-compat/")
+(load (concatenate 'string *acl-compat-directory* "nregex.lisp"))
+(load (concatenate 'string *acl-compat-directory* "meta.lisp"))
+(load (concatenate 'string *acl-compat-directory* "acl-excl-corman.lisp"))
+(load (concatenate 'string *acl-compat-directory* "acl-mp-corman.lisp"))
+(load (concatenate 'string *acl-compat-directory* "acl-socket-corman.lisp"))
+(load (concatenate 'string *acl-compat-directory* "uri.lisp"))
+(load (concatenate 'string *acl-compat-directory* "packages.lisp"))
+
+(pushnew :acl-compat *features*)
\ No newline at end of file
Added: branches/trunk-reorg/thirdparty/acl-compat/acl-compat.asd
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/acl-compat.asd Thu Feb 7 03:21:48 2008
@@ -0,0 +1,182 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; This as an ASDF system for ACL-COMPAT, meant to replace
+;;;; acl-compat-cmu.system, but could replace all other systems, too.
+;;;; (hint, hint)
+
+(defpackage #:acl-compat-system
+ (:use #:cl #:asdf))
+(in-package #:acl-compat-system)
+
+;;;; gray stream support for cmucl: Debian/common-lisp-controller has
+;;;; a `cmucl-graystream' system; if this is not found, we assume a
+;;;; cmucl downloaded from cons.org, where Gray stream support resides
+;;;; in the subsystems/ directory.
+
+
+#+cmu
+(progn
+
+(defclass precompiled-file (static-file)
+ ())
+
+(defmethod perform ((operation load-op) (c precompiled-file))
+ (load (component-pathname c)))
+
+(defmethod operation-done-p ((operation load-op) (c precompiled-file))
+ nil)
+
+#-gray-streams
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (unless (asdf:find-system :cmucl-graystream nil)
+ (asdf:defsystem cmucl-graystream
+ :pathname (make-pathname
+ :name nil :type nil :version nil
+ :defaults (truename "library:subsystems/gray-streams-library.x86f"))
+ :components ((:precompiled-file "gray-streams-library.x86f")))))
+)
+
+;;;; ignore warnings
+;;;;
+;;;; FIXME: should better fix warnings instead of ignoring them
+;;;; FIXME: (perform legacy-cl-sourcefile) duplicates ASDF code
+
+(defclass legacy-cl-source-file (cl-source-file)
+ ()
+ (:documentation
+ "Common Lisp source code module with (non-style) warnings.
+In contrast to CL-SOURCE-FILE, this class does not think that such warnings
+indicate failure."))
+
+(defmethod perform ((operation compile-op) (c legacy-cl-source-file))
+ (let ((source-file (component-pathname c))
+ (output-file (car (output-files operation c)))
+ (warnings-p nil)
+ (failure-p nil))
+ (setf (asdf::component-property c 'last-compiled) nil)
+ (handler-bind ((warning (lambda (c)
+ (declare (ignore c))
+ (setq warnings-p t)))
+ ;; _not_ (or error (and warning (not style-warning)))
+ (error (lambda (c)
+ (declare (ignore c))
+ (setq failure-p t))))
+ (compile-file source-file
+ :output-file output-file))
+ ;; rest of this method is as for CL-SOURCE-FILE
+ (setf (asdf::component-property c 'last-compiled) (file-write-date output-file))
+ (when warnings-p
+ (case (asdf::operation-on-warnings operation)
+ (:warn (warn "COMPILE-FILE warned while performing ~A on ~A"
+ c operation))
+ (:error (error 'compile-warned :component c :operation operation))
+ (:ignore nil)))
+ (when failure-p
+ (case (asdf::operation-on-failure operation)
+ (:warn (warn "COMPILE-FILE failed while performing ~A on ~A"
+ c operation))
+ (:error (error 'compile-failed :component c :operation operation))
+ (:ignore nil)))))
+
+;;;
+;;; This is thought to reduce reader-conditionals in the system definition
+;;;
+(defclass unportable-cl-source-file (cl-source-file) ()
+ (:documentation
+ "This is for files which contain lisp-system dependent code. Until now those
+are marked by a -system postfix but we could later change that to a directory per
+lisp-system"))
+
+(defmethod perform ((op load-op) (c unportable-cl-source-file))
+ (#+cmu ext:without-package-locks
+ #-(or cmu) progn
+ (call-next-method)))
+
+(defmethod perform ((op compile-op) (c unportable-cl-source-file))
+ (#+cmu ext:without-package-locks
+ #-(or cmu) progn
+ (call-next-method)))
+
+(defmethod source-file-type ((c unportable-cl-source-file) (s module))
+ "lisp")
+
+
+(defun lisp-system-shortname ()
+ #+allegro :allegro #+lispworks :lispworks #+cmu :cmucl
+ #+(or mcl openmcl) :mcl #+clisp :clisp #+scl :scl #+sbcl :sbcl) ;mcl/openmcl use the same directory
+
+(defmethod component-pathname ((component unportable-cl-source-file))
+ (let ((pathname (call-next-method))
+ (name (string-downcase (lisp-system-shortname))))
+ (merge-pathnames
+ (make-pathname :directory (list :relative name))
+ pathname)))
+
+;;;; system
+
+#+(and mcl (not openmcl)) (require :ansi-make-load-form)
+
+(defsystem acl-compat
+ :name "acl-compat"
+ :author "The acl-compat team"
+ :version "0.1.1"
+ :description
+ "A reimplementation of parts of the ACL API, mainly to get
+ AllegroServe running on various machines, but might be useful
+ in other projects as well."
+ :properties
+ ((("system" "author" "email") . "portableaserve-discuss at lists.sourceforge.net")
+ (("albert" "presentation" "output-dir") . "docs/")
+ (("albert" "presentation" "formats") . "docbook")
+ (("albert" "docbook" "dtd") . "/Users/Shared/DocBook/lib/docbook/docbook-dtd-412/docbookx.dtd")
+ (("albert" "docbook" "template") . "book"))
+ :components
+ (
+ ;; packages
+ (:file "packages")
+ ;; Our stream class; support for buffering, chunking and (in the
+ ;; future) unified stream exceptions
+ #-(or lispworks (and mcl (not openmcl)))
+ (:file "lw-buffering" :depends-on ("packages"))
+ #-(or allegro (and mcl (not openmcl)))
+ (:legacy-cl-source-file "chunked-stream-mixin"
+ :depends-on ("packages" "acl-excl"
+ #-lispworks "lw-buffering"))
+ ;; Multiprocessing
+ #+(or mcl openmcl) (:unportable-cl-source-file "mcl-timers")
+ (:unportable-cl-source-file "acl-mp"
+ :depends-on ("packages" #+(or mcl openmcl) "mcl-timers"))
+ ;; Sockets, networking; TODO: de-frob this a bit
+ #-(or mcl openmcl)
+ (:unportable-cl-source-file
+ "acl-socket" :depends-on ("packages" "acl-excl"
+ #-(or allegro (and mcl (not openmcl))) "chunked-stream-mixin"))
+ #+(and mcl (not openmcl))
+ (:unportable-cl-source-file "acl-socket-mcl" :depends-on ("packages"))
+ #+(and mcl (not openmcl) (not carbon-compat))
+ (:unportable-cl-source-file
+ "mcl-stream-fix" :depends-on ("acl-socket-mcl"))
+ #+openmcl
+ (:unportable-cl-source-file
+ "acl-socket-openmcl" :depends-on ("packages" "chunked-stream-mixin"))
+ ;; Diverse macros, utility functions
+ #-allegro (:file "acl-excl-common" :depends-on ("packages"))
+ (:unportable-cl-source-file "acl-excl" :depends-on
+ #-allegro ("acl-excl-common")
+ #+allegro ("packages"))
+ (:unportable-cl-source-file "acl-sys" :depends-on ("packages"))
+ ;; SSL
+ #+(and ssl-available (not (or allegro mcl openmcl clisp)))
+ (:file "acl-ssl" :depends-on ("acl-ssl-streams" "acl-socket"))
+ #+(and ssl-available (not (or allegro mcl openmcl clisp)))
+ (:file "acl-ssl-streams" :depends-on ("packages")))
+ ;; Dependencies
+ :depends-on (:puri
+ :cl-ppcre
+ #+sbcl :sb-bsd-sockets
+ #+sbcl :sb-posix
+ #+(and cmu (not gray-streams)) :cmucl-graystream
+ #+(and (or cmu lispworks) ssl-available) :cl-ssl
+ )
+ :perform (load-op :after (op acl-compat)
+ (pushnew :acl-compat cl:*features*)))
Added: branches/trunk-reorg/thirdparty/acl-compat/acl-excl-common.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/acl-excl-common.lisp Thu Feb 7 03:21:48 2008
@@ -0,0 +1,194 @@
+;;;;
+;;;; ACL-COMPAT - EXCL
+;;;;
+;;;; This is a modified version of Chris Doubles ACL excl wrapper library
+;;;; As stated in the changelogs of his original this file includes the
+;;;; IF* macro placed in the public domain by John Foderaro.
+;;;; See: http://www.franz.com/~jkf/ifstar.txt
+;;;;
+
+;;;; This file was made by Rudi Schlatte to gather
+;;;; not-implementation-specific parts of acl-compat in one place.
+
+;;;; This is the header of Chris Doubles original file. (but without Changelog)
+;;;;
+;;;; ACL excl wrapper library for Corman Lisp - Version 1.1
+;;;;
+;;;; Copyright (C) 2000 Christopher Double. All Rights Reserved.
+;;;;
+;;;; License
+;;;; =======
+;;;; This software is provided 'as-is', without any express or implied
+;;;; warranty. In no event will the author be held liable for any damages
+;;;; arising from the use of this software.
+;;;;
+;;;; Permission is granted to anyone to use this software for any purpose,
+;;;; including commercial applications, and to alter it and redistribute
+;;;; it freely, subject to the following restrictions:
+;;;;
+;;;; 1. The origin of this software must not be misrepresented; you must
+;;;; not claim that you wrote the original software. If you use this
+;;;; software in a product, an acknowledgment in the product documentation
+;;;; would be appreciated but is not required.
+;;;;
+;;;; 2. Altered source versions must be plainly marked as such, and must
+;;;; not be misrepresented as being the original software.
+;;;;
+;;;; 3. This notice may not be removed or altered from any source
+;;;; distribution.
+;;;;
+
+(in-package :acl-compat.excl)
+
+(defvar if*-keyword-list '("then" "thenret" "else" "elseif"))
+
+;this is not used in aserve, but is needed to use the franz xmlutils package with acl-compat
+(defvar *current-case-mode* :case-insensitive-upper)
+
+(defmacro if* (&rest args)
+ (do ((xx (reverse args) (cdr xx))
+ (state :init)
+ (elseseen nil)
+ (totalcol nil)
+ (lookat nil nil)
+ (col nil))
+ ((null xx)
+ (cond ((eq state :compl)
+ `(cond , at totalcol))
+ (t (error "if*: illegal form ~s" args))))
+ (cond ((and (symbolp (car xx))
+ (member (symbol-name (car xx))
+ if*-keyword-list
+ :test #'string-equal))
+ (setq lookat (symbol-name (car xx)))))
+
+ (cond ((eq state :init)
+ (cond (lookat (cond ((string-equal lookat "thenret")
+ (setq col nil
+ state :then))
+ (t (error
+ "if*: bad keyword ~a" lookat))))
+ (t (setq state :col
+ col nil)
+ (push (car xx) col))))
+ ((eq state :col)
+ (cond (lookat
+ (cond ((string-equal lookat "else")
+ (cond (elseseen
+ (error
+ "if*: multiples elses")))
+ (setq elseseen t)
+ (setq state :init)
+ (push `(t , at col) totalcol))
+ ((string-equal lookat "then")
+ (setq state :then))
+ (t (error "if*: bad keyword ~s"
+ lookat))))
+ (t (push (car xx) col))))
+ ((eq state :then)
+ (cond (lookat
+ (error
+ "if*: keyword ~s at the wrong place " (car xx)))
+ (t (setq state :compl)
+ (push `(,(car xx) , at col) totalcol))))
+ ((eq state :compl)
+ (cond ((not (string-equal lookat "elseif"))
+ (error "if*: missing elseif clause ")))
+ (setq state :init)))))
+
+(defvar *initial-terminal-io* *terminal-io*)
+(defvar *cl-default-special-bindings* nil)
+
+(defun filesys-size (stream)
+ (file-length stream))
+
+(defun filesys-write-date (stream)
+ (file-write-date stream))
+
+(defun frob-regexp (regexp)
+ "This converts from ACL regexps to Perl regexps. The escape
+ status of (, ) and | is toggled."
+ (let ((escapees '(#\) #\( #\| )))
+ (with-input-from-string (in regexp)
+ (with-output-to-string (out)
+ (loop for c = (read-char in nil nil nil)
+ while c
+ do (cond ((and (char= c #\\)
+ (member (peek-char nil in nil nil nil) escapees))
+ (setf c (read-char in)))
+ ((member c escapees)
+ (princ #\\ out)))
+ (princ c out))))))
+
+;; TODO: a compiler macro for constant string regexps would be nice,
+;; so that the create-scanner call at runtime can be evaded.
+(defun match-regexp (string-or-regexp string-to-match
+ &key newlines-special case-fold return
+ (start 0) end shortest)
+ "Note: if a regexp compiled with compile-regexp is passed, the
+ options newlines-special and case-fold shouldn't be used, since
+ the underlying engine uses them when generating the scanner,
+ not when executing it."
+ (when shortest (error "match-regexp: shortest option not supported yet."))
+ (unless end (setf end (length string-to-match)))
+ (let ((scanner (cl-ppcre:create-scanner (frob-regexp string-or-regexp)
+ :case-insensitive-mode case-fold
+ :single-line-mode newlines-special)))
+ (ecase return
+ (:string ; return t, list of strings
+ (multiple-value-bind (match regs)
+ (cl-ppcre:scan-to-strings scanner string-to-match
+ :start start :end end)
+ (if match
+ (apply #'values t match (coerce regs 'list))
+ nil)))
+ (:index ; return (cons start end)
+ (multiple-value-bind (start end reg-starts reg-ends)
+ (cl-ppcre:scan scanner string-to-match :start start :end end)
+ (and start (apply #'values t (cons start end)
+ (map 'list #'cons reg-starts reg-ends)))))
+ ((nil) ; return t
+ (not (not (cl-ppcre:scan scanner string-to-match
+ :start start :end end)))))))
+
+
+;; Caution Incompatible APIs! cl-ppcre has options case-insensitive,
+;; single-line for create-scanner, ACL has it in match-regexp.
+(defun compile-regexp (regexp)
+ "Note: Take care when using scanners compiled with this option
+ to not depend on options case-fold and newlines-special in match-regexp."
+ (cl-ppcre:create-scanner (frob-regexp regexp)))
+
+(defvar *current-case-mode* :case-insensitive-upper)
+
+(defun intern* (s len package)
+ (intern (subseq s 0 len) package))
+
+(defmacro errorset (form &optional (announce nil) (catch-breaks nil))
+ "This macro is incomplete. It was hacked to get AllegroServe
+running, but the announce and catch-breaks arguments are ignored. See
+documentation at
+http://franz.com/support/documentation/6.1/doc/pages/operators/excl/errorset.htm
+An implementation of the catch-breaks argument will necessarily be
+implementation-dependent, since Ansi does not allow any
+program-controlled interception of a break."
+ (declare (ignore announce catch-breaks))
+ `(let* ((ok nil)
+ (results (ignore-errors
+ (prog1 (multiple-value-list ,form)
+ (setq ok t)))))
+ (if ok
+ (apply #'values t results)
+ nil)))
+
+(defmacro fast (&body forms)
+ `(locally (declare (optimize (speed 3) (safety 0) (debug 0)))
+ , at forms))
+
+#-cmu
+(defun write-vector (sequence stream &key (start 0) end endian-swap)
+ (declare (ignore endian-swap))
+ (check-type sequence (or string (array (unsigned-byte 8) 1)
+ (array (signed-byte 8) 1)))
+ (write-sequence sequence stream :start start :end end))
+
Added: branches/trunk-reorg/thirdparty/acl-compat/acl-excl-corman.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/acl-excl-corman.lisp Thu Feb 7 03:21:48 2008
@@ -0,0 +1,233 @@
+;;;;
+;;;; ACL-COMPAT - EXCL
+;;;;
+;;;; This is a modified version of Chris Doubles ACL excl wrapper library
+;;;; As stated in the changelogs of his original this file includes the
+;;;; IF* macro placed in the public domain by John Foderaro.
+;;;; See: http://www.franz.com/~jkf/ifstar.txt
+;;;;
+;;;; It is not clear to this point if future releases will lead to a combined
+;;;; effort - So you may find newer versions of *this* file at
+;;;; http://www.dataheaven.de
+;;;;
+
+;;;; This is the header of Chris Doubles original file. (but without Changelog)
+;;;;
+;;;; ACL excl wrapper library for Corman Lisp - Version 1.1
+;;;;
+;;;; Copyright (C) 2000 Christopher Double. All Rights Reserved.
+;;;;
+;;;; License
+;;;; =======
+;;;; This software is provided 'as-is', without any express or implied
+;;;; warranty. In no event will the author be held liable for any damages
+;;;; arising from the use of this software.
+;;;;
+;;;; Permission is granted to anyone to use this software for any purpose,
+;;;; including commercial applications, and to alter it and redistribute
+;;;; it freely, subject to the following restrictions:
+;;;;
+;;;; 1. The origin of this software must not be misrepresented; you must
+;;;; not claim that you wrote the original software. If you use this
+;;;; software in a product, an acknowledgment in the product documentation
+;;;; would be appreciated but is not required.
+;;;;
+;;;; 2. Altered source versions must be plainly marked as such, and must
+;;;; not be misrepresented as being the original software.
+;;;;
+;;;; 3. This notice may not be removed or altered from any source
+;;;; distribution.
+;;;;
+;;;; Notes
+;;;; =====
+;;;; A simple implementation of some of the EXCL package from Allegro
+;;;; Common Lisp. Intended to be used for porting various ACL packages,
+;;;; like AllegroServe.
+;;;;
+;;;; More recent versions of this software may be available at:
+;;;; http://www.double.co.nz/cl
+;;;;
+;;;; Comments, suggestions and bug reports to the author,
+;;;; Christopher Double, at: chris at double.co.nz
+
+(require 'nregex)
+(require 'mp)
+
+(defpackage :excl
+ (:use :common-lisp :nregex)
+ (:import-from :common-lisp "FIXNUMP")
+ (:export
+ "IF*"
+ "*INITIAL-TERMINAL-IO*"
+ "*CL-DEFAULT-SPECIAL-BINDINGS*"
+ "FILESYS-SIZE"
+ "FILESYS-WRITE-DATE"
+ "STREAM-INPUT-FN"
+ "MATCH-REGEXP"
+ "COMPILE-REGEXP"
+ "*CURRENT-CASE-MODE*"
+ "INTERN*"
+ "FILESYS-TYPE"
+ "ERRORSET"
+ "ATOMICALLY"
+ "FAST"
+ "WITHOUT-PACKAGE-LOCKS"
+ "SOCKET-ERROR"
+ "RUN-SHELL-COMMAND"
+ "FIXNUMP"
+ ))
+
+(in-package :excl)
+
+(defvar if*-keyword-list '("then" "thenret" "else" "elseif"))
+
+(defmacro if* (&rest args)
+ (do ((xx (reverse args) (cdr xx))
+ (state :init)
+ (elseseen nil)
+ (totalcol nil)
+ (lookat nil nil)
+ (col nil))
+ ((null xx)
+ (cond ((eq state :compl)
+ `(cond , at totalcol))
+ (t (error "if*: illegal form ~s" args))))
+ (cond ((and (symbolp (car xx))
+ (member (symbol-name (car xx))
+ if*-keyword-list
+ :test #'string-equal))
+ (setq lookat (symbol-name (car xx)))))
+
+ (cond ((eq state :init)
+ (cond (lookat (cond ((string-equal lookat "thenret")
+ (setq col nil
+ state :then))
+ (t (error
+ "if*: bad keyword ~a" lookat))))
+ (t (setq state :col
+ col nil)
+ (push (car xx) col))))
+ ((eq state :col)
+ (cond (lookat
+ (cond ((string-equal lookat "else")
+ (cond (elseseen
+ (error
+ "if*: multiples elses")))
+ (setq elseseen t)
+ (setq state :init)
+ (push `(t , at col) totalcol))
+ ((string-equal lookat "then")
+ (setq state :then))
+ (t (error "if*: bad keyword ~s"
+ lookat))))
+ (t (push (car xx) col))))
+ ((eq state :then)
+ (cond (lookat
+ (error
+ "if*: keyword ~s at the wrong place " (car xx)))
+ (t (setq state :compl)
+ (push `(,(car xx) , at col) totalcol))))
+ ((eq state :compl)
+ (cond ((not (string-equal lookat "elseif"))
+ (error "if*: missing elseif clause ")))
+ (setq state :init)))))
+
+(defvar *initial-terminal-io* *terminal-io*)
+(defvar *cl-default-special-bindings* nil)
+
+(defun filesys-size (stream)
+ (file-length stream))
+
+(defun filesys-write-date (stream)
+ (file-write-date stream))
+
+#+obsolete
+(defun stream-input-fn (stream)
+ stream)
+
+(defmethod stream-input-fn ((stream stream))
+ stream)
+
+
+(defun match-regexp (pattern string &key (return :string))
+ (let ((res (cond ((stringp pattern)
+ (regex pattern string))
+ ((functionp pattern) (funcall pattern string))
+ (t (error "Wrong type for pattern")))))
+ (case return
+ (:string
+ (values-list (cons (not (null res))
+ res)))
+ (:index (error "REGEXP: INDEX Not implemented"))
+ (otherwise (not (null res))))))
+
+(defun compile-regexp (regexp)
+ (compile nil (regex-compile regexp)))
+
+(defvar *current-case-mode* :case-insensitive-upper)
+
+(defun intern* (s len package)
+ (intern (subseq s 0 len) package))
+
+(defun filesys-type (file-or-directory-name)
+ (if (ccl::directory-p file-or-directory-name)
+ :directory
+ (if (probe-file file-or-directory-name)
+ :file
+ nil)))
+
+(defmacro errorset (form &optional (announce nil) (catch-breaks nil))
+ "This macro is incomplete. It was hacked to get AllegroServe
+running, but the announce and catch-breaks arguments are ignored. See
+documentation at
+http://franz.com/support/documentation/6.1/doc/pages/operators/excl/errorset.htm
+An implementation of the catch-breaks argument will necessarily be
+implementation-dependent, since Ansi does not allow any
+program-controlled interception of a break."
+ (declare (ignore announce catch-breaks))
+ `(let* ((ok nil)
+ (results (ignore-errors
+ (prog1 (multiple-value-list ,form)
+ (setq ok t)))))
+ (if ok
+ (apply #'values t results)
+ nil)))
+
+
+(defmacro atomically (&body forms)
+ `(mp:without-scheduling , at forms))
+
+(defmacro fast (&body forms)
+ `(locally (declare (optimize (speed 3) (safety 0) (debug 0)))
+ , at forms))
+
+(defmacro without-package-locks (&body forms)
+ `(progn , at forms))
+
+(define-condition socket-error (error)
+ ((stream :initarg :stream)
+ (code :initarg :code :initform nil)
+ (action :initarg :action)
+ (identifier :initarg :identifier :initform nil))
+ (:report (lambda (e s)
+ (with-slots (identifier code action stream) e
+ (format s "~S (errno ~A) occured while ~A"
+ (case identifier
+ (:connection-refused "Connection refused")
+ (t identifier))
+ code action)
+ (when stream
+ (prin1 stream s))
+ (format s ".")))))
+
+#|
+(defun run-shell-command ()
+ (with-open-stream (s (open-pipe "/bin/sh"
+ :direction :io
+ :buffered nil))
+ (loop for var in environment
+ do (format stream "~A=~A~%" (car var) (cdr var)))
+|#
+
+
+(provide 'acl-excl)
Added: branches/trunk-reorg/thirdparty/acl-compat/acl-mp-corman.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/acl-mp-corman.lisp Thu Feb 7 03:21:48 2008
@@ -0,0 +1,52 @@
+;;; This file implements the process functions for AllegroServe in Corman Lisp.
+
+(require 'mp)
+
+(defpackage :acl-compat-mp
+ (:use :common-lisp :mp :sys)
+ (:export
+ #:process-interrrupt
+ #:make-process
+ #:make-process-lock
+ #:process-add-run-reason
+ #:process-kill
+ #:process-property-list
+ #:process-revoke-run-reason
+ #:process-run-function
+ #:with-process-lock
+ #:with-timeout
+ #:without-scheduling
+ #:*current-process*
+ #:lock
+ #:process-allow-schedule
+ #:process-name
+ #:process-preset
+ #:process-run-reasons
+ #:process-wait
+ #:without-interrupts
+ ))
+
+(in-package :acl-compat-mp)
+
+; existing stuff from ccl we can reuse directly
+;; The following process-property-list implementation was taken from
+;; the acl-mp-scl.lisp implementation.
+(defvar *process-plists* (make-hash-table :test #'eq)
+ "maps processes to their plists.
+See the functions process-plist, (setf process-plist).")
+
+(defun process-property-list (process)
+ (gethash process *process-plists*))
+
+(defun (setf process-property-list) (new-value process)
+ (setf (gethash process *process-plists*) new-value))
+
+;; Dummy implementation of process-wait
+(defun process-wait (whostate function &rest args)
+ "This function suspends the current process (the value of sys:*current-process*)
+ until applying function to arguments yields true. The whostate argument must be a
+ string which temporarily replaces the process' whostate for the duration of the wait.
+ This function returns nil."
+ (loop until (apply function args) do (sleep 0))
+ nil)
+
Added: branches/trunk-reorg/thirdparty/acl-compat/acl-mp-package.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/acl-mp-package.lisp Thu Feb 7 03:21:48 2008
@@ -0,0 +1,80 @@
+;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: CL-USER; -*-
+;;;; ;
+;;;; (c) 2001 by Jochen Schmidt.
+;;;;
+;;;; File: acl-mp-package.lisp
+;;;; Revision: 1.0.0
+;;;; Description: Package definition for ACL-COMPAT-MP
+;;;; Date: 02.02.2002
+;;;; Authors: Jochen Schmidt
+;;;; Tel: (+49 9 11) 47 20 603
+;;;; Email: jsc at dataheaven.de
+;;;;
+;;;; Redistribution and use in source and binary forms, with or without
+;;;; modification, are permitted provided that the following conditions
+;;;; are met:
+;;;; 1. Redistributions of source code must retain the above copyright
+;;;; notice, this list of conditions and the following disclaimer.
+;;;; 2. Redistributions in binary form must reproduce the above copyright
+;;;; notice, this list of conditions and the following disclaimer in the
+;;;; documentation and/or other materials provided with the distribution.
+;;;;
+;;;; THIS SOFTWARE IS PROVIDED "AS IS" AND THERE ARE NEITHER
+;;;; EXPRESSED NOR IMPLIED WARRANTIES - THIS INCLUDES, BUT
+;;;; IS NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+;;;; AND FITNESS FOR A PARTICULAR PURPOSE.IN NO WAY ARE THE
+;;;; AUTHORS LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;;;; SPECIAL, EXEMPLARY OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
+;;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES ;
+;;;; LOSS OF USE, DATA, OR PROFITS ; OR BUSINESS INTERRUPTION)
+;;;;
+;;;; For further details contact the authors of this software.
+;;;;
+;;;; Jochen Schmidt
+;;;; Zuckmantelstr. 11
+;;;; 91616 Neusitz
+;;;; GERMANY
+;;;;
+;;;;
+
+(defpackage :acl-compat-mp
+ (:use :common-lisp)
+ (:export
+ #:*current-process* ;*
+ #:process-kill ;*
+ #:process-preset ;*
+ #:process-name ;*
+
+ #:process-wait-function
+ #:process-run-reasons
+ #:process-arrest-reasons
+ #:process-whostate
+ #:without-interrupts
+ #:process-wait
+ #:process-enable
+ #:process-disable
+ #:process-reset
+ #:process-interrupt
+
+ #:process-run-function ;*
+ #:process-property-list ;*
+ #:without-scheduling ;*
+ #:process-allow-schedule ;*
+ #:make-process ;*
+ #:process-add-run-reason ;*
+ #:process-revoke-run-reason ;*
+ #:process-add-arrest-reason ;*
+ #:process-revoke-arrest-reason ;*
+ #:process-allow-schedule ;*
+ #:with-timeout ;*
+ #:make-process-lock ;*
+ #:with-process-lock ;*
+ #:process-active-p ; required by webactions
+ #:current-process
+ #:process-name-to-process
+ #:process-wait-with-timeout
+ #:wait-for-input-available
+ )
+ (:nicknames :acl-mp))
+
+;; * marked ones are used in Portable Allegroserve
Added: branches/trunk-reorg/thirdparty/acl-compat/acl-socket-corman.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/acl-socket-corman.lisp Thu Feb 7 03:21:48 2008
@@ -0,0 +1,194 @@
+;;;; ACL socket wrapper library for Corman Lisp - Version 1.1
+;;;;
+;;;; Copyright (C) 2000 Christopher Double. All Rights Reserved.
+;;;;
+;;;; License
+;;;; =======
+;;;; This software is provided 'as-is', without any express or implied
+;;;; warranty. In no event will the author be held liable for any damages
+;;;; arising from the use of this software.
+;;;;
+;;;; Permission is granted to anyone to use this software for any purpose,
+;;;; including commercial applications, and to alter it and redistribute
+;;;; it freely, subject to the following restrictions:
+;;;;
+;;;; 1. The origin of this software must not be misrepresented; you must
+;;;; not claim that you wrote the original software. If you use this
+;;;; software in a product, an acknowledgment in the product documentation
+;;;; would be appreciated but is not required.
+;;;;
+;;;; 2. Altered source versions must be plainly marked as such, and must
+;;;; not be misrepresented as being the original software.
+;;;;
+;;;; 3. This notice may not be removed or altered from any source
+;;;; distribution.
+;;;;
+;;;; Notes
+;;;; =====
+;;;; A simple wrapper around the SOCKETS package to present an interface
+;;;; similar to the Allegro Common Lisp SOCKET package. Based on a package
+;;;; by David Bakhash for LispWorks. For documentation on the ACL SOCKET
+;;;; package see:
+;;;;
+;;;; http://www.franz.com/support/documentation/5.0.1/doc/cl/socket.htm
+;;;;
+;;;; More recent versions of this software may be available at:
+;;;; http://www.double.co.nz/cl
+;;;;
+;;;; Comments, suggestions and bug reports to the author,
+;;;; Christopher Double, at: chris at double.co.nz
+;;;;
+;;;; 17/09/2000 - 1.0
+;;;; Initial release.
+;;;;
+;;;; 20/09/2000 - 1.1
+;;;; Added SOCKET-CONTROL function.
+;;;;
+;;;; 27/02/2001 - 1.2
+;;;; Added ability to create SSL sockets. Doesn't use
+;;;; same interface as Allegro 6 - need to look into
+;;;; how that works.
+;;;;
+;;;; 03/01/2003 - 1.3
+;;;; Added to PortableAllegroServe.
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (require :sockets)
+ (require :ssl-sockets))
+
+(sockets:start-sockets)
+(ssl-sockets:start-ssl-sockets)
+
+(defpackage socket
+ (:use "COMMON-LISP")
+ (:export
+ "MAKE-SOCKET"
+ "ACCEPT-CONNECTION"
+ "DOTTED-TO-IPADDR"
+ "IPADDR-TO-DOTTED"
+ "IPADDR-TO-HOSTNAME"
+ "LOOKUP-HOSTNAME"
+ "REMOTE-HOST"
+ "LOCAL-HOST"
+ "LOCAL-PORT"
+ "SOCKET-CONTROL"
+ ))
+
+(in-package :socket)
+
+(defmethod accept-connection ((server-socket sockets::server-socket)
+ &key (wait t))
+ (unless wait
+ (error "WAIT keyword to ACCEPT-CONNECTION not implemented."))
+ (sockets:make-socket-stream
+ (sockets:accept-socket server-socket)))
+
+(defun make-socket (&key
+ (remote-host "0.0.0.0") ;;localhost?
+ type
+ local-port
+ remote-port
+ (connect :active)
+ (format :text)
+ ssl
+ &allow-other-keys)
+ (check-type remote-host string)
+ (when (eq type :datagram)
+ (error ":DATAGRAM keyword to MAKE-SOCKET not implemented."))
+ (when (eq format :binary)
+ (warn ":BINARY keyword to MAKE-SOCKET partially implemented."))
+
+ (ecase connect
+ (:passive
+ (sockets:make-server-socket
+ :host remote-host
+ :port local-port))
+ (:active
+ (sockets:make-socket-stream
+ (if ssl
+ (ssl-sockets:make-client-ssl-socket
+ :host remote-host
+ :port remote-port)
+ (sockets:make-client-socket
+ :host remote-host
+ :port remote-port))))))
+
+
+(defun dotted-to-ipaddr (dotted &key errorp)
+ (when errorp
+ (warn ":ERRORP keyword to DOTTED-TO-IPADDR not supported."))
+ (sockets:host-to-ipaddr dotted))
+
+(defun ipaddr-to-dotted (ipaddr &key values)
+ (when values
+ (error ":VALUES keyword to IPADDR-TO-DOTTED not supported."))
+ (sockets:ipaddr-to-dotted ipaddr))
+
+(defun ipaddr-to-hostname (ipaddr &key ignore-cache)
+ (when ignore-cache
+ (warn ":IGNORE-CACHE keyword to IPADDR-TO-HOSTNAME not supported."))
+ (sockets:ipaddr-to-name ipaddr))
+
+(defun lookup-hostname (host &key ignore-cache)
+ (when ignore-cache
+ (warn ":IGNORE-CACHE keyword to IPADDR-TO-HOSTNAME not supported."))
+ (if (stringp host)
+ (sockets:host-to-ipaddr host)
+ (dotted-to-ipaddr (ipaddr-to-dotted host))))
+
+(defun remote-host (socket-or-stream)
+ (let ((socket (if (typep socket-or-stream 'sockets:base-socket)
+ socket-or-stream
+ (sockets:stream-socket-handle socket-or-stream))))
+ (sockets::remote-socket-ipaddr socket)))
+
+(defun local-host (socket-or-stream)
+ (let ((socket (if (typep socket-or-stream 'sockets:base-socket)
+ socket-or-stream
+ (sockets:stream-socket-handle socket-or-stream))))
+ (if (not (typep socket 'sockets:local-socket))
+ 16777343
+ (sockets::socket-host-ipaddr socket))))
+
+(defun local-port (socket-or-stream)
+ (let ((socket (if (typep socket-or-stream 'sockets:base-socket)
+ socket-or-stream
+ (sockets:stream-socket-handle socket-or-stream))))
+ (sockets:socket-port socket)))
+
+(defun socket-control (stream &key output-chunking output-chunking-eof input-chunking)
+ (declare (ignore stream output-chunking output-chunking-eof input-chunking))
+ (warn "SOCKET-CONTROL function not implemented."))
+
+;; Some workarounds to get combined text/binary socket streams working
+(defvar old-read-byte #'cl::read-byte)
+
+(defun new-read-byte (stream &optional (eof-error-p t) (eof-value nil))
+ "Replacement for Corman Lisp READ-BYTE to work with socket streams correctly."
+ (if (eq (cl::stream-subclass stream) 'sockets::socket-stream)
+ (char-int (read-char stream eof-error-p eof-value))
+ (funcall old-read-byte stream eof-error-p eof-value)))
+
+(setf (symbol-function 'common-lisp::read-byte) #'new-read-byte)
+
+(in-package :cl)
+
+(defun write-sequence (sequence stream &key start end)
+ (let ((element-type (stream-element-type stream))
+ (start (if start start 0))
+ (end (if end end (length sequence))))
+ (if (eq element-type 'character)
+ (do ((n start (+ n 1)))
+ ((= n end))
+ (write-char (if (typep (elt sequence n) 'number) (ccl:int-char (elt sequence n)) (elt sequence n)) stream))
+ (do ((n start (+ n 1)))
+ ((= n end))
+ (write-byte (elt sequence n) stream)))) ;; recoded to avoid LOOP, because it isn't loaded yet
+ ;(loop for n from start below end do
+ ; (write-char (elt sequence n) stream))
+ ;(loop for n from start below end do
+ ; (write-byte (elt sequence n) stream))
+ (force-output stream))
+
+(provide 'acl-socket)
+
Added: branches/trunk-reorg/thirdparty/acl-compat/acl-ssl-streams.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/acl-ssl-streams.lisp Thu Feb 7 03:21:48 2008
@@ -0,0 +1,293 @@
+;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: CL-USER; -*-
+;;;
+;;; Filename: gray-streams-integration.lisp
+;;; Author: Jochen Schmidt <jsc at dataheaven.de>
+;;; Description: Integrate ssl-sockets with the lisp
+;;; stream system using gray-streams.
+;;;
+
+(in-package :ssl)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Gray Streams integration ;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defclass ssl-stream-mixin ()
+ ((ssl-socket :accessor ssl-socket :initarg :ssl-socket)))
+
+(defclass binary-ssl-stream
+ (ssl-stream-mixin
+ gray-stream:fundamental-binary-input-stream
+ gray-stream:fundamental-binary-output-stream)
+ ())
+
+(defclass character-ssl-stream
+ (ssl-stream-mixin
+ gray-stream:fundamental-character-input-stream
+ gray-stream:fundamental-character-output-stream)
+ ())
+
+(defmethod #-cormanlisp gray-stream::stream-element-type #+cormanlisp gray-stream::stream-stream-element-type ((socket-stream binary-ssl-stream))
+ '(unsigned-byte 8))
+
+(defmethod #-cormanlisp gray-stream::stream-element-type #+cormanlisp gray-stream::stream-stream-element-type ((socket-stream character-ssl-stream))
+ 'character)
+
+(defmethod gray-stream:stream-line-column ((socket-stream character-ssl-stream))
+ nil)
+
+(defmethod gray-stream:stream-line-column ((socket-stream binary-ssl-stream))
+ nil)
+
+(defmethod gray-stream:stream-listen ((socket-stream ssl-stream-mixin))
+ (with-slots (ssl-socket) socket-stream
+ (> (ssl-internal:ssl-pending (ssl-internal:ssl-socket-handle ssl-socket)) 0)))
+
+(defmethod gray-stream:stream-read-byte ((socket-stream binary-ssl-stream))
+ (with-slots (ssl-socket) socket-stream
+ (ssl-internal:ssl-socket-read-byte ssl-socket)))
+
+(defmethod gray-stream:stream-write-byte ((socket-stream binary-ssl-stream) byte)
+ (with-slots (ssl-socket) socket-stream
+ (ssl-internal:ssl-socket-write-byte byte ssl-socket)))
+
+#|
+(defmethod gray-stream:stream-read-char ((socket-stream character-ssl-stream))
+ (with-slots (ssl-socket) socket-stream
+ (ssl-internal:ssl-socket-read-char ssl-socket)))
+
+(defmethod gray-stream:stream-read-char ((socket-stream binary-ssl-stream))
+ (with-slots (ssl-socket) socket-stream
+ (ssl-internal:ssl-socket-read-char ssl-socket)))
+|#
+
+; Bivalent
+(defmethod gray-stream:stream-read-char ((socket-stream ssl-stream-mixin))
+ (with-slots (ssl-socket) socket-stream
+ (ssl-internal:ssl-socket-read-char ssl-socket)))
+
+
+(defmethod gray-stream:stream-read-char-no-hang ((socket-stream character-ssl-stream))
+ (when (listen socket-stream)
+ (with-slots (ssl-socket) socket-stream
+ (ssl-internal:ssl-socket-read-char ssl-socket))))
+
+#|
+(defmethod gray-stream:stream-write-char ((socket-stream character-ssl-stream) char)
+ (with-slots (ssl-socket) socket-stream
+ (ssl-internal:ssl-socket-write-char char ssl-socket)))
+
+(defmethod gray-stream:stream-write-char ((socket-stream binary-ssl-stream) char)
+ (with-slots (ssl-socket) socket-stream
+ (ssl-internal:ssl-socket-write-char char ssl-socket)))
+|#
+
+; Bivalent
+(defmethod gray-stream:stream-write-char ((socket-stream ssl-stream-mixin) char)
+ (with-slots (ssl-socket) socket-stream
+ (ssl-internal:ssl-socket-write-char char ssl-socket)))
+
+
+
+; Bivalent
+(defmethod gray-stream:stream-force-output ((socket-stream ssl-stream-mixin))
+ (with-slots (ssl-socket) socket-stream
+ (ssl-internal:flush-output-buffer ssl-socket)))
+
+(defmethod gray-stream:stream-finish-output ((socket-stream ssl-stream-mixin))
+ (with-slots (ssl-socket) socket-stream
+ (ssl-internal:flush-output-buffer ssl-socket)))
+
+(defmethod gray-stream:stream-clear-output ((socket-stream ssl-stream-mixin))
+ (with-slots (ssl-socket) socket-stream
+ (with-slots (ssl-internal::output-offset) ssl-socket
+ (setf ssl-internal::output-offset 0))))
+
+(defmethod gray-stream:stream-clear-input ((socket-stream ssl-stream-mixin))
+ (with-slots (ssl-socket) socket-stream
+ (with-slots (ssl-internal::input-avail ssl-internal::input-offset) ssl-socket
+ (setf ssl-internal::input-avail 0)
+ (setf ssl-internal::input-offset 0))))
+
+(defmethod #-cormanlisp common-lisp:close #+cormanlisp gray-stream:stream-close ((socket-stream ssl-stream-mixin) &key abort)
+ (with-slots (ssl-socket) socket-stream
+ (unless abort
+ (ssl-internal:flush-output-buffer ssl-socket))
+ (ssl-internal:close-ssl-socket ssl-socket)))
+
+#|
+(defmethod gray-stream:stream-force-output ((socket-stream character-ssl-stream))
+ (with-slots (ssl-socket) socket-stream
+ (ssl-internal:flush-output-buffer ssl-socket)))
+
+(defmethod gray-stream:stream-finish-output ((socket-stream character-ssl-stream))
+ (with-slots (ssl-socket) socket-stream
+ (ssl-internal:flush-output-buffer ssl-socket)))
+
+(defmethod gray-stream:stream-clear-output ((socket-stream character-ssl-stream))
+ (with-slots (ssl-socket) socket-stream
+ (with-slots (ssl-internal::output-offset) ssl-socket
+ (setf ssl-internal::output-offset 0))))
+
+(defmethod gray-stream:stream-clear-input ((socket-stream character-ssl-stream))
+ (with-slots (ssl-socket) socket-stream
+ (with-slots (ssl-internal::input-avail ssl-internal::input-offset) ssl-socket
+ (setf ssl-internal::input-avail 0)
+ (setf ssl-internal::input-offset 0))))
+
+(defmethod gray-stream:stream-read-sequence ((socket-stream character-ssl-stream) sequence start end)
+ (let* ((len (length sequence))
+ (chars (- (min (or end len) len) start)))
+ ;(format t "Read ~A chars from index ~A on.~%" chars start) (force-output t)
+ (loop for i upfrom start
+ repeat chars
+ for char = (progn ;(format t "Read char on index ~A~%" i)
+ ;(force-output t)
+ (let ((c (gray-streams:stream-read-char socket-stream)))
+ ;(format t "The element read was ~A~%" c)
+ c))
+ if (eq char :eof) do (progn ;(format t "premature return on index ~A~%" i)
+ ;(force-output t)
+ (return-from gray-streams:stream-read-sequence i))
+ do (setf (elt sequence i) char))
+ ;(format t "Normal return on index ~A~%" (+ start chars)) (force-output t)
+ (+ start chars)))
+
+|#
+
+;;
+;; Why this argument ordering in CMUCL? LW has (stream sequence start end)
+;; It would be interesting to know why it is a particular good idea to
+;; reinvent APIs every second day in an incompatible way.... *grrr*
+;;
+
+#+cmu
+(defmethod gray-stream:stream-read-sequence ((socket-stream character-ssl-stream) (sequence sequence) &optional start end)
+ (let* ((len (length sequence))
+ (chars (- (min (or end len) len) start)))
+ (loop for i upfrom start
+ repeat chars
+ for char = (gray-stream:stream-read-char socket-stream)
+ if (eq char :eof) do (return-from gray-stream:stream-read-sequence i)
+ do (setf (elt sequence i) char))
+ (+ start chars)))
+
+#+cmu
+(defmethod gray-stream:stream-read-sequence ((socket-stream binary-ssl-stream) (sequence sequence) &optional start end)
+ (let* ((len (length sequence))
+ (chars (- (min (or end len) len) start)))
+ (loop for i upfrom start
+ repeat chars
+ for char = (gray-stream:stream-read-byte socket-stream)
+ if (eq char :eof) do (return-from gray-stream:stream-read-sequence i)
+ do (setf (elt sequence i) char))
+ (+ start chars)))
+
+#|
+(defmethod gray-stream:stream-read-sequence ((socket-stream binary-ssl-stream) sequence start end)
+ (let* ((len (length sequence))
+ (chars (- (min (or end len) len) start)))
+ ;(format t "Read ~A chars from index ~A on.~%" chars start) (force-output t)
+ (loop for i upfrom start
+ repeat chars
+ for char = (progn ;(format t "Read char on index ~A~%" i)
+ ;(force-output t)
+ (let ((c (gray-streams:stream-read-byte socket-stream)))
+ ;(format t "The element read was ~A~%" c)
+ c))
+ if (eq char :eof) do (progn ;(format t "premature return on index ~A~%" i)
+ ;(force-output t)
+ (return-from gray-streams:stream-read-sequence i))
+ do (setf (elt sequence i) char))
+ ;(format t "Normal return on index ~A~%" (+ start chars)) (force-output t)
+ (+ start chars)))
+|#
+
+#| Alternative implementation?
+(defmethod stream:stream-read-sequence ((socket-stream character-ssl-stream) sequence start end)
+ (let* ((len (length sequence))
+ (chars (- (min (or end len) len) start)))
+ (format t "Read ~A chars from index ~A on.~%" chars start) (force-output t)
+ (loop for i upfrom start
+ repeat chars
+ for char = (progn (format t "Read char on index ~A~%" i)
+ (force-output t)
+ (let ((c (stream:stream-read-char socket-stream)))
+ (format t "The element read was ~A~%" c) c))
+ if (eq char :eof) do (progn (format t "premature return on index ~A~%" i)
+ (force-output t)
+ (return-from stream:stream-read-sequence i))
+ do (setf (elt sequence i) char))
+ (format t "Normal return on index ~A~%" (+ start chars)) (force-output t)
+ (+ start chars)))
+|#
+
+#|
+(defmethod common-lisp:close ((socket-stream character-ssl-stream) &key abort)
+ (with-slots (ssl-socket) socket-stream
+ (unless abort
+ (ssl-internal:flush-output-buffer ssl-socket))
+ (ssl-internal:close-ssl-socket ssl-socket)))
+|#
+
+#+lispworks
+(declaim (inline %reader-function-for-sequence))
+#+lispworks
+(defun %reader-function-for-sequence (sequence)
+ (typecase sequence
+ (string #'read-char)
+ ((array unsigned-byte (*)) #'read-byte)
+ ((array signed-byte (*)) #'read-byte)
+ (otherwise #'read-byte)))
+
+#+lispworks
+(declaim (inline %writer-function-for-sequence))
+#+lispworks
+(defun %writer-function-for-sequence (sequence)
+ (typecase sequence
+ (string #'write-char)
+ ((array unsigned-byte (*)) #'write-byte)
+ ((array signed-byte (*)) #'write-byte)
+ (otherwise #'write-byte)))
+
+;; Bivalent socket support for READ-SEQUENCE / WRITE-SEQUENCE
+#+lispworks
+(defmethod gray-stream:stream-read-sequence ((stream ssl-stream-mixin) sequence start end)
+ (stream::read-elements stream sequence start end (%reader-function-for-sequence sequence)))
+
+#+lispworks
+(defmethod gray-stream:stream-write-sequence ((stream ssl-stream-mixin) sequence start end)
+ (stream::write-elements stream sequence start end (typecase sequence
+ (string t)
+ ((array unsigned-byte (*)) nil)
+ ((array signed-byte (*)) nil)
+ (otherwise nil))))
+
+#+lispworks
+(in-package :acl-socket)
+
+#+lispworks
+(defmethod remote-host ((socket ssl::ssl-stream-mixin))
+ (comm:get-socket-peer-address (ssl-internal::ssl-socket-fd (ssl::ssl-socket socket))))
+
+#+lispworks
+(defmethod remote-port ((socket ssl::ssl-stream-mixin))
+ (multiple-value-bind (host port)
+ (comm:get-socket-peer-address (ssl-internal::ssl-socket-fd (ssl::ssl-socket socket)))
+ (declare (ignore host))
+ port))
+
+#+lispworks
+(defmethod local-host ((socket ssl::ssl-stream-mixin))
+ (multiple-value-bind (host port)
+ (comm:get-socket-address (ssl-internal::ssl-socket-fd (ssl::ssl-socket socket)))
+ (declare (ignore port))
+ host))
+
+#+lispworks
+(defmethod local-port ((socket ssl::ssl-stream-mixin))
+ (multiple-value-bind (host port)
+ (comm:get-socket-address (ssl-internal::ssl-socket-fd (ssl::ssl-socket socket)))
+ (declare (ignore host))
+ port))
+
Added: branches/trunk-reorg/thirdparty/acl-compat/acl-ssl.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/acl-ssl.lisp Thu Feb 7 03:21:48 2008
@@ -0,0 +1,58 @@
+(in-package :ssl)
+;;;;;;;;;;;;;;;;;;;;;
+;;; ACL style API ;;;
+;;;;;;;;;;;;;;;;;;;;;
+
+(defmethod make-ssl-client-stream ((socket integer) &rest options)
+ (destructuring-bind (&key (format :binary)) options
+ (when (minusp socket)
+ (error "not a proper socket descriptor"))
+ (let ((ssl-socket (make-instance 'ssl-internal:ssl-client-socket :fd socket)))
+ (case format
+ (:binary (make-instance 'binary-ssl-stream
+ :ssl-socket ssl-socket))
+ (:text (make-instance 'character-ssl-stream
+ :ssl-socket ssl-socket))
+ (otherwise (error "Unknown ssl-stream format"))))))
+
+#+lispworks
+(defmethod make-ssl-client-stream ((lw-socket-stream comm:socket-stream) &rest options)
+ (apply #'make-ssl-client-stream (comm:socket-stream-socket lw-socket-stream) options))
+
+#+cormanlisp
+(defmethod make-ssl-client-stream (stream &rest options)
+ (apply #'make-ssl-client-stream (sockets:socket-descriptor (cl::stream-handle stream)) options))
+
+(defmethod make-ssl-server-stream ((socket integer) &rest options)
+ (destructuring-bind (&key certificate key other-certificates (format :binary)) options
+ (when (minusp socket)
+ (error "not a proper socket descriptor"))
+ (let ((ssl-socket (make-instance 'ssl-internal:ssl-server-socket
+ :fd socket
+ :rsa-privatekey-file (or key certificate)
+ :certificate-file (or certificate key))))
+ (case format
+ (:binary (make-instance 'binary-ssl-stream
+ :ssl-socket ssl-socket))
+ (:text (make-instance 'character-ssl-stream
+ :ssl-socket ssl-socket))
+ (otherwise (error "Unknown ssl-stream format"))))))
+
+(defmethod make-ssl-server-stream ((socket ssl-stream-mixin) &rest options)
+ (warn "SSL socket ~A reused" socket)
+ socket)
+
+#+lispworks
+(defmethod make-ssl-server-stream ((lw-socket-stream comm:socket-stream) &rest options)
+ (apply #'make-ssl-server-stream (comm:socket-stream-socket lw-socket-stream) options))
+
+
+#+ignore
+(defmethod make-ssl-server-stream ((acl-socket acl-socket::server-socket) &rest options)
+ (apply #'make-ssl-server-stream
+ (comm::get-fd-from-socket (acl-socket::passive-socket acl-socket)) options))
+
+#+ignore
+(defmethod make-ssl-server-stream ((lw-socket-stream acl-socket::chunked-socket-stream) &rest options)
+ (apply #'make-ssl-server-stream (comm:socket-stream-socket lw-socket-stream) options))
+
Added: branches/trunk-reorg/thirdparty/acl-compat/allegro/acl-excl.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/allegro/acl-excl.lisp Thu Feb 7 03:21:48 2008
@@ -0,0 +1,3 @@
+;;;; ACL-COMPAT - EXCL
+;;;;
+;;;; Nothing needs to be done
Added: branches/trunk-reorg/thirdparty/acl-compat/allegro/acl-mp.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/allegro/acl-mp.lisp Thu Feb 7 03:21:48 2008
@@ -0,0 +1,3 @@
+;;; This file implements the process functions for AllegroServe in MCL.
+
+(in-package :acl-compat.mp)
Added: branches/trunk-reorg/thirdparty/acl-compat/allegro/acl-socket.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/allegro/acl-socket.lisp Thu Feb 7 03:21:48 2008
@@ -0,0 +1,6 @@
+;;; Allegro layer for ACL sockets.
+;;;
+(in-package :acl-compat.socket)
+
+
+
Added: branches/trunk-reorg/thirdparty/acl-compat/allegro/acl-sys.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/allegro/acl-sys.lisp Thu Feb 7 03:21:48 2008
@@ -0,0 +1,4 @@
+;;; Allegro System Package Compatibility file
+
+;;; Nothing to do
+(in-package :acl-compat.system)
Added: branches/trunk-reorg/thirdparty/acl-compat/chunked-stream-mixin.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/chunked-stream-mixin.lisp Thu Feb 7 03:21:48 2008
@@ -0,0 +1,275 @@
+;;;; ;
+;;;; (c) 2002 by Jochen Schmidt.
+;;;;
+;;;; File: chunked-stream-mixin.lisp
+;;;; Revision: 0.1
+;;;; Description: ACL style HTTP1.1 I/O chunking
+;;;; Date: 08.04.2002
+;;;; Authors: Jochen Schmidt
+;;;; Tel: (+49 9 11) 47 20 603
+;;;; Email: jsc at dataheaven.de
+;;;;
+;;;; Redistribution and use in source and binary forms, with or without
+;;;; modification, are permitted provided that the following conditions
+;;;; are met:
+;;;; 1. Redistributions of source code must retain the above copyright
+;;;; notice, this list of conditions and the following disclaimer.
+;;;; 2. Redistributions in binary form must reproduce the above copyright
+;;;; notice, this list of conditions and the following disclaimer in the
+;;;; documentation and/or other materials provided with the distribution.
+;;;;
+;;;; THIS SOFTWARE IS PROVIDED "AS IS" AND THERE ARE NEITHER
+;;;; EXPRESSED NOR IMPLIED WARRANTIES - THIS INCLUDES, BUT
+;;;; IS NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+;;;; AND FITNESS FOR A PARTICULAR PURPOSE.IN NO WAY ARE THE
+;;;; AUTHORS LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;;;; SPECIAL, EXEMPLARY OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
+;;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES ;
+;;;; LOSS OF USE, DATA, OR PROFITS ; OR BUSINESS INTERRUPTION)
+;;;;
+;;;; For further details contact the authors of this software.
+;;;;
+;;;; Jochen Schmidt
+;;;; Zuckmantelstr. 11
+;;;; 91616 Neusitz
+;;;; GERMANY
+;;;;
+;;;; Nuernberg, 08.Apr.2002 Jochen Schmidt
+;;;;
+
+(in-package :de.dataheaven.chunked-stream-mixin)
+
+(defun buffer-ref (buffer index)
+ #+lispworks (schar buffer index)
+ #-lispworks (aref buffer index))
+
+(defun (setf buffer-ref) (new-value buffer index)
+ #-lispworks (setf (aref buffer index) (char-code new-value))
+ #+lispworks (setf (schar buffer index) new-value))
+
+(defclass chunked-stream-mixin ()
+ ((output-chunking-p :initform nil :accessor output-chunking-p)
+ (chunk-input-avail :initform nil
+ :documentation
+ "Number of octets of the current chunk that are
+not yet read into the buffer, or nil if input chunking is disabled")
+ (real-input-limit :initform 0
+ :documentation
+ "Index of last octet read into buffer
+(input-limit points to index of last octet in the current chunk)")))
+
+(defgeneric input-chunking-p (stream))
+(defmethod input-chunking-p ((stream chunked-stream-mixin))
+ (not (null (slot-value stream 'chunk-input-avail))))
+
+(defgeneric (setf input-chunking-p) (new-value stream))
+(defmethod (setf input-chunking-p) (new-value (stream chunked-stream-mixin))
+ (setf (slot-value stream 'chunk-input-avail) (and new-value 0)))
+
+(define-condition acl-compat.excl::socket-chunking-end-of-file (condition)
+ ((acl-compat.excl::format-arguments :initform nil :initarg :format-arguments)
+ (acl-compat.excl::format-control :initform "A chunking end of file occured"
+ :initarg :format-control)))
+
+
+;;;;;;;;;;;;;;;;;;;;;;
+;;; Input chunking ;;;
+;;;;;;;;;;;;;;;;;;;;;;
+
+;; Input chunking is not tested so far!
+
+(defgeneric initialize-input-chunking (stream))
+(defmethod initialize-input-chunking ((stream chunked-stream-mixin))
+ "This method initializes input chunking. The real-input-limit is nil
+in the beginnings because it got not saved yet. Chunk-input-avail is
+obviously 0 because no chunk-data got read so far."
+ (gray-stream:with-stream-input-buffer (input-buffer input-index input-limit)
+ stream
+ (with-slots (real-input-limit chunk-input-avail) stream
+ (setf
+ ;; Bytes read from stream (valid data in buffer up to here)
+ real-input-limit input-limit
+ ;; Bytes available in current chunk block after buffer contents
+ ;; runs out (trivially zero before first chunk block read)
+ chunk-input-avail 0
+ ;; Last buffer position that can be read before new data has to
+ ;; be fetched from stream (we must begin with parsing a chunk
+ ;; immediately; hence set to a value that guarantees this)
+ input-limit 0 ; or input-index?
+ ))))
+
+;; Lispworks fix by Edi Weitz (paserve-help 2003-11-28)
+#+lispworks
+(defmacro %with-stream-input-buffer ((input-buffer input-index input-limit) stream &body body)
+ `(with-slots ((,input-buffer stream::input-buffer)
+ (,input-index stream::input-index)
+ (,input-limit stream::input-limit))
+ (slot-value ,stream 'stream::buffer-state)
+ , at body))
+
+(defmethod gray-stream:stream-fill-buffer ((stream chunked-stream-mixin))
+ "Refill buffer from stream."
+ ;; STREAM-FILL-BUFFER gets called when the input-buffer contains no
+ ;; more data (the index is bigger than the limit). We call out to
+ ;; the real buffer filling mechanism by calling the next specialized
+ ;; method. This method is responsible to update the buffer state in
+ ;; coordination with the chunk-header.
+ (with-slots (chunk-input-avail real-input-limit) stream
+ (#-lispworks gray-stream:with-stream-input-buffer
+ #+lispworks %with-stream-input-buffer
+ (input-buffer input-index input-limit) stream
+ (labels
+ ((pop-char ()
+ (when (and (>= input-index input-limit) ; need new data
+ (not (call-next-method))) ; couldn't get it
+ (error "Unexpected end-of-file while reading chunk block"))
+ (prog1 #-lispworks (code-char (buffer-ref input-buffer input-index))
+ #+lispworks (buffer-ref input-buffer input-index)
+ (incf input-index)))
+ (read-chunk-header ()
+ (let ((chunk-length 0))
+ (tagbody
+ initial-crlf (let ((char (pop-char)))
+ (cond ((digit-char-p char 16)
+ (decf input-index) ; unread char
+ (go chunk-size))
+ ((eq #\Return char)
+ (if (eq (pop-char) #\Linefeed)
+ (go chunk-size)
+ (error "End of chunk-header corrupted: Expected Linefeed")))
+ (t (error "End of chunk-header corrupted: Expected Carriage Return or a digit"))))
+
+ chunk-size (let ((char (pop-char)))
+ (cond ((digit-char-p char 16)
+ (setf chunk-length
+ (+ (* 16 chunk-length)
+ (digit-char-p char 16)))
+ (go chunk-size))
+ (t (decf input-index) ; unread char
+ (go skip-rest))))
+
+ skip-rest (if (eq #\Return (pop-char))
+ (go check-linefeed)
+ (go skip-rest))
+
+ check-linefeed (let ((char (pop-char)))
+ (case char
+ (#\Linefeed (go accept))
+ (t (error "End of chunk-header corrupted: LF expected, ~A read." char))))
+
+ accept)
+ chunk-length)))
+
+ (cond ((not (input-chunking-p stream))
+ ;; Chunking not active; just fill buffer normally
+ (call-next-method))
+ ((zerop chunk-input-avail)
+ ;; We are at the beginning of a new chunk.
+ (when real-input-limit (setf input-limit real-input-limit))
+ (let* ((chunk-length (read-chunk-header))
+ (end-of-chunk (+ input-index chunk-length)))
+ (if (zerop chunk-length)
+ ;; rfc2616 indicates that input chunking is
+ ;; turned off after zero-length chunk is read
+ ;; (see section 19.4.6) -- turn off chunking
+ (progn (signal 'acl-compat.excl::socket-chunking-end-of-file
+ :format-arguments stream)
+ (setf (input-chunking-p stream) nil)
+ ;; TODO: whoever handles
+ ;; socket-chunking-end-of-file (client.cl
+ ;; in AllegroServe's case) should read the
+ ;; trailer (see section 3.6). All we can
+ ;; reasonably do here is turn off
+ ;; chunking, or throw information away.
+ )
+ ;; Now set up stream attributes so that read methods
+ ;; call refill-buffer both at end of chunk and end of
+ ;; buffer
+ (progn
+ (setf real-input-limit input-limit
+ input-limit (min real-input-limit end-of-chunk)
+ chunk-input-avail (max 0 (- end-of-chunk
+ real-input-limit)))
+ input-limit))))
+ (t
+ ;; We are in the middle of a chunk; re-fill buffer
+ (if (call-next-method)
+ (progn
+ (setf real-input-limit input-limit)
+ (setf input-limit
+ (min real-input-limit chunk-input-avail))
+ (setf chunk-input-avail
+ (max 0 (- chunk-input-avail real-input-limit)))
+ input-limit)
+ (error "Unexpected end-of-file in the middle of a chunk"))))))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;
+;;; Output chunking ;;;
+;;;;;;;;;;;;;;;;;;;;;;;
+
+;; This constant is the amount of bytes the system reserves for the chunk-header
+;; It is calculated as 4 bytes for the chunk-size in hexadecimal digits and a CR followed
+;; by a LF
+(defconstant +chunk-header-buffer-offset+ 6)
+
+(defgeneric initialize-output-chunking (stream))
+(defmethod initialize-output-chunking ((stream chunked-stream-mixin))
+ "This method initializes output chunking. Actual contents in the output-buffer
+ get flushed first. A chunk has a header at the start and a CRLF at the end.
+ The header is the length of the (data) content in the chunk as a string in hexadecimal
+ digits and a trailing CRLF before the real content begins. We assume that the content
+ of a chunk is never bigger than #xFFFF and therefore reserve 6 bytes at the beginning
+ of the buffer for the header. We reduce the buffer limit by 2 so that we have always
+ room left in the buffer to attach a CRLF."
+ (unless (output-chunking-p stream)
+ (force-output stream)
+ (gray-stream:with-stream-output-buffer (buffer index limit) stream
+ (setf index +chunk-header-buffer-offset+)
+ (setf (buffer-ref buffer (- +chunk-header-buffer-offset+ 2)) #\Return
+ (buffer-ref buffer (1- +chunk-header-buffer-offset+)) #\Linefeed)
+ (decf limit 2)
+ (setf (output-chunking-p stream) t))))
+
+(defmethod gray-stream:stream-flush-buffer ((stream chunked-stream-mixin))
+ "When there is pending content in the output-buffer then compute the chunk-header and flush
+ the buffer"
+ (if (output-chunking-p stream)
+ (gray-stream:with-stream-output-buffer (output-buffer output-index output-limit) stream
+ (when (> output-index +chunk-header-buffer-offset+)
+ (let* ((chunk-header (format nil "~X" (- output-index +chunk-header-buffer-offset+)))
+ (start (- +chunk-header-buffer-offset+ 2 (length chunk-header))))
+ (loop for c across chunk-header
+ for i upfrom start
+ do (setf (buffer-ref output-buffer i) c))
+ (setf (buffer-ref output-buffer output-index) #\Return
+ (buffer-ref output-buffer (1+ output-index)) #\Linefeed)
+ (gray-stream:stream-write-buffer stream output-buffer start (+ output-index 2))
+ (setf output-index +chunk-header-buffer-offset+))))
+ (call-next-method)))
+
+
+(defmethod close ((stream chunked-stream-mixin) &key abort)
+ (unless abort
+ (disable-output-chunking stream))
+ (call-next-method))
+
+
+(defgeneric disable-output-chunking (stream))
+(defmethod disable-output-chunking ((stream chunked-stream-mixin))
+ "When we disable chunking we first try to write out a last pending chunk and after that
+ reset the buffer-state to normal mode. To end the game we write out a chunk-header with
+ a chunk-size of zero to notify the peer that chunking ends."
+ (when (output-chunking-p stream)
+ (force-output stream)
+ (gray-stream:with-stream-output-buffer (buffer index limit) stream
+ (setf index 0)
+ (incf limit 2))
+ (setf (output-chunking-p stream) nil
+ (input-chunking-p stream) nil)
+ (format stream "0~A~A~A~A" #\Return #\Linefeed #\Return #\Linefeed)
+ (force-output stream)))
+
+
+
+
Added: branches/trunk-reorg/thirdparty/acl-compat/chunked.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/chunked.lisp Thu Feb 7 03:21:48 2008
@@ -0,0 +1,211 @@
+;;;
+;;; Streams with support for "chunked" transfer coding. This module
+;;; emulates the support for chunking found in Allegro Common Lisp's
+;;; streams. See RFC 2616 for a description of the "chunked" transfer
+;;; coding.
+;;;
+;;; TODO:
+;;; -
+
+(defpackage :com.ljosa.chunked
+ (:use :common-lisp #+LISPWORKS :stream)
+ (:export :chunked-mixin :make-chunked-stream :*buffer-size*
+ :output-chunking :input-chunking :close-chunk))
+
+(in-package :com.ljosa.chunked)
+
+(defparameter *buffer-size* 1024 "Maximum chunk size")
+
+(defvar *recursive* nil)
+
+(defclass chunked-mixin ()
+ ((output-chunking :initform nil :accessor output-chunking)
+ (input-chunking :initform nil :accessor input-chunking)
+ (output-buffer)
+ (remaining-input :initform nil)))
+
+(defmethod shared-initialize :after ((stream chunked-mixin) slots-for-initform
+ &rest initargs)
+ (declare (ignore initargs slots-for-initform))
+ (with-slots (output-buffer) stream
+ (setf output-buffer (make-array (list *buffer-size*)
+ :element-type 'unsigned-byte
+ :fill-pointer 0))))
+
+(define-condition excl::socket-chunking-end-of-file (condition)
+ ((excl::format-arguments :initform nil)
+ (excl::format-control :initform "~1@<The stream ~s had a chunking end of file~:@>")))
+
+;; (defmethod stream-element-type ((stream chunked-mixin))
+;; (call-next-method))
+
+(defun read-chunk-header (stream &aux (x 0) (*recursive* t))
+ (tagbody
+ s0 (let ((char (read-char stream)))
+ (cond ((digit-char-p char 16) (setf x (+ (* 16 x) (digit-char-p char 16)))
+ (go s0))
+ ((eq #\; char) (go s1))
+ ((eq #\; char) (go s2))
+ (t (error "Parse error in state s0: ~S." char))))
+ s1 (if (eq #\Return (read-char stream))
+ (go s2)
+ (go s1))
+ s2 (let ((char (read-char stream)))
+ (case char
+ (#\Linefeed (go accept))
+ (t (error "Parse error in state s2: ~S." char))))
+ accept)
+ x)
+
+;; FIXME: What do do when the chunked input stream can't be parsed?
+
+(defun gobble-crlf (stream &aux (*recursive* t))
+ (flet ((expect (expected-char)
+ (let ((char (read-char stream)))
+ (unless (eq expected-char char)
+ (error "Expected ~C, got ~C." expected-char char)))))
+ (expect #\Return)
+ (expect #\Linefeed)))
+
+(defmethod stream-read-char ((stream chunked-mixin))
+ (with-slots (input-chunking remaining-input output-chunking) stream
+ (cond (*recursive* (call-next-method))
+ ((not input-chunking) (call-next-method))
+ ((not remaining-input) (handler-case
+ (progn
+ (setf remaining-input (read-chunk-header stream))
+ (stream-read-char stream))
+ (end-of-file () :eof)))
+ ((> remaining-input 0) (decf remaining-input)
+ (call-next-method))
+ ((zerop remaining-input) (handler-case
+ (progn
+ (gobble-crlf stream)
+ (setf remaining-input (read-chunk-header stream))
+ (cond ((zerop remaining-input)
+ (setf input-chunking nil
+ output-chunking nil)
+ (signal 'excl::socket-chunking-end-of-file :format-arguments stream)
+ :eof)
+ (t (stream-read-char stream))))
+ (end-of-file () :eof))))))
+
+(defmethod stream-unread-char ((stream chunked-mixin) character)
+ (with-slots (input-chunking remaining-input) stream
+ (cond (*recursive* (call-next-method))
+ (input-chunking (incf remaining-input)
+ (call-next-method))
+ (t (call-next-method)))))
+
+(defmethod stream-read-line ((stream chunked-mixin))
+ (loop
+ with chars = nil
+ for char = (stream-read-char stream)
+ until (eq char #\Linefeed)
+ do
+ (if (eq char :eof)
+ (if (null chars)
+ (error 'end-of-file :stream stream)
+ (return (coerce chars 'string)))
+ (push char chars))
+ finally (return (coerce (nreverse chars) 'string))))
+
+(defmethod stream-read-sequence ((stream chunked-mixin) sequence start end)
+ (loop
+ for i from start below end
+ do
+ (let ((char (stream-read-char stream)))
+ (case char
+ (:eof (return i))
+ (t (setf (elt sequence i) char))))
+ finally (return i)))
+
+(defmethod stream-clear-input ((stream chunked-mixin))
+ (with-slots (input-chunking) stream
+ (cond (*recursive* (call-next-method))
+ (input-chunking nil)
+ (t (call-next-method)))))
+
+(defmethod stream-write-byte ((stream chunked-mixin) byte)
+ (check-type byte unsigned-byte)
+ (if *recursive*
+ (call-next-method)
+ (with-slots (output-buffer) stream
+ (or (vector-push byte output-buffer)
+ (progn
+ (stream-force-output stream)
+ (stream-write-byte stream byte))))))
+
+(defmethod stream-write-char ((stream chunked-mixin) character)
+ (if *recursive*
+ (call-next-method)
+ (stream-write-byte stream (char-code character))))
+
+(defmethod stream-write-sequence ((stream chunked-mixin) sequence start end)
+ (loop
+ for i from start below end
+ do
+ (let ((e (elt sequence i)))
+ (etypecase e
+ (integer (stream-write-byte stream e))
+ (character (stream-write-char stream e))))))
+
+(defmethod stream-write-string ((stream chunked-mixin) string &optional
+ (start 0) (end (length string)))
+ (stream-write-sequence stream string start end))
+
+(defmethod write-crlf ((stream stream))
+ (let ((*recursive* t))
+ (write-char #\Return stream)
+ (write-char #\Linefeed stream)))
+
+(defmethod stream-force-output ((stream chunked-mixin))
+ (with-slots (output-chunking output-buffer) stream
+ (when (> (fill-pointer output-buffer) 0)
+ (let ((*recursive* t))
+ (when output-chunking
+ (let ((*print-base* 16))
+ (princ (fill-pointer output-buffer) stream))
+ (write-crlf stream))
+ (write-sequence output-buffer stream)
+ (setf (fill-pointer output-buffer) 0)
+ (when output-chunking
+ (write-crlf stream)))))
+ (call-next-method))
+
+(defmethod stream-finish-output ((stream chunked-mixin))
+ (unless *recursive*
+ (force-output stream))
+ (call-next-method))
+
+(defmethod stream-clear-output ((stream chunked-mixin))
+ (with-slots (output-chunking output-buffer) stream
+ (if (and output-chunking (not *recursive*))
+ (setf (fill-pointer output-buffer) 0)
+ (call-next-method))))
+
+(defmethod close ((stream chunked-mixin) &key abort)
+ (unless abort
+ (finish-output stream))
+ (with-slots (output-chunking output-buffer) stream
+ (when (and output-chunking
+ (> (fill-pointer output-buffer) 0))
+ (close-chunk stream)))
+ (call-next-method))
+
+(defmethod close-chunk ((stream chunked-mixin))
+ (finish-output stream)
+ (with-slots (output-chunking input-chunking) stream
+ (if output-chunking
+ (let ((*recursive* t))
+ (princ 0 stream)
+ (write-crlf stream)
+ (write-crlf stream)
+ (finish-output stream)
+ (setf output-chunking nil
+ input-chunking nil))
+ (error "Chunking is not enabled for output on this stream: ~S."
+ stream))))
+
+(provide :com.ljosa.chunked)
+
Added: branches/trunk-reorg/thirdparty/acl-compat/clisp/acl-excl.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/clisp/acl-excl.lisp Thu Feb 7 03:21:48 2008
@@ -0,0 +1,70 @@
+;;;;
+;;;; ACL-COMPAT - EXCL
+;;;;
+
+;;;; Implementation-specific parts of acl-compat.excl (see
+;;;; acl-excl-common.lisp)
+
+(in-package :acl-compat.excl)
+
+(defun fixnump (x)
+ (sys::fixnump x))
+
+(defun stream-input-fn (stream)
+ stream)
+
+(defun filesys-type (file-or-directory-name)
+ ;; Taken from clocc's port library, with thanks to Sam Steingold
+ (if (values
+ (ignore-errors
+ (#+lisp=cl ext:probe-directory #-lisp=cl lisp:probe-directory
+ file-or-directory-name)))
+ :directory
+ (if (probe-file file-or-directory-name)
+ :file
+ nil)))
+
+(defmacro atomically (&body forms)
+ ;; No multiprocessing here, move along...
+ `(progn , at forms))
+
+(defun unix-signal (signal pid)
+ (declare (ignore signal pid))
+ (error "clisp unix-signal not implemented yet."))
+
+(defmacro without-package-locks (&body forms)
+ `(ext:without-package-lock ,(list-all-packages) , at forms))
+
+(defun fixnump (x)
+ (sys::fixnump x))
+
+(defun string-to-octets (string &key (null-terminate t) (start 0)
+ end mb-vector make-mb-vector?
+ (external-format :default))
+ "This function returns a lisp-usb8-vector and the number of bytes copied."
+ (declare (ignore external-format))
+ ;; The end parameter is different in ACL's lambda list, but this
+ ;; variant lets us give an argument :end nil explicitly, and the
+ ;; right thing will happen
+ (unless end (setf end (length string)))
+ (let* ((number-of-octets (if null-terminate (1+ (- end start))
+ (- end start)))
+ (mb-vector (cond
+ ((and mb-vector (>= (length mb-vector) number-of-octets))
+ mb-vector)
+ ((or (not mb-vector) make-mb-vector?)
+ (make-array (list number-of-octets)
+ :element-type '(unsigned-byte 8)
+ :initial-element 0))
+ (t (error "Was given a vector of length ~A, ~
+ but needed at least length ~A."
+ (length mb-vector) number-of-octets)))))
+ (declare (type (simple-array (unsigned-byte 8) (*)) mb-vector))
+ (loop for from-index from start below end
+ for to-index upfrom 0
+ do (progn
+ (setf (aref mb-vector to-index)
+ (char-code (aref string from-index)))))
+ (when null-terminate
+ (setf (aref mb-vector (1- number-of-octets)) 0))
+ (values mb-vector number-of-octets)))
Added: branches/trunk-reorg/thirdparty/acl-compat/clisp/acl-mp.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/clisp/acl-mp.lisp Thu Feb 7 03:21:48 2008
@@ -0,0 +1,74 @@
+;; Stubs for multiprocessing functions under clisp. Clisp does not
+;; provide threads at the time of writing, so these functions are here
+;; only to compile aserve with a minimum of changes in the main code.
+;;
+;; Written by Rudi Schlatte
+
+
+(in-package :acl-compat-mp)
+
+(defvar *current-process*)
+
+(defun process-allow-schedule ()
+ (values))
+
+(defun process-allow-scheduling ()
+ (values))
+
+(defun process-plist (process)
+ (declare (ignore process))
+ (error "Attempting to use multithreading with clisp."))
+
+(defun (setf process-plist) (new-value process)
+ (declare (ignore new-value process))
+ (error "Attempting to use multithreading with clisp."))
+
+(defun process-run-reasons (process)
+ (declare (ignore process))
+ (error "Attempting to use multithreading with clisp."))
+
+(defun (setf process-run-reasons) (new-value process)
+ (declare (ignore new-value process))
+ (error "Attempting to use multithreading with clisp."))
+
+(defun process-revoke-run-reason (process object)
+ (declare (ignore process object))
+ (error "Attempting to use multithreading with clisp."))
+
+(defun process-add-run-reason (process object)
+ (declare (ignore process object))
+ (error "Attempting to use multithreading with clisp."))
+
+(defun process-run-function (name function &rest arguments)
+ (declare (ignore name function arguments))
+ (error "Attempting to use multithreading with clisp."))
+
+(defun process-kill (process)
+ (declare (ignore process))
+ (error "Attempting to use multithreading with clisp."))
+
+(defmacro with-gensyms (syms &body body)
+ "Bind symbols to gensyms. First sym is a string - `gensym' prefix.
+Inspired by Paul Graham, <On Lisp>, p. 145."
+ `(let (,@(mapcar (lambda (sy) `(,sy (gensym ,(car syms)))) (cdr syms)))
+ , at body))
+
+(defun interrupt-process (process function &rest args)
+ (declare (ignore process function args))
+ (error "Attempting to use multithreading with clisp."))
+
+(defun make-process-lock (&key name)
+ (declare (ignore name))
+ (error "Attempting to use multithreading with clisp."))
+
+(defmacro with-process-lock ((lock &key norecursive whostate timeout)
+ &body forms)
+ (declare (ignore lock norecursive whostate timeout))
+ `(progn , at forms))
+
+(defmacro with-timeout ((seconds &body timeout-forms) &body body)
+ (declare (ignore seconds timeout-forms))
+ `(progn , at body))
+
+(defmacro without-scheduling (&body body)
+ `(progn , at body))
Added: branches/trunk-reorg/thirdparty/acl-compat/clisp/acl-socket.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/clisp/acl-socket.lisp Thu Feb 7 03:21:48 2008
@@ -0,0 +1,174 @@
+;; This package is designed for clisp. It implements the
+;; ACL-style socket interface on top of clisp.
+;;
+;; Written by Rudi Schlatte, based on the work done by Jochen Schmidt
+;; for Lispworks and net.lisp in the port library of CLOCC.
+
+(in-package :acl-socket)
+
+(defclass server-socket ()
+ ((port :type fixnum
+ :initarg :port
+ :reader port)
+ (stream-type :type (member :text :binary :bivalent)
+ :initarg :stream-type
+ :reader stream-type
+ :initform (error "No value supplied for stream-type"))
+ (clisp-socket-server :initarg :clisp-socket-server
+ :reader clisp-socket-server)))
+
+(defmethod print-object ((server-socket server-socket) stream)
+ (print-unreadable-object (server-socket stream :type t :identity nil)
+ (format stream "@port ~d" (port server-socket))))
+
+(defun %get-element-type (format)
+ (ecase format
+ (:text 'character)
+ (:binary '(unsigned-byte 8))
+ (:bivalent '(unsigned-byte 8))) )
+
+(defgeneric accept-connection (server-socket &key wait))
+(defmethod accept-connection ((server-socket server-socket)
+ &key (wait t))
+ "Return a bidirectional stream connected to socket, or nil if no
+client wanted to initiate a connection and wait is nil."
+ (when (cond ((numberp wait)
+ (socket-wait (clisp-socket-server server-socket) wait))
+ (wait (socket-wait (clisp-socket-server server-socket)))
+ (t (socket-wait (clisp-socket-server server-socket) 0)))
+ (let ((stream (socket-accept (clisp-socket-server server-socket)
+ :element-type (%get-element-type
+ (stream-type server-socket))
+ )))
+ (if (eq (stream-type server-socket) :bivalent)
+ (make-bivalent-stream stream)
+ stream))))
+
+
+(defun make-socket (&key (remote-host "localhost")
+ local-port
+ remote-port
+ (connect :active)
+ (format :text)
+ &allow-other-keys)
+ "Return a stream connected to remote-host if connect is :active, or
+something listening on local-port that can be fed to accept-connection
+if connect is :passive."
+ (check-type remote-host string)
+ (ecase connect
+ (:passive
+ (make-instance 'server-socket
+ :port local-port
+ :clisp-socket-server (socket-server local-port)
+ :stream-type format))
+ (:active
+ (let ((stream (socket-connect
+ remote-port remote-host
+ :element-type (%get-element-type format)
+ )))
+ (if (eq format :bivalent)
+ (make-bivalent-stream stream)
+ stream)))))
+
+(defmethod close ((server-socket server-socket) &key abort)
+ "Kill a passive (listening) socket. (Active sockets are actually
+streams and handled by their close methods."
+ (declare (ignore abort))
+ (socket-server-close (clisp-socket-server server-socket)))
+
+(declaim (ftype (function ((unsigned-byte 32)) (values simple-string))
+ ipaddr-to-dotted))
+(defun ipaddr-to-dotted (ipaddr &key values)
+ (declare (type (unsigned-byte 32) ipaddr))
+ (let ((a (logand #xff (ash ipaddr -24)))
+ (b (logand #xff (ash ipaddr -16)))
+ (c (logand #xff (ash ipaddr -8)))
+ (d (logand #xff ipaddr)))
+ (if values
+ (values a b c d)
+ (format nil "~d.~d.~d.~d" a b c d))))
+
+(defun string-tokens (string)
+ (labels ((get-token (str pos1 acc)
+ (let ((pos2 (position #\Space str :start pos1)))
+ (if (not pos2)
+ (nreverse acc)
+ (get-token str (1+ pos2) (cons (read-from-string (subseq str pos1 pos2))
+ acc))))))
+ (get-token (concatenate 'string string " ") 0 nil)))
+
+(declaim (ftype (function (string &key (:errorp t))
+ (values (unsigned-byte 32)))
+ dotted-to-ipaddr))
+(defun dotted-to-ipaddr (dotted &key (errorp t))
+ (declare (string dotted))
+ (if errorp
+ (let ((ll (string-tokens (substitute #\Space #\. dotted))))
+ (+ (ash (first ll) 24) (ash (second ll) 16)
+ (ash (third ll) 8) (fourth ll)))
+ (ignore-errors
+ (let ((ll (string-tokens (substitute #\Space #\. dotted))))
+ (+ (ash (first ll) 24) (ash (second ll) 16)
+ (ash (third ll) 8) (fourth ll))))))
+
+
+(defun ipaddr-to-hostname (ipaddr &key ignore-cache)
+ (when ignore-cache
+ (warn ":IGNORE-CACHE keyword in IPADDR-TO-HOSTNAME not supported."))
+ (posix::hostent-name (posix:resolve-host-ipaddr ipaddr)))
+
+(defun lookup-hostname (host &key ignore-cache)
+ (when ignore-cache
+ (warn ":IGNORE-CACHE keyword in LOOKUP-HOSTNAME not supported."))
+ (if (stringp host)
+ (car (posix::hostent-addr-list (posix:resolve-host-ipaddr host)))
+ (dotted-to-ipaddr (ipaddr-to-dotted host))))
+
+(defgeneric get-clisp-stream (stream))
+
+(defmethod get-clisp-stream ((stream gray-stream::native-lisp-stream-mixin))
+ (gray-stream::native-lisp-stream stream))
+
+(defmethod get-clisp-stream ((stream t))
+ (the stream stream))
+
+(defun remote-host (socket-stream)
+ (dotted-to-ipaddr
+ (nth-value 0 (socket-stream-peer (get-clisp-stream socket-stream) t))))
+
+(defun remote-port (socket-stream)
+ (nth-value 1 (socket-stream-peer (get-clisp-stream socket-stream) t)))
+
+(defun local-host (socket-stream)
+ (dotted-to-ipaddr
+ (nth-value 0 (socket-stream-local (get-clisp-stream socket-stream) t))))
+
+(defun local-port (socket-stream)
+ (nth-value 1 (socket-stream-local (get-clisp-stream socket-stream) t)))
+
+;; Now, throw chunking in the mix
+
+(defclass chunked-stream (de.dataheaven.chunked-stream-mixin::chunked-stream-mixin
+ gray-stream::buffered-bivalent-stream)
+ ((plist :initarg :plist :accessor stream-plist)))
+
+
+(defun make-bivalent-stream (lisp-stream &key plist)
+ (make-instance 'chunked-stream :lisp-stream lisp-stream :plist plist))
+
+
+(defun socket-control (stream &key (output-chunking nil oc-p) output-chunking-eof (input-chunking nil ic-p))
+ (when oc-p
+ (when output-chunking
+ (de.dataheaven.chunked-stream-mixin::initialize-output-chunking stream))
+ (setf (de.dataheaven.chunked-stream-mixin::output-chunking-p stream)
+ output-chunking))
+ (when output-chunking-eof
+ (de.dataheaven.chunked-stream-mixin::disable-output-chunking stream))
+ (when ic-p
+ (when input-chunking
+ (de.dataheaven.chunked-stream-mixin::initialize-input-chunking stream))
+ (setf (de.dataheaven.chunked-stream-mixin::input-chunking-p stream)
+ input-chunking)))
+
+(provide 'acl-socket)
Added: branches/trunk-reorg/thirdparty/acl-compat/clisp/acl-sys.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/clisp/acl-sys.lisp Thu Feb 7 03:21:48 2008
@@ -0,0 +1,22 @@
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (ext:without-package-lock ()
+ (let ((sys-package (find-package "SYSTEM")))
+ (export (list (intern "COMMAND-LINE-ARGUMENTS" sys-package)
+ (intern "COMMAND-LINE-ARGUMENT" sys-package)
+ (intern "REAP-OS-SUBPROCESS" sys-package))
+ sys-package))))
+
+(ext:without-package-lock ()
+ (defun sys:command-line-arguments ()
+ ext:*args*))
+
+(ext:without-package-lock ()
+ (defun sys:command-line-argument (n)
+ (nth n ext:*args*)))
+
+(ext:without-package-lock ()
+ (defun sys:reap-os-subprocess (&key (wait nil))
+ (declare (ignore wait))
+ nil))
+
Added: branches/trunk-reorg/thirdparty/acl-compat/cmucl/acl-excl.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/cmucl/acl-excl.lisp Thu Feb 7 03:21:48 2008
@@ -0,0 +1,71 @@
+;;;;
+;;;; ACL-COMPAT - EXCL
+;;;;
+
+;;;; Implementation-specific parts of acl-compat.excl (see
+;;;; acl-excl-common.lisp)
+
+(in-package :acl-compat.excl)
+
+(defun stream-input-fn (stream)
+ stream)
+
+(defun filesys-type (file-or-directory-name)
+ (if (eq :directory (unix:unix-file-kind
+ (namestring file-or-directory-name)))
+ :directory
+ (if (probe-file file-or-directory-name)
+ :file
+ nil)))
+
+(defmacro atomically (&body forms)
+ `(mp:without-scheduling , at forms))
+
+(defun unix-signal (signal pid)
+ ;; fixxme: did I get the arglist right? only invocation I have seen
+ ;; is (excl::unix-signal 15 0) in net.aserve:start
+ (unix:unix-kill pid signal))
+
+(defmacro without-package-locks (&body forms)
+ `(progn , at forms))
+
+(defun filesys-inode (path)
+ (multiple-value-bind (found ign inode)
+ (unix:unix-lstat path)
+ (if found
+ inode
+ (error "path ~s does not exist" path))))
+
+(defun cl-internal-real-time ()
+ (round (/ (get-internal-real-time) internal-time-units-per-second)))
+
+(defun string-to-octets (string &key (null-terminate t) (start 0)
+ end mb-vector make-mb-vector?
+ (external-format :default))
+ "This function returns a lisp-usb8-vector and the number of bytes copied."
+ (declare (ignore external-format))
+ ;; The end parameter is different in ACL's lambda list, but this
+ ;; variant lets us give an argument :end nil explicitly, and the
+ ;; right thing will happen
+ (unless end (setf end (length string)))
+ (let* ((number-of-octets (if null-terminate (1+ (- end start))
+ (- end start)))
+ (mb-vector (cond
+ ((and mb-vector (>= (length mb-vector) number-of-octets))
+ mb-vector)
+ ((or (not mb-vector) make-mb-vector?)
+ (make-array (list number-of-octets)
+ :element-type '(unsigned-byte 8)
+ :initial-element 0))
+ (t (error "Was given a vector of length ~A, ~
+ but needed at least length ~A."
+ (length mb-vector) number-of-octets)))))
+ (declare (type (simple-array (unsigned-byte 8) (*)) mb-vector))
+ (loop for from-index from start below end
+ for to-index upfrom 0
+ do (progn
+ (setf (aref mb-vector to-index)
+ (char-code (aref string from-index)))))
+ (when null-terminate
+ (setf (aref mb-vector (1- number-of-octets)) 0))
+ (values mb-vector number-of-octets)))
Added: branches/trunk-reorg/thirdparty/acl-compat/cmucl/acl-mp.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/cmucl/acl-mp.lisp Thu Feb 7 03:21:48 2008
@@ -0,0 +1,170 @@
+;; This package is designed for cmucl. It implements ACL-style
+;; multiprocessing on top of cmucl (basically, process run reasons and
+;; some function renames).
+;;
+;; Written by Rudi Schlatte, based on the work done by Jochen Schmidt
+;; for Lispworks.
+
+(in-package :acl-compat.mp)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Import equivalent parts from the CMU MP package ;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(shadowing-import '(mp:*current-process*
+ ;; mp::process-preset
+ mp::process-reset
+ mp:process-interrupt
+ mp::process-name
+ mp::process-wait-function
+ mp:process-run-reasons
+ mp:process-add-run-reason
+ mp:process-revoke-run-reason
+ mp:process-arrest-reasons
+ mp:process-add-arrest-reason
+ mp:process-revoke-arrest-reason
+ mp:process-whostate
+ ; mp:without-interrupts
+ mp:process-wait
+ mp:with-timeout
+ mp:without-scheduling
+ mp:process-active-p
+ ))
+
+(export '(*current-process*
+ ;; process-preset
+ process-reset
+ process-interrupt
+ process-name
+ process-wait-function
+ process-whostate
+ process-wait
+ with-timeout
+ without-scheduling
+ process-run-reasons
+ process-add-run-reason
+ process-revoke-run-reason
+ process-arrest-reasons
+ process-add-arrest-reason
+ process-revoke-arrest-reason
+ process-active-p
+ ))
+
+
+(defun process-allow-schedule ()
+ (mp:process-yield))
+
+(defvar *process-plists* (make-hash-table :test #'eq)
+ "maps processes to their plists.
+See the functions process-plist, (setf process-plist).")
+
+(defun process-property-list (process)
+ (gethash process *process-plists*))
+
+(defun (setf process-property-list) (new-value process)
+ (setf (gethash process *process-plists*) new-value))
+
+#||
+
+;;; rudi 2002-06-09: This is not needed as of cmucl 18d, thanks to Tim
+;;; Moore who added run reasons to cmucl's multithreading. Left in
+;;; for the time being just in case someone wants to get acl-compat
+;;; running on older cmucl's. Can be deleted safely.
+
+(defvar *process-run-reasons* (make-hash-table :test #'eq)
+ "maps processes to their run-reasons.
+See the functions process-run-reasons, (setf process-run-reasons),
+process-add-run-reason, process-revoke-run-reason.")
+
+(defun process-run-reasons (process)
+ (gethash process *process-run-reasons*))
+
+(defun (setf process-run-reasons) (new-value process)
+ (mp:without-scheduling
+ (prog1
+ (setf (gethash process *process-run-reasons*) new-value)
+ (if new-value
+ (mp:enable-process process)
+ (mp:disable-process process)))))
+
+(defun process-revoke-run-reason (process object)
+ (without-scheduling
+ (setf (process-run-reasons process)
+ (remove object (process-run-reasons process))))
+ (when (and (eq process mp:*current-process*))
+ (mp:process-yield)))
+
+(defun process-add-run-reason (process object)
+ (setf (process-run-reasons process)
+ (pushnew object (process-run-reasons process))))
+||#
+
+(defun process-run-function (name-or-options preset-function
+ &rest preset-arguments)
+ (let ((process (etypecase name-or-options
+ (string (make-process :name name-or-options
+ :run-reasons '(t)))
+ (list (apply #'make-process :run-reasons '(t)
+ name-or-options)))))
+ (apply #'acl-mp::process-preset process preset-function preset-arguments)
+ process))
+
+(defun process-preset (process preset-function &rest arguments)
+ (mp:process-preset process
+ #'(lambda ()
+ (apply-with-bindings preset-function
+ arguments
+ (process-initial-bindings process)))))
+
+(defvar *process-initial-bindings* (make-hash-table :test #'eq))
+
+(defun process-initial-bindings (process)
+ (gethash process *process-initial-bindings*))
+
+(defun (setf process-initial-bindings) (bindings process)
+ (setf (gethash process *process-initial-bindings*) bindings))
+
+
+;;; ;;;
+;;; Contributed by Tim Moore ;;;
+;;; ;;;
+(defun apply-with-bindings (function args bindings)
+ (if bindings
+ (progv
+ (mapcar #'car bindings)
+ (mapcar #'(lambda (binding)
+ (eval (cdr binding)))
+ bindings)
+ (apply function args))
+ (apply function args)))
+
+(defun make-process (&key (name "Anonymous") reset-action run-reasons
+ arrest-reasons (priority 0) quantum resume-hook
+ suspend-hook initial-bindings run-immediately)
+ (declare (ignore priority quantum reset-action resume-hook suspend-hook
+ run-immediately))
+ (mp:make-process nil :name name
+ :run-reasons run-reasons
+ :arrest-reasons arrest-reasons
+ :initial-bindings initial-bindings))
+
+(defun process-kill (process)
+ (mp:destroy-process process))
+
+
+(defun make-process-lock (&key name)
+ (mp:make-lock name))
+
+(defun process-lock (lock)
+ (mp::lock-wait lock (mp:process-whostate mp:*current-process*)))
+
+(defun process-unlock (lock)
+ (setf (mp::lock-process lock) nil))
+
+
+(defmacro with-process-lock ((lock &key norecursive whostate timeout) &body forms)
+ (declare (ignore norecursive))
+ `(mp:with-lock-held (,lock
+ ,@(when whostate (list :whostate whostate))
+ ,@(when timeout (list :timeout timeout)))
+ , at forms))
Added: branches/trunk-reorg/thirdparty/acl-compat/cmucl/acl-socket.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/cmucl/acl-socket.lisp Thu Feb 7 03:21:48 2008
@@ -0,0 +1,208 @@
+;; This package is designed for cmucl. It implements the
+;; ACL-style socket interface on top of cmucl.
+;;
+;; Written by Rudi Schlatte, based on the work done by Jochen Schmidt
+;; for Lispworks and net.lisp in the port library of CLOCC.
+
+(in-package acl-compat.socket)
+
+(defclass socket ()
+ ((fd :type fixnum
+ :initarg :fd
+ :reader fd)))
+
+(defmethod print-object ((socket socket) stream)
+ (print-unreadable-object (socket stream :type t :identity t)
+ (format stream "@~d" (fd socket))))
+
+(defclass server-socket (socket)
+ ((element-type :type (member signed-byte unsigned-byte base-char)
+ :initarg :element-type
+ :reader element-type
+ :initform (error "No value supplied for element-type"))
+ (port :type fixnum
+ :initarg :port
+ :reader port
+ :initform (error "No value supplied for port"))
+ (stream-type :type (member :text :binary :bivalent)
+ :initarg :stream-type
+ :reader stream-type
+ :initform (error "No value supplied for stream-type"))))
+
+#+cl-ssl
+(defmethod make-ssl-server-stream ((lisp-stream system:lisp-stream)
+ &rest options)
+ (apply #'make-ssl-server-stream (system:fd-stream-fd lisp-stream) options))
+
+(defmethod print-object ((socket server-socket) stream)
+ (print-unreadable-object (socket stream :type t :identity nil)
+ (format stream "@~d on port ~d" (fd socket) (port socket))))
+
+(defmethod accept-connection ((server-socket server-socket)
+ &key (wait t))
+ "Return a bidirectional stream connected to socket, or nil if no
+client wanted to initiate a connection and wait is nil."
+ ;; fixxme: perhaps check whether we run multiprocessing and use
+ ;; sys:wait-until-fd-usable instead of
+ ;; mp:process-wait-until-fd-usable here?
+
+ ;; api pipe fitting: wait t ==> timeout nil
+ (when (mp:process-wait-until-fd-usable (fd server-socket) :input
+ (if wait nil 0))
+ (let ((stream (sys:make-fd-stream
+ (ext:accept-tcp-connection (fd server-socket))
+ :input t :output t
+ :element-type (element-type server-socket)
+ :auto-close t)))
+ (if (eq (stream-type server-socket) :bivalent)
+ (make-bivalent-stream stream)
+ stream))))
+
+(defun make-socket (&key (remote-host "localhost")
+ local-port
+ remote-port
+ (connect :active)
+ (format :text)
+ (reuse-address t)
+ &allow-other-keys)
+ "Return a stream connected to remote-host if connect is :active, or
+something listening on local-port that can be fed to accept-connection
+if connect is :passive.
+
+This is an incomplete implementation of ACL's make-socket function!
+It was written to provide the functionality necessary to port
+AllegroServe. Refer to
+http://franz.com/support/documentation/6.1/doc/pages/operators/socket/make-socket.htm
+to read about the missing parts."
+ (check-type remote-host string)
+ (let ((element-type (ecase format
+ (:text 'base-char)
+ (:binary 'signed-byte)
+ (:bivalent 'unsigned-byte))))
+ (ecase connect
+ (:passive
+ (make-instance 'server-socket
+ :port local-port
+ :fd (ext:create-inet-listener local-port :stream :reuse-address reuse-address)
+ :element-type element-type
+ :stream-type format))
+ (:active
+ (let ((stream (sys:make-fd-stream
+ (ext:connect-to-inet-socket remote-host remote-port)
+ :input t :output t :element-type element-type)))
+ (if (eq :bivalent format)
+ (make-bivalent-stream stream)
+ stream))))))
+
+(defmethod close ((server server-socket) &key abort)
+ "Kill a passive (listening) socket. (Active sockets are actually
+streams and handled by their close methods."
+ (declare (ignore abort))
+ (unix:unix-close (fd server)))
+
+(declaim (ftype (function ((unsigned-byte 32) &key (:values t))
+ (values simple-string))
+ ipaddr-to-dotted))
+(defun ipaddr-to-dotted (ipaddr &key values)
+ (declare (type (unsigned-byte 32) ipaddr))
+ (let ((a (logand #xff (ash ipaddr -24)))
+ (b (logand #xff (ash ipaddr -16)))
+ (c (logand #xff (ash ipaddr -8)))
+ (d (logand #xff ipaddr)))
+ (if values
+ (values a b c d)
+ (format nil "~d.~d.~d.~d" a b c d))))
+
+(defun string-tokens (string)
+ (labels ((get-token (str pos1 acc)
+ (let ((pos2 (position #\Space str :start pos1)))
+ (if (not pos2)
+ (nreverse acc)
+ (get-token str (1+ pos2) (cons (read-from-string (subseq str pos1 pos2))
+ acc))))))
+ (get-token (concatenate 'string string " ") 0 nil)))
+
+(declaim (ftype (function (string &key (:errorp t))
+ (values (unsigned-byte 32)))
+ dotted-to-ipaddr))
+(defun dotted-to-ipaddr (dotted &key (errorp t))
+ (declare (string dotted))
+ (if errorp
+ (let ((ll (string-tokens (substitute #\Space #\. dotted))))
+ (+ (ash (first ll) 24) (ash (second ll) 16)
+ (ash (third ll) 8) (fourth ll)))
+ (ignore-errors
+ (let ((ll (string-tokens (substitute #\Space #\. dotted))))
+ (+ (ash (first ll) 24) (ash (second ll) 16)
+ (ash (third ll) 8) (fourth ll))))))
+
+(defun ipaddr-to-hostname (ipaddr &key ignore-cache)
+ (when ignore-cache
+ (warn ":IGNORE-CACHE keyword in IPADDR-TO-HOSTNAME not supported."))
+ (ext:host-entry-name (ext:lookup-host-entry ipaddr)))
+
+(defun lookup-hostname (host &key ignore-cache)
+ (when ignore-cache
+ (warn ":IGNORE-CACHE keyword in LOOKUP-HOSTNAME not supported."))
+ (if (stringp host)
+ (car (ext:host-entry-addr-list (ext:lookup-host-entry host)))
+ (dotted-to-ipaddr (ipaddr-to-dotted host))))
+
+(defgeneric get-fd (stream))
+
+(defmethod get-fd ((stream gray-stream::native-lisp-stream-mixin))
+ (system:fd-stream-fd (gray-stream::native-lisp-stream stream)))
+
+(defmethod get-fd ((stream system:lisp-stream))
+ (system:fd-stream-fd stream))
+
+(defmethod get-fd ((stream server-socket))
+ (fd stream))
+
+(defun remote-host (socket-stream)
+ (ext:get-peer-host-and-port (get-fd socket-stream)))
+
+(defun remote-port (socket-stream)
+ (multiple-value-bind (host port)
+ (ext:get-peer-host-and-port (get-fd socket-stream))
+ (declare (ignore host))
+ port))
+
+(defun local-host (socket-stream)
+ (ext:get-socket-host-and-port (get-fd socket-stream)))
+
+(defun local-port (socket-stream)
+ (if (typep socket-stream 'socket::server-socket)
+ (port socket-stream)
+ (multiple-value-bind (host port)
+ (ext:get-socket-host-and-port (get-fd socket-stream))
+ (declare (ignore host))
+ port)))
+
+;; Now, throw chunking in the mix
+
+(defclass chunked-stream (de.dataheaven.chunked-stream-mixin::chunked-stream-mixin
+ gray-stream::buffered-bivalent-stream)
+ ())
+
+
+(defun make-bivalent-stream (lisp-stream)
+ (make-instance 'chunked-stream :lisp-stream lisp-stream))
+
+
+(defun socket-control (stream &key (output-chunking nil oc-p) output-chunking-eof (input-chunking nil ic-p))
+ (when oc-p
+ (when output-chunking
+ (de.dataheaven.chunked-stream-mixin::initialize-output-chunking stream))
+ (setf (de.dataheaven.chunked-stream-mixin::output-chunking-p stream)
+ output-chunking))
+ (when output-chunking-eof
+ (de.dataheaven.chunked-stream-mixin::disable-output-chunking stream))
+ (when ic-p
+ (when input-chunking
+ (de.dataheaven.chunked-stream-mixin::initialize-input-chunking stream))
+ (setf (de.dataheaven.chunked-stream-mixin::input-chunking-p stream)
+ input-chunking)))
+
+
+(provide 'acl-socket)
Added: branches/trunk-reorg/thirdparty/acl-compat/cmucl/acl-sys.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/cmucl/acl-sys.lisp Thu Feb 7 03:21:48 2008
@@ -0,0 +1,18 @@
+(in-package :acl-compat.system)
+
+(ignore-errors
+(export 'command-line-arguments)
+(export 'command-line-argument)
+(export 'reap-os-subprocess)
+
+(defun command-line-arguments ()
+ ext:*command-line-strings*)
+
+(defun command-line-argument (n)
+ (nth n ext:*command-line-strings*))
+
+(defun reap-os-subprocess (&key (wait nil))
+ (declare (ignore wait))
+ nil)
+
+)
Added: branches/trunk-reorg/thirdparty/acl-compat/defsys.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/defsys.lisp Thu Feb 7 03:21:48 2008
@@ -0,0 +1,50 @@
+(in-package "CL-USER")
+
+(defsystem "ACL-COMPAT"
+ (:default-pathname "ACL-COMPAT:")
+ :members
+ ("acl-compat-common-lisp-lw"
+ "nregex"
+ "acl-excl-lw"
+ "acl-mp-package"
+ "acl-mp-lw"
+ "gray-stream-package"
+ "acl-socket-lw"
+ "acl-sys-lw"
+ "meta"
+ "uri"
+ "chunked-stream-mixin")
+
+ :rules
+ ((:in-order-to :compile "acl-excl-lw"
+ (:caused-by (:compile "nregex"))
+ (:requires (:load "nregex")))
+ (:in-order-to :load "acl-excl-lw"
+ (:requires (:load "nregex")))
+
+ (:in-order-to :compile "acl-mp-lw"
+ (:caused-by (:compile "acl-mp-package" "acl-socket-lw"))
+ (:requires (:load "acl-mp-package" "acl-socket-lw")))
+ (:in-order-to :load "acl-mp-lw"
+ (:requires (:load "acl-mp-package" "acl-socket-lw")))
+
+ (:in-order-to :compile "acl-socket-lw"
+ (:caused-by (:compile "chunked-stream-mixin"))
+ (:requires (:load "chunked-stream-mixin")))
+ (:in-order-to :load "acl-socket-lw"
+ (:requires (:load "chunked-stream-mixin")))
+
+ (:in-order-to :compile "chunked-stream-mixin"
+ (:caused-by (:compile "acl-excl-lw" "gray-stream-package"))
+ (:requires (:load "acl-excl-lw" "gray-stream-package")))
+ (:in-order-to :load "chunked-stream-mixin"
+ (:requires (:load "acl-excl-lw" "gray-stream-package")))
+
+ (:in-order-to :compile "uri"
+ (:caused-by (:compile "meta"))
+ (:requires (:load "meta")))
+ (:in-order-to :load "uri"
+ (:requires (:load "meta")))))
+
+(eval-when (:load-toplevel :execute)
+ (pushnew :acl-compat *features*))
Added: branches/trunk-reorg/thirdparty/acl-compat/lispworks/acl-excl.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/lispworks/acl-excl.lisp Thu Feb 7 03:21:48 2008
@@ -0,0 +1,85 @@
+;;;;
+;;;; ACL-COMPAT - EXCL
+;;;;
+
+;;;; Implementation-specific parts of acl-compat.excl (see
+;;;; acl-excl-common.lisp)
+
+(in-package :acl-compat.excl)
+
+#+obsolete
+(defun stream-input-fn (stream)
+ stream)
+
+(defmethod stream-input-fn ((stream stream))
+ stream)
+
+(defun filesys-type (file-or-directory-name)
+ (if (lw::file-directory-p file-or-directory-name)
+ :directory
+ (if (probe-file file-or-directory-name)
+ :file
+ nil)))
+
+#-:win32
+(defun filesys-inode (path)
+ (let ((checked-path (probe-file path)))
+ (cond
+ (checked-path (let ((stat (system:get-file-stat checked-path)))
+ (system:file-stat-inode stat)))
+ (t (error "path ~a does not exist." path)))))
+
+(defmacro atomically (&body forms)
+ `(mp:without-preemption , at forms))
+
+(defmacro without-package-locks (&body forms)
+ `(progn , at forms))
+
+
+#|
+(defun run-shell-command ()
+ (with-open-stream (s (open-pipe "/bin/sh"
+ :direction :io
+ :buffered nil))
+ (loop for var in environment
+ do (format stream "~A=~A~%" (car var) (cdr var)))
+|#
+
+;; NDL 2004-06-04 -- Missing definition & a package, to allow LispWorks to load webactions
+
+(defun cl-internal-real-time ()
+ (round (/ (get-internal-real-time) 1000)))
+
+(defun string-to-octets (string &key (null-terminate t) (start 0)
+ end mb-vector make-mb-vector?
+ (external-format :default))
+ "This function returns a lisp-usb8-vector and the number of bytes copied."
+ (declare (ignore external-format))
+ ;; The end parameter is different in ACL's lambda list, but this
+ ;; variant lets us give an argument :end nil explicitly, and the
+ ;; right thing will happen
+ (unless end (setf end (length string)))
+ (let* ((number-of-octets (if null-terminate (1+ (- end start))
+ (- end start)))
+ (mb-vector (cond
+ ((and mb-vector (>= (length mb-vector) number-of-octets))
+ mb-vector)
+ ((or (not mb-vector) make-mb-vector?)
+ (make-array (list number-of-octets)
+ :element-type '(unsigned-byte 8)
+ :initial-element 0))
+ (t (error "Was given a vector of length ~A, ~
+ but needed at least length ~A."
+ (length mb-vector) number-of-octets)))))
+ (declare (type (simple-array (unsigned-byte 8) (*)) mb-vector))
+ (loop for from-index from start below end
+ for to-index upfrom 0
+ do (progn
+ (setf (aref mb-vector to-index)
+ (char-code (aref string from-index)))))
+ (when null-terminate
+ (setf (aref mb-vector (1- number-of-octets)) 0))
+ (values mb-vector number-of-octets)))
+
+
+(provide 'acl-excl)
Added: branches/trunk-reorg/thirdparty/acl-compat/lispworks/acl-mp.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/lispworks/acl-mp.lisp Thu Feb 7 03:21:48 2008
@@ -0,0 +1,209 @@
+;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: CL-USER; -*-
+;;;; ;
+;;;; (c) 2001 by Jochen Schmidt.
+;;;;
+;;;; File: acl-mp-lw.lisp
+;;;; Revision: 1.0.0
+;;;; Description: LispWorks implementation for ACL-COMPAT-MP
+;;;; Date: 02.02.2002
+;;;; Authors: Jochen Schmidt
+;;;; Tel: (+49 9 11) 47 20 603
+;;;; Email: jsc at dataheaven.de
+;;;;
+;;;; Redistribution and use in source and binary forms, with or without
+;;;; modification, are permitted provided that the following conditions
+;;;; are met:
+;;;; 1. Redistributions of source code must retain the above copyright
+;;;; notice, this list of conditions and the following disclaimer.
+;;;; 2. Redistributions in binary form must reproduce the above copyright
+;;;; notice, this list of conditions and the following disclaimer in the
+;;;; documentation and/or other materials provided with the distribution.
+;;;;
+;;;; THIS SOFTWARE IS PROVIDED "AS IS" AND THERE ARE NEITHER
+;;;; EXPRESSED NOR IMPLIED WARRANTIES - THIS INCLUDES, BUT
+;;;; IS NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+;;;; AND FITNESS FOR A PARTICULAR PURPOSE.IN NO WAY ARE THE
+;;;; AUTHORS LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;;;; SPECIAL, EXEMPLARY OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
+;;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES ;
+;;;; LOSS OF USE, DATA, OR PROFITS ; OR BUSINESS INTERRUPTION)
+;;;;
+;;;; For further details contact the authors of this software.
+;;;;
+;;;; Jochen Schmidt
+;;;; Zuckmantelstr. 11
+;;;; 91616 Neusitz
+;;;; GERMANY
+;;;;
+;;;;
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (require "comm"))
+
+(in-package :acl-compat-mp)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Import equivalent parts from the LispWorks MP package ;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(shadowing-import '(
+ mp:*current-process*
+ mp:process-kill
+ mp:process-enable
+ mp:process-disable
+ mp::process-preset
+ mp:process-reset
+ mp:process-interrupt
+ mp::process-name
+ mp:process-wait-function
+ mp:process-run-reasons
+ mp:process-arrest-reasons
+ mp:process-whostate
+ mp:without-interrupts
+ mp:process-wait
+ mp::process-active-p
+ ))
+
+(export '( *current-process*
+ process-kill
+ process-enable
+ process-disable
+ process-preset
+ process-reset
+ process-interrupt
+ process-name
+ process-wait-function
+ process-run-reasons
+ process-arrest-reasons
+ process-whostate
+ without-interrupts
+ process-wait
+ process-active-p
+ ))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Implement missing (and differing) functions ;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun make-process (&key (name "Anonymous") reset-action run-reasons arrest-reasons (priority 0) quantum
+ resume-hook suspend-hook initial-bindings run-immediately)
+ (declare (ignore priority quantum reset-action resume-hook suspend-hook run-immediately))
+ (let ((mp:*process-initial-bindings* initial-bindings))
+ (mp:create-process name :run-reasons run-reasons :arrest-reasons arrest-reasons)))
+
+(defun process-run-function (name-or-options preset-function &rest preset-arguments)
+ (let ((process (ctypecase name-or-options
+ (string (make-process :name name-or-options))
+ (list (apply #'make-process name-or-options)))))
+ (apply #'mp::process-preset process preset-function preset-arguments)
+ (push :enable (mp:process-run-reasons process))
+ process))
+
+(defun process-property-list (process)
+ (mp:process-plist process))
+
+(defun (setf process-property-list) (new-value process)
+ (setf (mp:process-plist process) new-value))
+
+(defun process-name-to-process (name &optional abbrev)
+ (if abbrev
+ (let ((length (length name)))
+ (dolist (process (mp:list-all-processes))
+ (when (and (>= (length (process-name process)) length)
+ (string= name (process-name process) :end2 length))
+ (return process))))
+ (mp:find-process-from-name (ctypecase name
+ (symbol (symbol-name name))
+ (string name)))))
+
+(defun process-wait-with-timeout (whostate seconds function &rest args)
+ (apply #'mp:process-wait-with-timeout whostate seconds function args))
+
+(defun wait-for-input-available (streams &key (wait-function #'socket::stream-input-available) whostate timeout)
+ (let ((collected-fds nil))
+ (flet ((fd (stream-or-fd)
+ (typecase stream-or-fd
+ (comm:socket-stream (comm:socket-stream-socket stream-or-fd))
+ (socket::passive-socket (socket::socket-os-fd stream-or-fd))
+ (fixnum stream-or-fd)))
+ (collect-fds ()
+ (setf collected-fds
+ (remove-if-not wait-function streams))))
+
+ #+unix
+ (unwind-protect
+ (progn
+ (dolist (stream-or-fd streams)
+ (mp:notice-fd (fd stream-or-fd)))
+ (if timeout
+ (mp:process-wait-with-timeout (or whostate "Waiting for input") timeout #'collect-fds)
+ (mp:process-wait (or whostate "Waiting for input") #'collect-fds)))
+ (dolist (stream-or-fd streams)
+ (mp:unnotice-fd (fd stream-or-fd))))
+ #-unix
+ (if timeout
+ (mp:process-wait-with-timeout (or whostate "Waiting for input") timeout #'collect-fds)
+ (mp:process-wait (or whostate "Waiting for input") #'collect-fds)))
+ collected-fds))
+
+(defmacro without-scheduling (&body forms)
+ `(mp:without-preemption , at forms))
+
+(defun process-allow-schedule (&optional process)
+ (declare (ignore process))
+ (mp:process-allow-scheduling))
+
+(defun process-revoke-run-reason (process object)
+ (mp:without-preemption
+ (setf (mp:process-run-reasons process)
+ (remove object (mp:process-run-reasons process))))
+ (when (and (eq process mp:*current-process*)
+ (not mp:*inhibit-scheduling-flag*))
+ (mp:process-allow-scheduling)))
+
+(defun process-add-run-reason (process object)
+ (setf (mp:process-run-reasons process) (pushnew object (mp:process-run-reasons process))))
+
+;revised version from alain picard
+(defun invoke-with-timeout (timeout bodyfn timeoutfn)
+ (block timeout
+ (let* ((process mp:*current-process*)
+ (unsheduled? nil)
+ (timer (mp:make-timer
+ #'(lambda ()
+ (mp:process-interrupt process
+ #'(lambda ()
+ (unless unsheduled?
+ (return-from timeout
+ (funcall timeoutfn)))))))))
+ (mp:schedule-timer-relative timer timeout)
+ (unwind-protect (funcall bodyfn)
+ (without-interrupts
+ (mp:unschedule-timer timer)
+ (setf unsheduled? t))))))
+
+
+(defmacro with-timeout ((seconds &body timeout-forms) &body body)
+ "Execute BODY; if execution takes more than SECONDS seconds, terminate
+and evaluate TIMEOUT-FORMS."
+ `(invoke-with-timeout ,seconds #'(lambda () , at body)
+ #'(lambda () , at timeout-forms)))
+
+(defun current-process ()
+ "The current process."
+ mp:*current-process*)
+
+(defun interrupt-process (process function &rest args)
+ "Run FUNCTION in PROCESS."
+ (apply #'mp:process-interrupt process function args))
+
+(defun make-process-lock (&key name)
+ (mp:make-lock :name name))
+
+(defmacro with-process-lock ((lock &key norecursive timeout whostate) &body forms)
+ (declare (ignore norecursive))
+ `(mp:with-lock (,lock
+ ,@(when whostate (list :whostate whostate))
+ ,@(when timeout (list :timeout timeout)))
+ , at forms))
+
Added: branches/trunk-reorg/thirdparty/acl-compat/lispworks/acl-socket.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/lispworks/acl-socket.lisp Thu Feb 7 03:21:48 2008
@@ -0,0 +1,311 @@
+;; This package is designed for LispWorks. It implements the
+;; ACL-style socket interface on top of LispWorks.
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (require "comm"))
+
+#+cl-ssl
+(eval-when (:compile-toplevel :load-toplevel :execute)
+(ssl-internal::initialize-ssl-library)
+)
+
+(in-package acl-compat.socket)
+
+(define-condition stream-error (error)
+ ((acl-compat.excl::stream :initarg :stream
+ :reader stream-error-stream)
+ (acl-compat.excl::action :initarg :action
+ :reader stream-error-action)
+ (acl-compat.excl::code :initarg :code
+ :reader stream-error-code)
+ (acl-compat.excl::identifier :initarg :identifier
+ :reader stream-error-identifier))
+ (:report (lambda (condition stream)
+ (format stream "A stream error occured (action=~A identifier=~A code=~A stream=~S)."
+ (stream-error-action condition)
+ (stream-error-identifier condition)
+ (stream-error-code condition)
+ (stream-error-stream condition)))))
+
+(define-condition socket-error (stream-error)
+ ()
+ (:report (lambda (condition stream)
+ (format stream "A socket error occured (action=~A identifier=~A code=~A stream=~S)."
+ (stream-error-action condition)
+ (stream-error-identifier condition)
+ (stream-error-code condition)
+ (stream-error-stream condition)))))
+
+#+unix
+(defun %socket-error-identifier (code)
+ (case code
+ (32 :x-broken-pipe)
+ (98 :address-in-use)
+ (99 :address-not-available)
+ (100 :network-down)
+ (102 :network-reset)
+ (103 :connection-aborted)
+ (104 :connection-reset)
+ (105 :no-buffer-space)
+ (108 :shutdown)
+ (110 :connection-timed-out)
+ (111 :connection-refused)
+ (112 :host-down)
+ (113 :host-unreachable)
+ (otherwise :unknown)))
+
+#+win32
+(defun %socket-error-identifier (code)
+ (case code
+ (10048 :address-in-use)
+ (10049 :address-not-available)
+ (10050 :network-down)
+ (10052 :network-reset)
+ (10053 :connection-aborted)
+ (10054 :connection-reset)
+ (10055 :no-buffer-space)
+ (10058 :shutdown)
+ (10060 :connection-timed-out)
+ (10061 :connection-refused)
+ (10064 :host-down)
+ (10065 :host-unreachable)
+ (otherwise :unknown)))
+
+(defun socket-error (stream error-code action format-string &rest format-args)
+ (declare (ignore format-string format-args)) ;no valid initargs for this with socket-error
+ (let ((code (if (numberp error-code) error-code #+unix(lw:errno-value))))
+ (error 'socket-error :stream stream :code code
+ :identifier (if (keywordp error-code)
+ error-code
+ (%socket-error-identifier error-code))
+ :action action)))
+
+
+(defclass socket ()
+ ((passive-socket :type fixnum
+ :initarg :passive-socket
+ :reader socket-os-fd)))
+
+(defclass passive-socket (socket)
+ ((element-type :type (member signed-byte unsigned-byte base-char)
+ :initarg :element-type
+ :reader element-type)
+ (port :type fixnum
+ :initarg :port
+ :reader local-port)))
+
+(defclass binary-socket-stream (de.dataheaven.chunked-stream-mixin:chunked-stream-mixin comm:socket-stream) ())
+(defclass input-binary-socket-stream (binary-socket-stream)())
+(defclass output-binary-socket-stream (binary-socket-stream)())
+(defclass bidirectional-binary-socket-stream (input-binary-socket-stream output-binary-socket-stream)())
+
+
+(defmethod comm::socket-error ((stream binary-socket-stream) error-code format-string &rest format-args)
+ (apply #'socket-error stream error-code :IO format-string format-args))
+
+
+(declaim (inline %reader-function-for-sequence))
+(defun %reader-function-for-sequence (sequence)
+ (typecase sequence
+ (string #'read-char)
+ ((array unsigned-byte (*)) #'read-byte)
+ ((array signed-byte (*)) #'read-byte)
+ (otherwise #'read-byte)))
+
+;; Bivalent socket support for READ-SEQUENCE
+(defmethod gray-stream:stream-read-sequence ((stream input-binary-socket-stream) sequence start end)
+ (stream::read-elements stream sequence start end (%reader-function-for-sequence sequence)))
+
+;; NDL 2004-06-06 -- without this, emit-clp-entity tries writing a string down a binary stream, and LW barfs
+(defmethod gray-stream:stream-write-sequence ((stream output-binary-socket-stream) (sequence string) start end)
+ (write-string sequence stream :start start :end end))
+
+;; ACL Gray-Streams Enhancment Generic Functions
+
+(defmethod stream-input-fn ((stream input-binary-socket-stream))
+ (comm:socket-stream-socket stream))
+
+(defmethod stream-output-fn ((stream output-binary-socket-stream))
+ (comm:socket-stream-socket stream))
+
+(defmethod socket-os-fd ((socket comm:socket-stream))
+ (comm:socket-stream-socket socket))
+
+(defmethod print-object ((passive-socket passive-socket) stream)
+ (print-unreadable-object (passive-socket stream :type t :identity nil)
+ (format stream "@~d on port ~d" (socket-os-fd passive-socket) (local-port passive-socket))))
+
+(defmethod stream-input-available ((fd fixnum))
+ (comm::socket-listen fd))
+
+(defmethod stream-input-available ((stream stream::os-file-handle-stream))
+ (stream-input-available (stream::os-file-handle-stream-file-handle stream)))
+
+(defmethod stream-input-available ((stream comm:socket-stream))
+ (or (comm::socket-listen (comm:socket-stream-socket stream))
+ (listen stream)))
+
+(defmethod stream-input-available ((stream socket::passive-socket))
+ (comm::socket-listen (socket::socket-os-fd stream)))
+
+
+(defmethod accept-connection ((passive-socket passive-socket)
+ &key (wait t))
+ (if (or wait (stream-input-available passive-socket))
+ (make-instance 'bidirectional-binary-socket-stream
+ :socket (comm::get-fd-from-socket (socket-os-fd passive-socket))
+ :direction :io
+ :element-type (element-type passive-socket))))
+
+(defun %new-passive-socket (local-port)
+ (multiple-value-bind (socket error-location error-code)
+ (comm::create-tcp-socket-for-service local-port)
+ (cond (socket socket)
+ (t (error 'socket-error :action error-location :code error-code :identifier :unknown)))))
+
+(defun make-socket (&key (remote-host "localhost")
+ local-port
+ remote-port
+ (connect :active)
+ (format :text)
+ (reuse-address t)
+ &allow-other-keys)
+ (declare (ignore format))
+ (check-type remote-host string)
+ (ecase connect
+ (:passive
+ (let ((comm::*use_so_reuseaddr* reuse-address))
+ (make-instance 'passive-socket
+ :port local-port
+ :passive-socket (%new-passive-socket local-port)
+ :element-type '(unsigned-byte 8))))
+ (:active
+ (handler-case
+ (let ((stream (comm:open-tcp-stream remote-host remote-port
+ :direction :io
+ :element-type '(unsigned-byte 8)
+ :errorp t)))
+ (change-class stream 'bidirectional-binary-socket-stream))
+ (simple-error (condition)
+ (let ((code (first (last (simple-condition-format-arguments condition)))))
+ (socket-error condition code
+ :connect "~A occured while connecting (~?)" (simple-condition-format-arguments condition))))))))
+
+
+(defmethod close ((passive-socket passive-socket) &key abort)
+ (declare (ignore abort))
+ (comm::close-socket (socket-os-fd passive-socket)))
+
+;(declaim (ftype (function ((unsigned-byte 32)) (values simple-string))
+; ipaddr-to-dotted))
+(defun ipaddr-to-dotted (ipaddr &key values)
+ ;(declare (type (unsigned-byte 32) ipaddr))
+ (if ipaddr ;sometimes ipaddr is nil in the log call if client has broken the connection
+ (let ((a (logand #xff (ash ipaddr -24)))
+ (b (logand #xff (ash ipaddr -16)))
+ (c (logand #xff (ash ipaddr -8)))
+ (d (logand #xff ipaddr)))
+ (if values
+ (values a b c d)
+ (format nil "~d.~d.~d.~d" a b c d)))
+ (if values (values 0 0 0 0) "0.0.0.0")))
+
+(defun string-tokens (string)
+ (labels ((get-token (str pos1 acc)
+ (let ((pos2 (position #\Space str :start pos1)))
+ (if (not pos2)
+ (nreverse acc)
+ (get-token str (1+ pos2) (cons (read-from-string (subseq str pos1 pos2))
+ acc))))))
+(get-token (concatenate 'string string " ") 0 nil)))
+
+(declaim (ftype (function (string &key (:errorp t))
+ (values (unsigned-byte 32)))
+ dotted-to-ipaddr))
+(defun dotted-to-ipaddr (dotted &key (errorp t))
+ (declare (string dotted))
+ (if errorp
+ (let ((ll (string-tokens (substitute #\Space #\. dotted))))
+ (+ (ash (first ll) 24) (ash (second ll) 16)
+ (ash (third ll) 8) (fourth ll)))
+ (ignore-errors
+ (let ((ll (string-tokens (substitute #\Space #\. dotted))))
+ (+ (ash (first ll) 24) (ash (second ll) 16)
+ (ash (third ll) 8) (fourth ll))))))
+
+(defun ipaddr-to-hostname (ipaddr &key ignore-cache)
+ (declare (ignore ignore-cache))
+ (multiple-value-bind (name)
+ (comm:get-host-entry (ipaddr-to-dotted ipaddr) :fields '(:name))
+ name))
+
+(defun lookup-hostname (host &key ignore-cache)
+ (when ignore-cache
+ (warn ":IGNORE-CACHE keyword in LOOKUP-HOSTNAME not supported."))
+ (if (stringp host)
+ (multiple-value-bind (addr)
+ (comm:get-host-entry host :fields '(:address))
+ addr)
+ (dotted-to-ipaddr (ipaddr-to-dotted host))))
+
+(defmethod remote-host ((socket comm:socket-stream))
+ (comm:socket-stream-peer-address socket))
+
+(defmethod remote-port ((socket comm:socket-stream))
+ (multiple-value-bind (host port)
+ (comm:socket-stream-peer-address socket)
+ (declare (ignore host))
+ port))
+
+(defmethod local-host ((socket comm:socket-stream))
+ (multiple-value-bind (host port)
+ (comm:socket-stream-address socket)
+ (declare (ignore port))
+ host))
+
+(defmethod local-port ((socket comm:socket-stream))
+ (multiple-value-bind (host port)
+ (comm:socket-stream-address socket)
+ (declare (ignore host))
+ port))
+
+(defun socket-control (stream &key (output-chunking nil oc-p) output-chunking-eof (input-chunking nil ic-p))
+ (when oc-p
+ (when output-chunking
+ (de.dataheaven.chunked-stream-mixin::initialize-output-chunking stream))
+ (setf (de.dataheaven.chunked-stream-mixin:output-chunking-p stream) output-chunking))
+ (when output-chunking-eof
+ (de.dataheaven.chunked-stream-mixin::disable-output-chunking stream))
+ (when ic-p
+ (when input-chunking
+ (de.dataheaven.chunked-stream-mixin::initialize-input-chunking stream))
+ (setf (de.dataheaven.chunked-stream-mixin:input-chunking-p stream) input-chunking)))
+
+#+(and :lispworks4.4 (not :cl-ssl))
+(defmethod make-ssl-client-stream ((socket-stream bidirectional-binary-socket-stream) &rest options)
+ (declare (ignore options))
+ (comm:attach-ssl socket-stream :ssl-ctx t :ssl-side :client)
+ socket-stream)
+
+#+(and :lispworks4.4 (not :cl-ssl))
+(defun initialize-ssl-library ()
+ ;; Dunno how to force load yet
+ (comm:ensure-ssl))
+
+#+(and :lispworks4.4 (not :cl-ssl))
+(defmethod make-ssl-server-stream ((socket-stream bidirectional-binary-socket-stream) &key certificate certificate-password)
+ (flet ((ctx-configure-callback (ctx)
+ (comm:ssl-ctx-use-privatekey-file ctx
+ certificate-password
+ comm:SSL_FILETYPE_PEM))
+ (ssl-configure-callback (ssl)
+ (comm:ssl-use-certificate-file ssl
+ certificate
+ comm:SSL_FILETYPE_PEM)))
+ (comm:attach-ssl socket-stream
+ :ssl-side :server
+ :ctx-configure-callback #'ctx-configure-callback
+ :ssl-configure-callback #'ssl-configure-callback))
+ socket-stream)
+
+(provide 'acl-socket)
Added: branches/trunk-reorg/thirdparty/acl-compat/lispworks/acl-sys.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/lispworks/acl-sys.lisp Thu Feb 7 03:21:48 2008
@@ -0,0 +1,24 @@
+(in-package :sys)
+(let ((*handle-warn-on-redefinition* :warn))
+; (*packages-for-warn-on-redefinition* nil))
+
+ (defun command-line-arguments ()
+ system:*line-arguments-list*)
+
+ (defun command-line-argument (n)
+ (nth n system:*line-arguments-list*))
+
+ (defun reap-os-subprocess (&key (wait nil))
+ (declare (ignore wait))
+ nil)
+
+ (export 'command-line-arguments)
+ (export 'command-line-argument)
+ (export 'reap-os-subprocess))
+
+;; Franz uses the MSWINDOWS feature conditional in some of their code;
+;; thus, under Windows, ACL-COMPAT should probably push MSWINDOWS
+;; onto the *features* list when it detects the presence of WIN32
+;; under Lispworks.
+#+WIN32 (eval-when (:compile-toplevel :load-toplevel :execute)
+ (pushnew :mswindows *features*))
Added: branches/trunk-reorg/thirdparty/acl-compat/lw-buffering.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/lw-buffering.lisp Thu Feb 7 03:21:48 2008
@@ -0,0 +1,261 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; LW Style Buffer Protocol for other Lisps ;;;
+;;; So far only 8bit byte and character IO works ;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(in-package :gray-stream)
+
+(defvar *default-input-buffer-size* 8192)
+(defvar *default-output-buffer-size* 8192)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defstruct buffer-state
+ (input-buffer (make-array *default-input-buffer-size* :element-type '(unsigned-byte 8)) :type (simple-array (unsigned-byte 8) (*)))
+ (input-index nil)
+ (input-limit *default-input-buffer-size* :type fixnum)
+ (output-buffer (make-array *default-output-buffer-size* :element-type '(unsigned-byte 8)) :type (simple-array (unsigned-byte 8) (*)))
+ (output-index 0)
+ (output-limit *default-output-buffer-size* :type fixnum)))
+
+;; Can be used to implement resourcing of buffers later
+(defun %allocate-buffer-state (&optional (input-limit *default-input-buffer-size*) (output-limit *default-output-buffer-size*))
+ (declare (ignore input-limit output-limit))
+ (make-buffer-state))
+
+(defun %deallocate-buffer-state (state)
+ (declare (ignore state)))
+
+;; Can be used to implement unbuffered encapsulating streams later
+(defclass native-lisp-stream-mixin ()
+ ((lisp-stream :initarg :lisp-stream
+ :reader native-lisp-stream))
+ (:documentation "Stream mixin that encapsulates a native stream."))
+
+(defclass buffered-stream-mixin (native-lisp-stream-mixin)
+ ((buffer-state :initform (%allocate-buffer-state)))
+ (:documentation "Stream mixin that provides buffering for a native lisp stream."))
+
+;; fundamental-bivalent-xxx-streams can be used to implement buffered
+;; and unbuffered bivalent streams. At the moment, we only implement
+;; buffered ones.
+(defclass fundamental-bivalent-input-stream
+ (fundamental-character-input-stream fundamental-binary-input-stream)
+ ())
+
+(defclass fundamental-bivalent-output-stream
+ (fundamental-character-output-stream fundamental-binary-output-stream)
+ ())
+
+(defclass buffered-bivalent-input-stream
+ (buffered-stream-mixin fundamental-bivalent-input-stream)
+ ())
+
+(defclass buffered-bivalent-output-stream
+ (buffered-stream-mixin fundamental-bivalent-output-stream)
+ ())
+
+(defclass buffered-bivalent-stream
+ (buffered-bivalent-input-stream buffered-bivalent-output-stream)
+ ())
+
+(defmacro with-stream-output-buffer ((buffer index limit) stream &body forms)
+ (let ((state (gensym "BUFFER-STATE-")))
+ `(let ((,state (slot-value ,stream 'buffer-state)))
+ (symbol-macrolet ((,buffer ,(list 'buffer-state-output-buffer state))
+ (,index ,(list 'buffer-state-output-index state))
+ (,limit ,(list 'buffer-state-output-limit state)))
+ , at forms))))
+
+;;; Encapsulated native streams
+
+(defmethod close ((stream native-lisp-stream-mixin) &key abort)
+ (close (native-lisp-stream stream) :abort abort))
+
+(defmethod stream-listen ((stream native-lisp-stream-mixin))
+ (listen (native-lisp-stream stream)))
+
+(defmethod open-stream-p ((stream native-lisp-stream-mixin))
+ (common-lisp::open-stream-p (native-lisp-stream stream)))
+
+(defmethod stream-clear-output ((stream native-lisp-stream-mixin))
+ (clear-output (native-lisp-stream stream)))
+
+;;; Input streams
+
+(declaim (inline %reader-function-for-sequence))
+(defun %reader-function-for-sequence (sequence)
+ (typecase sequence
+ (string #'read-char)
+ ((array unsigned-byte (*)) #'read-byte)
+ ((array signed-byte (*)) #'read-byte)
+ (otherwise #'read-byte)))
+
+(defun read-elements (socket-stream sequence start end reader-fn)
+ (let* ((len (length sequence))
+ (chars (- (min (or end len) len) start)))
+ (loop for i upfrom start
+ repeat chars
+ for char = (funcall reader-fn socket-stream)
+ if (eq char :eof) do (return-from read-elements i)
+ do (setf (elt sequence i) char))
+ (+ start chars)))
+
+(defmacro with-stream-input-buffer ((buffer index limit) stream &body forms)
+ (let ((state (gensym "BUFFER-STATE-")))
+ `(let ((,state (slot-value ,stream 'buffer-state)))
+ (symbol-macrolet ((,buffer ,(list 'buffer-state-input-buffer state))
+ (,index ,(list 'buffer-state-input-index state))
+ (,limit ,(list 'buffer-state-input-limit state)))
+ , at forms))))
+
+(defgeneric stream-fill-buffer (stream))
+(defmethod stream-fill-buffer ((stream buffered-stream-mixin))
+ ;; Implement b/nb semantics: block until at least one byte is read,
+ ;; but not until the whole buffer is filled. This means it takes at
+ ;; most n calls to this function to fill a buffer of length n, even
+ ;; with a slow connection.
+ (with-stream-input-buffer (buffer index limit) stream
+ (let* ((the-stream (native-lisp-stream stream))
+ (read-bytes
+ (loop with byte
+ for n-read from 0 below limit
+ while (and (if (< 0 n-read) (listen the-stream) t)
+ (setf byte (read-byte the-stream nil nil)))
+ do (setf (aref buffer n-read) byte)
+ count t)))
+ (if (zerop read-bytes)
+ nil
+ (setf index 0
+ limit read-bytes)))))
+
+(defmethod stream-read-byte ((stream buffered-bivalent-input-stream))
+ (with-stream-input-buffer (buffer index limit) stream
+ (unless (and index (< index limit))
+ (when (null (stream-fill-buffer stream))
+ (return-from stream-read-byte :eof)))
+ (prog1 (aref buffer index)
+ (incf index))))
+
+(defmethod stream-read-char ((stream buffered-bivalent-input-stream))
+ (let ((byte (stream-read-byte stream)))
+ (if (eq byte :eof)
+ :eof
+ (code-char byte))))
+
+(defmethod stream-read-char-no-hang ((stream buffered-bivalent-input-stream))
+ (if (listen stream)
+ (read-char stream)
+ nil))
+
+(defmethod stream-unread-char ((stream buffered-bivalent-input-stream) character)
+ (with-stream-input-buffer (buffer index limit) stream
+ (let ((new-index (1- index)))
+ (when (minusp new-index)
+ (error "Cannot unread char ~A" character))
+ (setf (aref buffer new-index) (char-code character)
+ index new-index)))
+ nil)
+
+(defmethod stream-peek-char ((stream buffered-bivalent-input-stream))
+ (let ((char (stream-read-char stream)))
+ (unless (eq char :eof)
+ (stream-unread-char stream char))
+ char))
+
+
+(defmethod stream-read-line ((stream buffered-bivalent-input-stream))
+ (let ((res (make-array 80 :element-type 'character :fill-pointer 0)))
+ (loop
+ (let ((ch (stream-read-char stream)))
+ (cond ((eq ch :eof)
+ (return (values (copy-seq res) t)))
+ ((char= ch #\Linefeed)
+ (return (values (copy-seq res) nil)))
+ (t
+ (vector-push-extend ch res)))))))
+
+
+(defmethod stream-read-sequence ((stream buffered-bivalent-input-stream) sequence &optional start end)
+ (read-elements stream sequence start end (%reader-function-for-sequence sequence)))
+
+;;(defmethod stream-clear-input ((stream buffered-bivalent-input-stream))
+;; (clear-input (native-lisp-stream stream)))
+
+(defmethod stream-element-type ((stream fundamental-bivalent-input-stream))
+ '(or character (unsigned-byte 8)))
+
+;;; Output streams
+
+(declaim (inline %writer-function-for-sequence))
+(defun %writer-function-for-sequence (sequence)
+ (typecase sequence
+ (string #'stream-write-char)
+ ((array unsigned-byte (*)) #'stream-write-byte)
+ ((array signed-byte (*)) #'stream-write-byte)
+ (otherwise #'stream-write-byte)))
+
+(defun write-elements (stream sequence start end writer-fn)
+ (let* ((len (length sequence))
+ (start (or start 0))
+ (end (or end len)))
+ (assert (<= 0 start end len))
+ (etypecase sequence
+ (simple-vector (loop for i from start below end
+ do (funcall writer-fn stream (svref sequence i))))
+ (vector (loop for i from start below end
+ do (funcall writer-fn stream (aref sequence i))))
+ (list (loop for i from start below end
+ for c in (nthcdr start sequence)
+ do (funcall writer-fn stream c))))))
+
+(defgeneric stream-write-buffer (stream buffer start end))
+(defmethod stream-write-buffer ((stream buffered-stream-mixin) buffer start end)
+ (let ((lisp-stream (native-lisp-stream stream)))
+ (write-sequence buffer lisp-stream :start start :end end)))
+
+(defgeneric stream-flush-buffer (stream))
+(defmethod stream-flush-buffer ((stream buffered-stream-mixin))
+ (with-stream-output-buffer (buffer index limit) stream
+ (when (plusp index)
+ (stream-write-buffer stream buffer 0 index)
+ (setf index 0))))
+
+(defmethod stream-write-byte ((stream buffered-bivalent-output-stream) byte)
+ (with-stream-output-buffer (buffer index limit) stream
+ (unless (< index limit)
+ (stream-flush-buffer stream))
+ (setf (aref buffer index) byte)
+ (incf index)))
+
+(defmethod stream-write-char ((stream buffered-bivalent-output-stream) character)
+ (stream-write-byte stream (char-code character)))
+
+(defmethod stream-write-string ((stream buffered-bivalent-output-stream) string &optional (start 0) end)
+ (write-elements stream string start end #'stream-write-char))
+
+(defmethod stream-write-sequence ((stream buffered-stream-mixin) sequence
+ &optional (start 0) end)
+ (write-elements stream sequence start end (%writer-function-for-sequence sequence)))
+
+(defmethod stream-element-type ((stream fundamental-bivalent-output-stream))
+ '(or character (unsigned-byte 8)))
+
+(defmethod stream-line-column ((stream fundamental-bivalent-output-stream))
+ nil)
+
+(defmethod stream-finish-output ((stream buffered-bivalent-output-stream))
+ (stream-flush-buffer stream)
+ (finish-output (native-lisp-stream stream)))
+
+(defmethod stream-force-output ((stream buffered-bivalent-output-stream))
+ (stream-flush-buffer stream)
+ (force-output (native-lisp-stream stream)))
+
+(defmethod stream-clear-output ((stream buffered-bivalent-output-stream))
+ (with-stream-output-buffer (buffer index limit) stream
+ (setf index 0
+ limit 0))
+ (call-next-method) ; Clear native stream also
+ )
+
+
Added: branches/trunk-reorg/thirdparty/acl-compat/mcl/acl-excl.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/mcl/acl-excl.lisp Thu Feb 7 03:21:48 2008
@@ -0,0 +1,168 @@
+;;;;
+;;;; ACL-COMPAT - EXCL
+;;;;
+
+;;;; Implementation-specific parts of acl-compat.excl (see
+;;;; acl-excl-common.lisp)
+
+(in-package :acl-compat.excl)
+
+;#-openmcl
+;(defun fixnump (x)
+; (ccl::fixnump x))
+
+#-openmcl
+(import 'ccl::fixnump)
+
+#+openmcl
+(defun filesys-inode (path)
+ (or (nth-value 4 (ccl::%stat (ccl::native-translated-namestring path)))
+ (error "path ~s does not exist" path)))
+
+(defun cl-internal-real-time ()
+ (round (/ (get-internal-real-time) 1000)))
+
+(defun stream-input-fn (stream)
+ stream)
+
+(defun filesys-type (file-or-directory-name)
+ (if (ccl:directory-pathname-p file-or-directory-name)
+ :directory
+ (if (probe-file file-or-directory-name)
+ :file
+ nil)))
+
+(defmacro atomically (&body forms)
+ `(ccl:without-interrupts , at forms))
+
+(defmacro without-package-locks (&body forms)
+ `(progn , at forms))
+
+(define-condition stream-error (error)
+ ((stream :initarg :stream
+ :reader stream-error-stream)
+ (action :initarg :action
+ :initform nil
+ :reader stream-error-action)
+ (code :initarg :code
+ :initform nil
+ :reader stream-error-code)
+ (identifier :initarg :identifier
+ :initform nil
+ :reader stream-error-identifier))
+ (:report (lambda (condition stream)
+ (format stream "A stream error occured (action=~A identifier=~A code=~A stream=~S)."
+ (stream-error-action condition)
+ (stream-error-identifier condition)
+ (stream-error-code condition)
+ (stream-error-stream condition)))))
+
+(define-condition socket-error (stream-error)
+ ()
+ (:report (lambda (condition stream)
+ (format stream "A socket error occured (action=~A identifier=~A code=~A stream=~S)."
+ (stream-error-action condition)
+ (stream-error-identifier condition)
+ (stream-error-code condition)
+ (stream-error-stream condition)))))
+
+
+
+;! Need to figure out what to do here
+(defun fasl-read (filename)
+ (declare (ignore filename))
+ (error "fasl-read not implemented for MCL.") )
+
+(defun fasl-write (data stream opt)
+ (declare (ignore data stream opt))
+ (error "fasl-write not implemented for MCL.") )
+
+
+(defmacro schedule-finalization (object function)
+ `(ccl:terminate-when-unreachable ,object ,function))
+
+(defun run-shell-command (program
+ &key input output error-output separate-streams
+ if-input-does-not-exist if-output-exists
+ if-error-output-exists wait environment show-window)
+ (declare (ignore show-window))
+ ;; KLUDGE: split borrowed from asdf, this shouldn't be done -- it
+ ;; would be better to use split-sequence or define one ourselves ...
+ ;; TODO: On Unix, acl also handles a vector of simple-strings as
+ ;; value for program, with different semantics.
+ (let* ((program-and-arguments
+ (delete "" (asdf::split program) :test #'string=))
+ (program (car program-and-arguments))
+ (arguments (cdr program-and-arguments)))
+ (when environment
+ #-unix (error "Don't know how to run program in an environment.")
+ (setf arguments (append
+ (list "-i")
+ (loop for (name . value) in environment
+ collecting (concatenate 'string name "=" value))
+ (list program)
+ arguments))
+ (setf program "env"))
+
+ (let* ((process (run-program program arguments
+ :input input
+ :if-input-does-not-exist
+ if-input-does-not-exist
+ :output output
+ :if-output-exists if-output-exists
+ :error error-output
+ :if-error-exists if-error-output-exists
+ :wait wait))
+ (in-stream (external-process-input-stream process))
+ (out-stream (external-process-output-stream process))
+ (err-stream (external-process-error-stream process))
+ (pid (external-process-id process)))
+ (cond
+ ;; one value: exit status
+ (wait (nth-value 1 (external-process-status process)))
+ ;; four values: i/o/e stream, pid
+ (separate-streams
+ (values (if (eql input :stream) in-stream nil)
+ (if (eql output :stream) out-stream nil)
+ (if (eql error-output :stream) err-stream nil)
+ pid))
+ ;; three values: normal stream, error stream, pid
+ (t (let ((normal-stream
+ (cond ((and (eql input :stream) (eql output :stream))
+ (make-two-way-stream in-stream out-stream))
+ ((eql input :stream) in-stream)
+ ((eql output :stream) out-stream)
+ (t nil)))
+ (error-stream (if (eql error-output :stream) err-stream nil)))
+ (values normal-stream error-stream pid)))))))
+
+(defun string-to-octets (string &key (null-terminate t) (start 0)
+ end mb-vector make-mb-vector?
+ (external-format :default))
+ "This function returns a lisp-usb8-vector and the number of bytes copied."
+ (declare (ignore external-format))
+ ;; The end parameter is different in ACL's lambda list, but this
+ ;; variant lets us give an argument :end nil explicitly, and the
+ ;; right thing will happen
+ (unless end (setf end (length string)))
+ (let* ((number-of-octets (if null-terminate (1+ (- end start))
+ (- end start)))
+ (mb-vector (cond
+ ((and mb-vector (>= (length mb-vector) number-of-octets))
+ mb-vector)
+ ((or (not mb-vector) make-mb-vector?)
+ (make-array (list number-of-octets)
+ :element-type '(unsigned-byte 8)
+ :initial-element 0))
+ (t (error "Was given a vector of length ~A, ~
+ but needed at least length ~A."
+ (length mb-vector) number-of-octets)))))
+ (declare (type (simple-array (unsigned-byte 8) (*)) mb-vector))
+ (loop for from-index from start below end
+ for to-index upfrom 0
+ do (progn
+ (setf (aref mb-vector to-index)
+ (char-code (aref string from-index)))))
+ (when null-terminate
+ (setf (aref mb-vector (1- number-of-octets)) 0))
+ (values mb-vector number-of-octets)))
Added: branches/trunk-reorg/thirdparty/acl-compat/mcl/acl-mp.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/mcl/acl-mp.lisp Thu Feb 7 03:21:48 2008
@@ -0,0 +1,183 @@
+;;; This file implements the process functions for AllegroServe in MCL.
+;;; Based on the the work done for cmucl and Lispworks.
+;;;
+;;; John DeSoi, Ph.D. desoi at users.sourceforge.net
+
+
+(in-package :acl-compat.mp)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+; existing stuff from ccl we can reuse directly
+(shadowing-import
+ '(ccl:*current-process*
+ ccl::lock
+ ccl:process-allow-schedule
+ ccl:process-name
+ ccl:process-preset
+ #-openmcl-native-threads ccl:process-run-reasons
+ ccl:process-wait
+ ccl:process-wait-with-timeout
+ ccl:without-interrupts))
+)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+(export
+ '(*current-process*
+ lock
+ process-allow-schedule
+ process-name
+ process-preset
+ process-run-reasons
+ process-wait
+ process-wait-with-timeout
+ without-interrupts))
+)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+(defmacro without-scheduling (&body forms)
+ `(ccl:without-interrupts , at forms))
+
+#|
+; more ideas stolen from acl-mp-lw.lisp
+(defun invoke-with-timeout (seconds bodyfn timeoutfn)
+ (block timeout
+ (let* ((process *current-process*)
+ (timer (ccl:process-run-function "with-timeout-timer"
+ #'(lambda ()
+ (sleep seconds)
+ (ccl:process-interrupt process
+ #'(lambda ()
+ (return-from timeout
+ (funcall timeoutfn))))))))
+ (unwind-protect (funcall bodyfn)
+ (ccl:process-kill timer)))))
+
+|#
+
+
+
+(defun invoke-with-timeout (seconds bodyfn timeoutfn)
+ (block timeout
+ (let* ((timer (ccl::make-timer-request
+ seconds
+ #'(lambda () (return-from timeout (funcall timeoutfn))))))
+ (ccl::enqueue-timer-request timer)
+ (unwind-protect (funcall bodyfn)
+ (ccl::dequeue-timer-request timer)))))
+
+
+(defmacro with-timeout ((seconds &body timeout-forms) &body body)
+ "Execute BODY; if execution takes more than SECONDS seconds, terminate and evaluate TIMEOUT-FORMS."
+ `(invoke-with-timeout ,seconds #'(lambda () , at body)
+ #'(lambda () , at timeout-forms)))
+
+
+#+openmcl-native-threads
+(progn
+
+;;; The :INITIAL-BINDINGS arg to process creation functions seems to be
+;;; quoted, even when it appears in a list (as in the case of
+;;; (process-run-function <args>)) By the time that percolates down
+;;; to OpenMCL's process creation functions, it should lose the quote.
+;;;
+;;; Perhaps I imagined that ...
+;;;
+
+(defun ccl::openmcl-fix-initial-bindings (initial-bindings)
+ (if (and (consp initial-bindings)
+ (eq (car initial-bindings) 'quote))
+ (cadr initial-bindings)
+ initial-bindings))
+
+)
+
+
+#-openmcl-native-threads
+(defmacro process-revoke-run-reason (process reason)
+ `(ccl:process-disable-run-reason ,process ,reason) )
+
+#-openmcl-native-threads
+(defmacro process-add-run-reason (process reason)
+ `(ccl:process-enable-run-reason ,process ,reason) )
+
+
+(defmacro make-process-lock (&key name)
+ (if name
+ `(ccl:make-lock ,name)
+ `(ccl:make-lock)))
+
+(defmacro with-process-lock ((lock &key norecursive timeout whostate) &body forms)
+ (declare (ignore norecursive whostate timeout))
+ `(ccl:with-lock-grabbed (,lock) , at forms))
+
+
+(defmacro process-kill (process)
+ `(progn
+ #-openmcl-native-threads
+ (unless (ccl:process-active-p ,process) ;won't die unless enabled
+ (ccl:process-reset-and-enable ,process) )
+ (ccl:process-kill ,process)))
+)
+
+(defun process-active-p (process)
+ (ccl::process-active-p process))
+
+(defun interrupt-process (process function &rest args)
+ "Run FUNCTION in PROCESS."
+(apply #'ccl:process-interrupt process function args))
+
+(defun current-process ()
+ "The current process."
+ ccl:*current-process*)
+
+
+;property list implementation from acl-mp-cmu.lisp
+(defvar *process-plists* (make-hash-table :test #'eq)
+ "maps processes to their plists.
+See the functions process-plist, (setf process-plist).")
+
+(defun process-property-list (process)
+ (gethash process *process-plists*))
+
+(defun (setf process-property-list) (new-value process)
+ (setf (gethash process *process-plists*) new-value))
+
+; from acl-mp-lw.lisp
+(defun make-process (&key (name "Anonymous") reset-action run-reasons arrest-reasons (priority 0) quantum
+ resume-hook suspend-hook initial-bindings run-immediately)
+ (declare (ignore priority quantum reset-action resume-hook suspend-hook run-immediately))
+ #-openmcl-native-threads
+ (declare (ignore initial-bindings)) ;! need separate lexical bindings for each process?
+ #+openmcl-native-threads
+ (declare (ignore run-reasons arrest-reasons))
+ ;(let ((acl-mp:*process-initial-bindings* initial-bindings))
+ #-openmcl-native-threads
+ (ccl:make-process name :run-reasons run-reasons :arrest-reasons arrest-reasons)
+ #+openmcl-native-threads
+ (ccl:make-process name :initial-bindings (ccl::openmcl-fix-initial-bindings initial-bindings)))
+
+(defun process-run-function (name-or-options preset-function &rest preset-arguments)
+ (let ((process (ctypecase name-or-options
+ (string (acl-mp:make-process :name name-or-options))
+ (list (apply #'acl-mp:make-process name-or-options)))))
+ (apply #'acl-mp:process-preset process preset-function preset-arguments)
+ #+openmcl-native-threads (ccl:process-enable process)
+ #-openmcl-native-threads (process-add-run-reason process :enable)
+ process))
+
+;;; Busy-waiting ...
+(defun wait-for-input-available (streams
+ &key (wait-function #'ccl:stream-listen)
+ whostate timeout)
+ (let ((collected-fds nil))
+ (flet ((collect-fds ()
+ (setf collected-fds
+ (remove-if-not wait-function streams))))
+
+ (if timeout
+ (process-wait-with-timeout (or whostate "Waiting for input") timeout #'collect-fds)
+ (process-wait (or whostate "Waiting for input") #'collect-fds)))
+ collected-fds))
Added: branches/trunk-reorg/thirdparty/acl-compat/mcl/acl-socket-mcl.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/mcl/acl-socket-mcl.lisp Thu Feb 7 03:21:48 2008
@@ -0,0 +1,268 @@
+;;; MCL layer for ACL sockets.
+;;; Based on acl-socket-cmu.lisp and acl-socket-lw.lisp.
+;;;
+;;; John DeSoi, Ph.D. desoi at users.sourceforge.net
+
+
+(defpackage :acl-compat.socket
+ (:nicknames :socket :acl-socket)
+ (:use :common-lisp)
+ (:export #:make-socket
+ #:accept-connection
+ #:ipaddr-to-dotted
+ #:dotted-to-ipaddr
+ #:ipaddr-to-hostname
+ #:lookup-hostname
+ #:remote-host
+ #:remote-port
+ #:local-host
+ #:local-port
+ #:socket-control
+ ))
+
+(in-package :socket)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+(require :opentransport)
+
+;OpenTransport.lisp does not export anything, so do this to make it look a bit cleaner.
+(import '(ccl::open-tcp-stream
+ ccl::opentransport-tcp-stream
+ ccl::opentransport-binary-tcp-stream
+ ccl::stream-local-port
+ ccl::stream-local-host
+ ccl::stream-local-port
+ ccl::stream-remote-host
+ ccl::stream-remote-port
+ ccl::inet-host-name
+ ccl::tcp-host-address
+ ) )
+
+(defmacro connection-state (s)
+ `(ccl::opentransport-stream-connection-state ,s))
+
+(defmacro connection-established (s)
+ `(eq :dataxfer (connection-state ,s)) )
+
+)
+
+
+;;; There is a bug in MCL (4.3.1 tested) where read-sequence and
+;;; write-sequence fail with binary tcp streams. These two methods
+;;; provide a work-around.
+#-carbon-compat ;should be fixed starting with first carbon version (4.3.5)
+(defmethod ccl:stream-write-sequence ((s opentransport-binary-tcp-stream)
+ (sequence ccl::simple-unsigned-byte-vector)
+ &key (start 0) end)
+ (ccl::stream-write-vector s sequence start (or end (length sequence)))
+ s)
+
+
+
+#-carbon-compat ;should be fixed starting with first carbon version (4.3.5)
+(defmethod ccl:stream-read-sequence ((s opentransport-binary-tcp-stream)
+ (sequence ccl::simple-unsigned-byte-vector)
+ &key (start 0) (end (length sequence)))
+ (ccl::stream-read-bytes-to-vector s sequence (- end start) start)
+ end)
+
+
+
+(defmethod port ((stream opentransport-tcp-stream))
+ (stream-local-port stream) )
+
+(defmethod local-host ((s opentransport-tcp-stream))
+ (stream-local-host s))
+
+(defmethod local-port ((s opentransport-tcp-stream))
+ (stream-local-port s))
+
+(defmethod remote-host ((s opentransport-tcp-stream))
+ (stream-remote-host s))
+
+(defmethod remote-port ((s opentransport-tcp-stream))
+ (stream-remote-port s))
+
+;? copied from lispworks - don't think it applies to mcl
+(defmethod fd ((s opentransport-tcp-stream))
+ (declare (ignore s))
+ 42)
+
+
+
+(defvar *passive-socket-listener-count* 10
+ "Default number of listen streams to use.")
+
+; With ACL, an unlimited number of connections can be made to the same passive
+; socket instance. Nothing like that here, so we have to create our own stream
+; listener to create the "real" sockets as connections are made.
+
+
+; Create a class to monitor streams so we have a data structure to pass to process-wait
+(defclass passive-socket (stream) ;inherit stream so we can handle close
+ ((port
+ :documentation "Port we are listening on."
+ :initform 80
+ :initarg :port
+ :reader local-port)
+ (element-type
+ :documentation "Stream element type."
+ :initarg :element-type
+ :initform '(unsigned-byte 8))
+ (count
+ :documentation "Number of listening streams to monitor."
+ :initform *passive-socket-listener-count*)
+ (streams
+ :documentation "Array of listen streams."
+ :initform nil)
+ (index
+ :documentation "Index of the last listen stream checked."
+ :initform *passive-socket-listener-count*)
+ (connect-index
+ :documentation "Index of a connected stream, next for processing."
+ :initform nil)
+ )
+ (:documentation "Class used to manage listening streams and connections.") )
+
+
+
+(defmethod initialize-instance :after ((listener passive-socket) &rest initargs)
+ (declare (ignore initargs))
+ (with-slots (streams count port element-type) listener
+ (setf streams (make-array count :initial-element nil :adjustable t))
+ (dotimes (i count)
+ (setf (elt streams i) (new-listen-stream listener)) ) ) )
+
+
+(defmethod ccl:stream-close ((listener passive-socket))
+ (with-slots (streams count) listener
+ (dotimes (i count)
+ (close (elt streams i)))
+ (setf count 0)))
+
+
+(defmethod new-listen-stream ((listener passive-socket))
+ (with-slots (port element-type) listener
+ (open-tcp-stream nil port ;use nil host to get a passive connection
+ :element-type element-type) ) )
+
+
+(defmethod local-host ((listener passive-socket))
+ (with-slots (streams count) listener
+ (when (> count 0)
+ (local-host (elt streams 0)))))
+
+
+
+; See if one of the streams is established.
+(defmethod find-connection-index ((listener passive-socket))
+ (with-slots (count streams index connect-index) listener
+ (let ((next (if (< (1+ index) count) (1+ index) 0)))
+ (when (connection-established (elt streams next))
+ (setf index next
+ connect-index next)
+ connect-index))))
+
+
+(defmethod process-connected-stream ((listener passive-socket))
+ (with-slots (streams connect-index) listener
+ (if (null connect-index) nil
+ (let ((s (elt streams connect-index))) ;return the connected stream and set a new one
+ (setf (elt streams connect-index) (new-listen-stream listener))
+ (setf connect-index nil)
+ s) ) ) )
+
+
+;! future - determine how many connects we are getting an dynamically increase the number
+; of listeners if necessary.
+(defmethod accept-connection ((listener passive-socket) &key (wait t))
+ (if wait
+ (ccl:process-wait "accept connection..." #'find-connection-index listener) ;apply repeatedly with process wait
+ (find-connection-index listener) )
+ (process-connected-stream listener) )
+
+
+(defun make-socket (&key (remote-host "localhost")
+ local-port
+ remote-port
+ (connect :active)
+ (format :text)
+ &allow-other-keys)
+ (let ((element-type (ecase format
+ (:text 'base-char)
+ (:binary 'signed-byte)
+ (:bivalent 'unsigned-byte))))
+ (ecase connect
+ (:passive
+ (make-instance 'passive-socket :port local-port :element-type element-type :direction :io))
+ (:active
+ (let ((host (if (integerp remote-host) ;aparently the acl version also accepts an integer
+ (ipaddr-to-dotted remote-host)
+ remote-host)))
+ (check-type host string)
+ (open-tcp-stream host remote-port
+ :element-type element-type))))))
+
+
+
+(declaim (ftype (function ((unsigned-byte 32)) (values simple-string))
+ ipaddr-to-dotted))
+
+(defun ipaddr-to-dotted (ipaddr &key values)
+ (declare (type (unsigned-byte 32) ipaddr))
+ (let ((a (logand #xff (ash ipaddr -24)))
+ (b (logand #xff (ash ipaddr -16)))
+ (c (logand #xff (ash ipaddr -8)))
+ (d (logand #xff ipaddr)))
+ (if values
+ (values a b c d)
+ (format nil "~d.~d.~d.~d" a b c d))))
+
+(defun string-tokens (string)
+ (labels ((get-token (str pos1 acc)
+ (let ((pos2 (position #\Space str :start pos1)))
+ (if (not pos2)
+ (nreverse acc)
+ (get-token str (1+ pos2) (cons (read-from-string (subseq str pos1 pos2))
+ acc))))))
+ (get-token (concatenate 'string string " ") 0 nil)))
+
+(declaim (ftype (function (string &key (:errorp t))
+ (values (unsigned-byte 32)))
+ dotted-to-ipaddr))
+
+(defun dotted-to-ipaddr (dotted &key (errorp t))
+ (declare (string dotted))
+ (if errorp
+ (let ((ll (string-tokens (substitute #\Space #\. dotted))))
+ (+ (ash (first ll) 24) (ash (second ll) 16)
+ (ash (third ll) 8) (fourth ll)))
+ (ignore-errors
+ (let ((ll (string-tokens (substitute #\Space #\. dotted))))
+ (+ (ash (first ll) 24) (ash (second ll) 16)
+ (ash (third ll) 8) (fourth ll))))))
+
+(defun ipaddr-to-hostname (ipaddr &key ignore-cache)
+ (declare (ignore ignore-cache))
+ (inet-host-name ipaddr) )
+
+(defun lookup-hostname (host &key ignore-cache)
+ (when ignore-cache
+ (warn ":IGNORE-CACHE keyword in LOOKUP-HOSTNAME not supported."))
+ (if (stringp host)
+ (tcp-host-address host)
+ (dotted-to-ipaddr (ipaddr-to-dotted host))))
+
+
+(defun socket-control (stream &key output-chunking output-chunking-eof input-chunking)
+ (declare (ignore stream))
+ (warn "SOCKET-CONTROL function not implemented.")
+ (when (or output-chunking output-chunking-eof input-chunking)
+ (error "Chunking is not yet supported in MCL. Restart the server with argument :chunking nil (turns chunking off).") ) )
+
+
+(provide 'acl-socket)
+
+
+
Added: branches/trunk-reorg/thirdparty/acl-compat/mcl/acl-socket-openmcl.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/mcl/acl-socket-openmcl.lisp Thu Feb 7 03:21:48 2008
@@ -0,0 +1,145 @@
+;;; OpenMCL layer for ACL sockets.
+;;; Most everything is already there, just needs to be in the socket package.
+;;;
+;;; John DeSoi, Ph.D. desoi at users.sourceforget.net
+
+(in-package :acl-compat.socket)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (shadowing-import
+ '(;ccl:make-socket ; use our own version
+ ccl:accept-connection
+ ccl:dotted-to-ipaddr
+ ccl:ipaddr-to-hostname
+ ccl:lookup-hostname
+ ccl:remote-host
+ ccl:remote-port
+ ccl:local-host
+ ccl:local-port))
+)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (export
+ '(accept-connection
+ ipaddr-to-dotted
+ dotted-to-ipaddr
+ ipaddr-to-hostname
+ lookup-hostname
+ remote-host
+ remote-port
+ local-host
+ local-port
+ socket-control))
+ )
+
+
+(defclass server-socket ()
+ ((socket :initarg :socket :reader socket
+ :initform (error "No value supplied for socket"))
+ (port :initarg :port
+ :reader port
+ :initform (error "No value supplied for port"))))
+
+
+(defmethod print-object ((socket server-socket) stream)
+ (print-unreadable-object (socket stream :type t :identity nil)
+ (format stream "listening on port ~d" (port socket))))
+
+
+(defmethod accept-connection ((server-socket server-socket)
+ &key (wait t))
+ "Return a bidirectional stream connected to socket."
+ (let ((stream (accept-connection (socket server-socket) :wait wait)))
+ (when stream (make-chunked-stream stream))))
+
+
+(defun make-socket (&rest args
+ &key (connect :active) port
+ &allow-other-keys)
+ "Return a stream connected to remote-host if connect is :active, or
+something listening on local-port that can be fed to accept-connection
+if connect is :passive.
+"
+ (let ((socket-or-stream (apply #'ccl:make-socket args)))
+ (if (eq connect :active)
+ (make-chunked-stream socket-or-stream)
+ (make-instance 'server-socket :socket socket-or-stream :port port))))
+
+
+(defmethod close ((server-socket server-socket) &key abort)
+ "Kill a passive (listening) socket. (Active sockets are actually
+streams and handled by their close methods."
+ (declare (ignore abort))
+ (close (socket server-socket)))
+
+(defmethod local-host ((server-socket server-socket))
+ (local-host (socket server-socket)))
+
+(defmethod local-port ((server-socket server-socket))
+ (local-port (socket server-socket)))
+
+(defmethod ccl:stream-write-vector
+ ((stream gray-stream::buffered-bivalent-stream) vector start end)
+ (declare (fixnum start end))
+ (let ((fn (gray-stream::%writer-function-for-sequence vector)))
+ (do* ((i start (1+ i)))
+ ((= i end))
+ (declare (fixnum i))
+ (funcall fn stream (ccl:uvref vector i)))))
+
+(defmethod ccl:stream-read-vector
+ ((stream gray-stream::buffered-bivalent-stream) vector start end)
+ (declare (fixnum start end))
+ (let ((fn (gray-stream::%reader-function-for-sequence vector)))
+ (do* ((i start (1+ i)))
+ ((= i end) end)
+ (declare (fixnum i))
+ (let* ((b (funcall fn stream)))
+ (if (eq b :eof)
+ (return i)
+ (setf (ccl:uvref vector i) b))))))
+
+(defclass chunked-stream (de.dataheaven.chunked-stream-mixin::chunked-stream-mixin
+ gray-stream::buffered-bivalent-stream)
+ ((plist :initarg :plist :accessor stream-plist)))
+
+(defun make-chunked-stream (lisp-stream &key plist)
+ (make-instance 'chunked-stream :lisp-stream lisp-stream :plist plist))
+
+(defmethod local-host ((chunked-stream chunked-stream))
+ (local-host (gray-stream::native-lisp-stream chunked-stream)))
+
+(defmethod local-port ((chunked-stream chunked-stream))
+ (local-port (gray-stream::native-lisp-stream chunked-stream)))
+
+(defmethod remote-host ((chunked-stream chunked-stream))
+ (remote-host (gray-stream::native-lisp-stream chunked-stream)))
+
+(defmethod remote-port ((chunked-stream chunked-stream))
+ (remote-port (gray-stream::native-lisp-stream chunked-stream)))
+
+
+(defun socket-control (stream &key (output-chunking nil oc-p) output-chunking-eof (input-chunking nil ic-p))
+ (when oc-p
+ (when output-chunking
+ (de.dataheaven.chunked-stream-mixin::initialize-output-chunking stream))
+ (setf (de.dataheaven.chunked-stream-mixin::output-chunking-p stream)
+ output-chunking))
+ (when output-chunking-eof
+ (de.dataheaven.chunked-stream-mixin::disable-output-chunking stream))
+ (when ic-p
+ (when input-chunking
+ (de.dataheaven.chunked-stream-mixin::initialize-input-chunking stream))
+ (setf (de.dataheaven.chunked-stream-mixin::input-chunking-p stream)
+ input-chunking)))
+
+; OpenMCL has a built-in ipaddr-to-dotted. But it appears that sometimes
+; the log function is being called after the connection is closed and
+; it causes nil to be passed to ipaddr-to-dotted. So we wrap ipaddr-to-dotten
+; to ensure only non-nil values are passed.
+
+(defun ipaddr-to-dotted (ipaddr &key values)
+ (unless (null ipaddr)
+ (ccl:ipaddr-to-dotted ipaddr :values values)))
+
+(provide 'acl-socket)
Added: branches/trunk-reorg/thirdparty/acl-compat/mcl/acl-sys.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/mcl/acl-sys.lisp Thu Feb 7 03:21:48 2008
@@ -0,0 +1,20 @@
+
+(in-package :acl-compat.system)
+
+
+(defun command-line-arguments ()
+ #+openmcl (ccl::command-line-arguments)
+ #-openmcl nil)
+
+(defun command-line-argument (n)
+ #+openmcl (nth n (command-line-arguments))
+ #-openmcl nil)
+
+;;; On acl, reap-os-subprocess is needed for (run-shell-command ...
+;;; :wait nil), but not on OpenMCL.
+(defun reap-os-subprocess (&key (wait nil))
+ (declare (ignore wait))
+ nil)
+
+#+nil
+(export '(command-line-arguments command-line-argument reap-os-subprocess))
Added: branches/trunk-reorg/thirdparty/acl-compat/mcl/mcl-stream-fix.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/mcl/mcl-stream-fix.lisp Thu Feb 7 03:21:48 2008
@@ -0,0 +1,44 @@
+
+
+(in-package :ccl)
+
+;;; There are several bugs in MCL functions to read sequences prior to 4.3.5; this fixes them
+
+
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+(let ((ccl:*warn-if-redefine* nil))
+
+(defun %io-buffer-read-bytes-to-vector (io-buffer vector bytes start)
+ (loop with fill-pointer = start
+ with bytes-remaining = bytes
+ until (eql 0 bytes-remaining)
+ while (if (eql 0 (io-buffer-incount io-buffer))
+ (%io-buffer-advance io-buffer t t) ; eof may be signalled through this -- JCMa 5/13/1999.
+ t)
+ for buffer = (io-buffer-inptr io-buffer)
+ for read-bytes = (min (io-buffer-incount io-buffer) bytes-remaining)
+ do (%copy-ptr-to-ivector buffer 0 vector fill-pointer read-bytes)
+ (incf fill-pointer read-bytes)
+ (%incf-ptr (io-buffer-inptr io-buffer) read-bytes) ;; bug fix from akh on 7/28/2002
+ (decf bytes-remaining read-bytes)
+ (decf (io-buffer-incount io-buffer) read-bytes)
+ (incf (io-buffer-bytes-read io-buffer) read-bytes)))
+
+
+;This function is unchanged, but kept for completeness
+(defun io-buffer-read-bytes-to-vector (io-buffer vector bytes &optional (start 0))
+ (require-type io-buffer 'io-buffer)
+ (with-io-buffer-locked (io-buffer)
+ (multiple-value-bind (v v-offset)
+ (array-data-and-offset vector)
+ (%io-buffer-read-bytes-to-vector io-buffer v bytes (+ start v-offset)))))
+
+
+(defmethod stream-read-bytes-to-vector ((stream buffered-output-stream-mixin) vector bytes &optional (start 0))
+ (io-buffer-read-bytes-to-vector (stream-io-buffer stream) vector bytes start)) ;original fuction did not get the buffer from the stream
+
+
+)
+)
\ No newline at end of file
Added: branches/trunk-reorg/thirdparty/acl-compat/mcl/mcl-timers.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/mcl/mcl-timers.lisp Thu Feb 7 03:21:48 2008
@@ -0,0 +1,112 @@
+;;; mcl-timers contributed by Gary Byers
+
+(in-package "CCL")
+
+
+;;; A simple timer mechanism for MCL/OpenMCL, which uses a
+;;; PERIODIC-TASK to check for expired "timer requests".
+;;; In MCL and OpenMCL, PERIODIC-TASKS run at specified
+;;; intervals via the same preemption mechanism that the
+;;; scheduler uses; they run in the execution context of
+;;; whatever thread was preempted, and they're assumed to
+;;; run pretty quickly.
+;;; This code uses doubly-linked-list elements (DLL-NODEs)
+;;; to represent a sorted list of "timer requests"; client
+;;; processes use timer requests to schedule an interrupt
+;;; action at a specified time. A periodic task walks this
+;;; list once a second (by default), removing those requests
+;;; whose time isn't in the future and interrupting the
+;;; corresponding processes.
+
+
+;;; The number of timer interrupts (ticks) per second.
+(defmacro ticks-per-second ()
+ #+OpenMCL '*ticks-per-second*
+ #-OpenMCL 60)
+
+
+(defun expiration-tick-count (seconds)
+ (+ (round (* seconds (ticks-per-second)))
+ (get-tick-count)))
+
+(defstruct (timer-request (:include dll-node)
+ (:constructor %make-timer-request))
+ expiration-tick ; when the timer expires
+ process ; what process to interrupt
+ function) ; how to interrupt it
+
+
+(defun make-timer-request (seconds-from-now function)
+ (check-type seconds-from-now (and unsigned-byte fixnum))
+ (check-type function function)
+ (%make-timer-request
+ :expiration-tick (expiration-tick-count seconds-from-now)
+ :process *current-process*
+ :function function))
+
+
+;;; the CCL::DEFLOADVAR construct ensures that the variable
+;;; will be reinitialized when a saved image is restarted
+(defloadvar *timer-request-queue*
+ #-openmcl-native-threads (make-dll-header)
+ #+openmcl-native-threads (make-locked-dll-header))
+
+;;; Insert the timer request before the first element with a later
+;;; expiration time (or at the end of the queue if there's no such
+;;; element.)
+(defun enqueue-timer-request (r)
+ (#-openmcl-native-threads without-interrupts
+ #+openmcl-native-threads with-locked-dll-header
+ #+openmcl-native-threads (*timer-request-queue*)
+ (if (dll-node-succ r) ; Already enqueued.
+ r ; Or signal an error.
+ (let* ((r-date (timer-request-expiration-tick r)))
+ (do* ((node *timer-request-queue* next)
+ (next (dll-node-succ node) (dll-node-succ next)))
+ ((or (eq next *timer-request-queue*)
+ (> (timer-request-expiration-tick next) r-date))
+ (insert-dll-node-after r node)))))))
+
+;;; Remove a timer request. (It's a no-op if the request has already
+;;; been removed.)
+(defun dequeue-timer-request (r)
+ (#-openmcl-native-threads without-interrupts
+ #+openmcl-native-threads with-locked-dll-header
+ #+openmcl-native-threads (*timer-request-queue*)
+ (when (dll-node-succ r) ;enqueued
+ (remove-dll-node r))
+ r))
+
+;;; Since this runs in an arbitrary process, it tries to be a little
+;;; careful with requests made by the current process (since running
+;;; the interrupt function will probably transfer control out of the
+;;; periodic task function.) The oldest (hopefully only) request for
+;;; the current process is handled after all other pending requests.
+(defun process-timer-requests ()
+ (let* ((now (get-tick-count))
+ (current-process *current-process*)
+ (current-process-action ()))
+ (#-openmcl-native-threads progn
+ #+openmcl-native-threads with-locked-dll-header
+ #+openmcl-native-threads (*timer-request-queue*)
+
+ (do-dll-nodes (r *timer-request-queue*)
+ (when (> (timer-request-expiration-tick r) now)
+ (return)) ; Anything remaining is
+ ; in the future.
+ (dequeue-timer-request r)
+ (let* ((proc (timer-request-process r))
+ (func (timer-request-function r)))
+ (if (eq proc current-process)
+ (if (null current-process-action)
+ (setq current-process-action func))
+ (process-interrupt (timer-request-process r)
+ (timer-request-function r)))))
+ (when current-process-action
+ (funcall current-process-action)))))
+
+(%install-periodic-task
+ 'process-timer-requests ; Name of periodic task
+ 'process-timer-requests ; function to call
+ (ticks-per-second) ; Run once per second
+ )
Added: branches/trunk-reorg/thirdparty/acl-compat/packages.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/packages.lisp Thu Feb 7 03:21:48 2008
@@ -0,0 +1,272 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; Package definitions for acl-compat.
+;;;;
+;;;; Package names follow their Allegro CL counterparts -- for an ACL
+;;;; package foo, acl-compat defines a package acl-compat.foo
+;;;;
+;;;; Some packages have nicknames, which were used as package names by
+;;;; previous versions of paserve and acl-compat. The nicknames are
+;;;; deprecated, but are kept for the benefit of people using
+;;;; acl-compat in other projects. New projects should use the
+;;;; package names starting with "acl-compat.".
+;;;;
+
+(in-package :common-lisp-user)
+
+;;; general
+(defpackage :acl-compat.excl
+ (:use #:common-lisp
+ #+cmu #:ext
+ #+clisp #:ext
+ #+sbcl #:sb-ext #+sbcl #:sb-gray
+ #+(or allegro cormanlisp) :excl
+ #+(or mcl openmcl) :ccl
+ )
+ #+lispworks (:import-from :common-lisp #:fixnump)
+ #+sbcl (:import-from :sb-int #:fixnump)
+ #+sbcl (:import-from :sb-ext #:without-package-locks)
+ #+cmu (:import-from :ext #:without-package-locks)
+ #+allegro (:shadowing-import-from :excl #:filesys-size
+ #:filesys-write-date #:intern* #:filesys-type #:atomically #:fast)
+ (:export
+ #:if*
+ #:*initial-terminal-io*
+ #:*cl-default-special-bindings*
+ #:filesys-size
+ #:filesys-write-date
+ #:stream-input-fn
+ #:match-regexp
+ #:compile-regexp
+ #:*current-case-mode*
+ #:intern*
+ #:filesys-type
+ #:errorset
+ #:atomically
+ #:fast
+ #:without-package-locks
+ #:fixnump
+ #+(or lispworks mcl openmcl) #:socket-error
+ #+(or allegro lispworks mcl openmcl) #:run-shell-command
+ #+(or allegro mcl openmcl) #:fasl-read
+ #+(or allegro mcl openmcl) #:fasl-write
+ #+(or allegro cmu scl mcl lispworks openmcl) #:string-to-octets
+ #+(or allegro cmu scl mcl lispworks openmcl) #:write-vector
+ ))
+
+
+;; general
+(defpackage :acl-compat.mp
+ (:use :common-lisp #+cormanlisp :acl-compat-mp #+allegro :mp)
+ (:nicknames :acl-mp #-cormanlisp :acl-compat-mp)
+ #+allegro (:shadowing-import-from :mp #:process-interrupt #:lock)
+ #+allegro (:shadowing-import-from :excl #:without-interrupts)
+ (:export
+ #:*current-process* ;*
+ #:process-kill ;*
+ #:process-preset ;*
+ #:process-name ;*
+
+ #:process-wait-function
+ #:process-run-reasons
+ #:process-arrest-reasons
+ #:process-whostate
+ #:without-interrupts
+ #:process-wait
+ #:process-enable
+ #:process-disable
+ #:process-reset
+ #:process-interrupt
+
+ #:process-run-function ;*
+ #:process-property-list ;*
+ #:without-scheduling ;*
+ #:process-allow-schedule ;*
+ #:make-process ;*
+ #:process-add-run-reason ;*
+ #:process-revoke-run-reason ;*
+ #:process-add-arrest-reason ;*
+ #:process-revoke-arrest-reason ;*
+ #:process-allow-schedule ;*
+ #:with-timeout ;*
+ #:make-process-lock ;*
+ #:with-process-lock ;*
+ #:process-lock
+ #:process-unlock
+
+ #:current-process
+ #:process-name-to-process
+ #:process-wait-with-timeout
+ #:wait-for-input-available
+ #:process-active-p
+ ))
+
+(defpackage :de.dataheaven.chunked-stream-mixin
+ (:use :common-lisp)
+ (:export #:chunked-stream-mixin
+ #:output-chunking-p #:input-chunking-p))
+
+;; general
+(defpackage acl-compat.socket
+ (:use #:common-lisp
+ #+(or cmu lispworks scl) #:acl-mp
+ #+(or lispworks cmu)#:acl-compat.excl
+ #+clisp #:socket
+ #+sbcl #:sb-bsd-sockets
+ #+(or lispworks cmu) #:de.dataheaven.chunked-stream-mixin
+ #+cormanlisp #:socket
+ )
+ #+cl-ssl (:import-from :ssl #:MAKE-SSL-CLIENT-STREAM #:MAKE-SSL-SERVER-STREAM)
+ #+lispworks (:shadow socket-stream stream-error)
+ (:export
+ #+(or lispworks cmu) #:socket
+ #:make-socket
+ #:accept-connection
+ #:ipaddr-to-dotted
+ #:dotted-to-ipaddr
+ #:ipaddr-to-hostname
+ #:lookup-hostname
+ #:remote-host
+ #:remote-port
+ #:local-host
+ #:local-port
+ #:socket-control
+ #+cl-ssl #:make-ssl-client-stream
+ #+cl-ssl #:make-ssl-server-stream
+ #+(and :lispworks4.4 (not :cl-ssl)) #:make-ssl-client-stream
+ #+(and :lispworks4.4 (not :cl-ssl)) #:make-ssl-server-stream
+ #+lispworks #:socket-os-fd
+ )
+ #-cormanlisp (:nicknames #-(or clisp allegro) socket #-allegro acl-socket))
+
+
+(defpackage acl-compat.system
+ (:nicknames :acl-compat.sys)
+ (:use :common-lisp)
+ (:export
+ #:command-line-arguments
+ #:command-line-argument
+ #:reap-os-subprocess
+ ))
+
+
+; these are not all in the ccl package which causes an error
+#+(and mcl (not openmcl))
+(shadowing-import '(
+ fundamental-binary-input-stream
+ fundamental-binary-output-stream
+ fundamental-character-input-stream
+ fundamental-character-output-stream
+ stream-element-type
+ stream-listen
+ stream-read-byte
+ stream-read-char
+ stream-peek-char
+ stream-write-byte
+ stream-write-char
+ stream-read-char-no-hang
+ stream-force-output
+ stream-finish-output
+ stream-clear-input
+ stream-clear-output
+ stream-line-column
+ stream-read-sequence
+ stream-unread-char
+ stream-read-line
+ stream-write-sequence
+ stream-write-string)
+ :ccl)
+
+#-cormanlisp
+(defpackage :gray-stream
+ (:use #:common-lisp)
+ (:import-from #+lispworks :stream #+cmu :lisp #+clisp :gray #+cormanlisp :gray-streams
+ #+(or mcl openmcl) :ccl #+allegro :excl #+sbcl :sb-gray
+ #:fundamental-binary-input-stream
+ #:fundamental-binary-output-stream
+ #:fundamental-character-input-stream
+ #:fundamental-character-output-stream
+ #:stream-element-type
+ #:stream-listen
+ #:stream-read-byte
+ #:stream-read-char
+ #:stream-peek-char
+ #:stream-write-byte
+ #:stream-write-char
+ #:stream-read-char-no-hang
+ #:stream-force-output
+ #:stream-finish-output
+ #:stream-clear-input
+ #:stream-clear-output
+ #:stream-line-column
+ #-(or clisp openmcl) #:stream-read-sequence
+ #:stream-unread-char
+ #:stream-read-line
+ #-(or clisp openmcl) #:stream-write-sequence
+ #:stream-write-string
+ #+lispworks #:stream-write-buffer
+ #+lispworks #:stream-read-buffer
+ #+lispworks #:stream-fill-buffer
+ #+lispworks #:stream-flush-buffer
+ #+lispworks #:with-stream-input-buffer
+ #+lispworks #:with-stream-output-buffer)
+ (:export
+ #:fundamental-binary-input-stream
+ #:fundamental-binary-output-stream
+ #:fundamental-character-input-stream
+ #:fundamental-character-output-stream
+ #:stream-element-type
+ #:stream-listen
+ #:stream-read-byte
+ #:stream-read-char
+ #:stream-write-byte
+ #:stream-write-char
+ #:stream-read-char-no-hang
+ #:stream-force-output
+ #:stream-finish-output
+ #:stream-clear-input
+ #:stream-clear-output
+ #:stream-line-column
+ #-clisp #:stream-read-sequence
+ #:stream-unread-char
+ #:stream-read-line
+ #-clisp #:stream-write-sequence
+ #:stream-write-string
+ #:stream-write-buffer
+ #:stream-read-buffer
+ #:stream-fill-buffer
+ #:stream-flush-buffer
+ #:with-stream-input-buffer
+ #:with-stream-output-buffer))
+
+#+cormanlisp
+(defpackage :gray-stream
+ (:use #:common-lisp :gray-streams)
+ (:export
+ #:fundamental-binary-input-stream
+ #:fundamental-binary-output-stream
+ #:fundamental-character-input-stream
+ #:fundamental-character-output-stream
+ #:stream-element-type
+ #:stream-listen
+ #:stream-read-byte
+ #:stream-read-char
+ #:stream-write-byte
+ #:stream-write-char
+ #:stream-read-char-no-hang
+ #:stream-force-output
+ #:stream-finish-output
+ #:stream-clear-input
+ #:stream-clear-output
+ #:stream-line-column
+ #:stream-read-sequence
+ #:stream-unread-char
+ #:stream-read-line
+ #:stream-write-sequence
+ #:stream-write-string
+ #:stream-write-buffer
+ #:stream-read-buffer
+ #:stream-fill-buffer
+ #:stream-flush-buffer
+ #:with-stream-input-buffer
+ #:with-stream-output-buffer))
Added: branches/trunk-reorg/thirdparty/acl-compat/sbcl/acl-excl.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/sbcl/acl-excl.lisp Thu Feb 7 03:21:48 2008
@@ -0,0 +1,32 @@
+;;;;
+;;;; ACL-COMPAT - EXCL
+;;;;
+
+;;;; Implementation-specific parts of acl-compat.excl (see
+;;;; acl-excl-common.lisp)
+
+(in-package :acl-compat.excl)
+
+(defun stream-input-fn (stream)
+ stream)
+
+(defun filesys-type (file-or-directory-name)
+ (let ((mode (sb-posix:stat-mode (sb-posix:stat file-or-directory-name))))
+ (cond
+ ((sb-posix:s-isreg mode) :file)
+ ((sb-posix:s-isdir mode) :directory)
+ (t nil))))
+
+(defmacro atomically (&body forms)
+ `(acl-mp:without-scheduling , at forms))
+
+(defun unix-signal (signal pid)
+ (declare (ignore signal pid))
+ (error "unix-signal not implemented in acl-excl-sbcl.lisp"))
+
+(defun filesys-inode (path)
+ (sb-posix:stat-ino (sb-posix:lstat path)))
+
+(defun cl-internal-real-time ()
+ (round (/ (get-internal-real-time) internal-time-units-per-second)))
+
Added: branches/trunk-reorg/thirdparty/acl-compat/sbcl/acl-mp.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/sbcl/acl-mp.lisp Thu Feb 7 03:21:48 2008
@@ -0,0 +1,294 @@
+;; Threading for sbcl, or stub functions for single-threaded sbcl.
+;;
+;; Written by Rudi Schlatte, intended to be distributed along with the
+;; acl-compat library, under the same license as the rest of it.
+
+;; Inspirations taken from Dan Barlow<dan at metacircles.com>'s work for
+;; McCLIM; cut, pasted and mutilated with permission.
+
+(in-package :acl-compat.mp)
+
+(defstruct (process
+ (:constructor %make-process)
+ (:predicate processp))
+ name
+ state
+ whostate
+ function ; function wot will be run
+ arguments ; arguments to the function
+ id ; pid of unix thread or nil
+ %lock ; lock for process structure mutators
+ run-reasons ; primitive mailbox for IPC
+ %queue ; queue for condition-wait
+ initial-bindings ; special variable bindings
+ property-list)
+
+(defparameter *current-process*
+ #-sb-thread
+ (%make-process)
+ #+sb-thread
+ ;; We don't fill in the process id, so the process compiling this
+ ;; (the REPL, in most cases) can't be killed by accident. (loop for
+ ;; p in (all-processes) do (kill-process p)), anyone?
+ (%make-process :name "initial process" :function nil))
+
+(defparameter *all-processes-lock*
+ (sb-thread:make-mutex :name "all processes lock"))
+
+(defparameter *all-processes*
+ (list *current-process*))
+
+#-sb-thread
+(defun make-process (&key (name "Anonymous") reset-action run-reasons
+ arrest-reasons (priority 0) quantum resume-hook
+ suspend-hook initial-bindings run-immediately)
+ (declare (ignore reset-action arrest-reasons priority quantum resume-hook
+ suspend-hook run-immediately))
+ (%make-process :name "the only process"
+ :run-reasons run-reasons
+ :initial-bindings initial-bindings))
+
+#+sb-thread
+(defun make-process (&key (name "Anonymous") reset-action run-reasons
+ arrest-reasons (priority 0) quantum resume-hook
+ suspend-hook initial-bindings run-immediately)
+ (declare (ignore reset-action arrest-reasons priority quantum resume-hook
+ suspend-hook run-immediately))
+ (let ((p (%make-process
+ :name name
+ :run-reasons run-reasons
+ :initial-bindings initial-bindings
+ :%lock (sb-thread:make-mutex
+ :name (format nil "Internal lock for ~A" name))
+ :%queue (sb-thread:make-waitqueue
+ :name (format nil "Blocking queue for ~A" name)))))
+ (sb-thread:with-mutex (*all-processes-lock*)
+ (push p *all-processes*))
+ p))
+
+(defmacro defun/sb-thread (name args &body body)
+ #-sb-thread (declare (ignore body))
+ `(defun ,name ,args
+ #-sb-thread
+ (declare (ignore ,@(remove-if
+ (lambda (x)
+ (member x '(&optional &rest &key &allow-other-keys
+ &aux)))
+ (mapcar (lambda (x) (if (consp x) (car x) x))
+ args))))
+ #-sb-thread
+ (error
+ "~A: Calling a multiprocessing function on a single-threaded sbcl build"
+ ',name)
+ #+sb-thread
+ , at body))
+
+(defun/sb-thread process-interrupt (process function)
+ (sb-thread:interrupt-thread (process-id process) function))
+
+;; TODO: why no such function was in +sb-thread part?
+(defun/sb-thread process-wait-function (process)
+ (declare (ignore process)))
+
+(defun/sb-thread process-wait (reason predicate &rest arguments)
+ (declare (type function predicate))
+ (let ((old-state (process-whostate *current-process*)))
+ (unwind-protect
+ (progn
+ (setf old-state (process-whostate *current-process*)
+ (process-whostate *current-process*) reason)
+ (loop
+ (let ((it (apply predicate arguments)))
+ (when it (return it)))
+ (process-allow-schedule)))
+ (setf (process-whostate *current-process*) old-state))))
+
+(defun/sb-thread process-allow-schedule (&optional process)
+ (declare (ignore process))
+ (sleep .01))
+
+(defun/sb-thread process-revoke-run-reason (process object)
+ (sb-thread:with-recursive-lock ((process-%lock process))
+ (prog1
+ (setf (process-run-reasons process)
+ (delete object (process-run-reasons process)))
+ (when (and (process-id process) (not (process-run-reasons process)))
+ (disable-process process)))))
+
+(defun/sb-thread process-add-run-reason (process object)
+ (sb-thread:with-recursive-lock ((process-%lock process))
+ (prog1
+ (push object (process-run-reasons process))
+ (if (process-id process)
+ (enable-process process)
+ (restart-process process)))))
+
+(defun/sb-thread process-run-function (name-or-options preset-function
+ &rest preset-arguments)
+ (let* ((make-process-args (etypecase name-or-options
+ (list name-or-options)
+ (string (list :name name-or-options))))
+ (process (apply #'make-process make-process-args)))
+ (apply #'process-preset process preset-function preset-arguments)
+ (setf (process-run-reasons process) :enable)
+ (restart-process process)
+ process))
+
+(defun/sb-thread process-preset (process function &rest arguments)
+ (setf (process-function process) function
+ (process-arguments process) arguments)
+ (when (process-id process) (restart-process process)))
+
+(defun/sb-thread process-kill (process)
+ (when (process-id process)
+ (sb-thread:destroy-thread (process-id process))
+ (setf (process-id process) nil))
+ (sb-thread:with-mutex (*all-processes-lock*)
+ (setf *all-processes* (delete process *all-processes*))))
+
+#+sb-thread
+(defun make-process-lock (&key name)
+ (sb-thread:make-mutex :name name))
+#-sb-thread
+(defun make-process-lock (&key name)
+ (declare (ignore name))
+ nil)
+
+(defun/sb-thread process-lock (lock &optional lock-value whostate timeout)
+ (declare (ignore whostate timeout))
+ (sb-thread:get-mutex lock lock-value))
+
+(defun/sb-thread process-unlock (lock &optional lock-value)
+ (declare (ignore lock-value))
+ (sb-thread:release-mutex lock))
+
+#-sb-thread
+(defmacro with-process-lock ((lock &key norecursive timeout whostate)
+ &body forms)
+ (declare (ignore lock norecursive timeout whostate))
+ `(progn , at forms))
+
+#+sb-thread
+(defmacro with-process-lock ((place &key timeout whostate norecursive)
+ &body body)
+ (declare (ignore norecursive timeout))
+ (let ((old-whostate (gensym "OLD-WHOSTATE")))
+ `(sb-thread:with-recursive-lock (,place)
+ (let (,old-whostate)
+ (unwind-protect
+ (progn
+ (when ,whostate
+ (setf ,old-whostate (process-whostate *current-process*))
+ (setf (process-whostate *current-process*) ,whostate))
+ , at body)
+ (setf (process-whostate *current-process*) ,old-whostate))))))
+
+
+#-sb-thread
+(defmacro without-scheduling (&body forms)
+ `(progn , at forms)) ; *
+
+;;; FIXME but, of course, we can't. Fix whoever wants to use it,
+;;; instead
+#+sb-thread
+(defmacro without-scheduling (&body body)
+ `(progn , at body))
+
+;;; Same implementation for multi- and uni-thread
+(defmacro with-timeout ((seconds &body timeout-forms) &body body)
+ (let ((c (gensym "TIMEOUT-")))
+ `(handler-case
+ (sb-ext::with-timeout ,seconds (progn , at body))
+ (sb-ext::timeout (,c) (declare (ignore ,c)) , at timeout-forms))))
+
+(defun/sb-thread restart-process (process)
+ (labels ((boing ()
+ (let ((*current-process* process)
+ (bindings (process-initial-bindings process))
+ (function (process-function process))
+ (arguments (process-arguments process)))
+ (declare (type function function))
+ (if bindings
+ (progv
+ (mapcar #'car bindings)
+ (mapcar #'(lambda (binding)
+ (eval (cdr binding)))
+ bindings)
+ (apply function arguments))
+ (apply function arguments)))))
+ (when (process-id process)
+ (sb-thread:terminate-thread (process-id process)))
+ ;; XXX handle run-reasons in some way? Should a process continue
+ ;; running if all run reasons are taken away before
+ ;; restart-process is called? (process-revoke-run-reason handles
+ ;; this, so let's say (setf (process-run-reasons process) nil) is
+ ;; not guaranteed to do the Right Thing.)
+ (when (setf (process-id process)
+ (sb-thread:make-thread #'boing :name (process-name process)))
+ process)))
+
+(defun current-process ()
+ *current-process*)
+
+(defun all-processes ()
+ (copy-list *all-processes*))
+
+(defun/sb-thread process-wait-with-timeout (reason timeout predicate)
+ (declare (type function predicate))
+ (let ((old-state (process-whostate *current-process*))
+ (end-time (+ (get-universal-time) timeout)))
+ (unwind-protect
+ (progn
+ (setf old-state (process-whostate *current-process*)
+ (process-whostate *current-process*) reason)
+ (loop
+ (let ((it (funcall predicate)))
+ (when (or (> (get-universal-time) end-time) it)
+ (return it)))
+ (sleep .01)))
+ (setf (process-whostate *current-process*) old-state))))
+
+(defun/sb-thread disable-process (process)
+ ;; TODO: set process-whostate
+ ;; Can't figure out how to safely block a thread from a different one
+ ;; and handle all the locking nastiness. So punt for now.
+ (if (eq sb-thread:*current-thread* (process-id process))
+ ;; Keep waiting until we have a reason to run. GC and other
+ ;; things can break a wait prematurely. Don't know if this is
+ ;; expected or not.
+ (do ()
+ ((process-run-reasons process) nil)
+ (sb-thread:with-recursive-lock ((process-%lock process))
+ (sb-thread:condition-wait (process-%queue process)
+ (process-%lock process))))
+ (error "Can't safely disable-process from another thread")))
+
+(defun/sb-thread enable-process (process)
+ ;; TODO: set process-whostate
+ (sb-thread:with-recursive-lock ((process-%lock process))
+ (sb-thread:condition-notify (process-%queue process))))
+
+;;; TODO: integrate with McCLIM / system-wide queue for such things
+#+sb-thread
+(defvar *atomic-spinlock* (sb-thread::make-spinlock))
+
+#-sb-thread
+(defmacro atomic-incf (place)
+ `(incf ,place))
+
+#+sb-thread
+(defmacro atomic-incf (place)
+ `(sb-thread::with-spinlock (*atomic-spinlock*)
+ (incf ,place)))
+
+#-sb-thread
+(defmacro atomic-decf (place)
+ `(decf ,place))
+
+#+sb-thread
+(defmacro atomic-decf (place)
+ `(sb-thread::with-spinlock (*atomic-spinlock*)
+ (decf ,place)))
+
+(defun process-active-p (process)
+ (sb-thread:thread-alive-p (process-id process)))
Added: branches/trunk-reorg/thirdparty/acl-compat/sbcl/acl-socket.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/sbcl/acl-socket.lisp Thu Feb 7 03:21:48 2008
@@ -0,0 +1,283 @@
+;; This package is designed for sbcl. It implements the
+;; ACL-style socket interface on top of sbcl.
+;;
+;; Written by Rudi Schlatte, based on the work done by Jochen Schmidt
+;; for Lispworks and net.lisp in the port library of CLOCC.
+
+(in-package #:acl-compat.socket)
+
+(defclass server-socket ()
+ ((socket :initarg :socket :reader socket
+ :initform (error "No value supplied for socket"))
+ (element-type :type (member signed-byte unsigned-byte base-char)
+ :initarg :element-type
+ :reader element-type
+ :initform (error "No value supplied for element-type"))
+ (port :type fixnum
+ :initarg :port
+ :reader port
+ :initform (error "No value supplied for port"))
+ (stream-type :type (member :text :binary :bivalent)
+ :initarg :stream-type
+ :reader stream-type
+ :initform (error "No value supplied for stream-type"))))
+
+(defclass datagram-socket (server-socket)
+ ())
+
+
+(defmethod print-object ((socket server-socket) stream)
+ (print-unreadable-object (socket stream :type t :identity nil)
+ (format stream "listening on port ~d" (port socket))))
+
+(defmethod print-object ((socket datagram-socket) stream)
+ (print-unreadable-object (socket stream :type t :identity nil)
+ (format stream "datagram socket listening on port ~d" (port socket))))
+
+(defgeneric accept-connection (socket &key wait))
+(defmethod accept-connection ((server-socket server-socket)
+ &key (wait t))
+ "Return a bidirectional stream connected to socket."
+ (if (sb-sys:wait-until-fd-usable (socket-file-descriptor (socket server-socket))
+ :input (if (numberp wait) wait nil))
+ (let* ((socket (socket-accept (socket server-socket)))
+ (stream (socket-make-stream socket
+ :input t :output t
+ ; :buffering :none
+ :element-type
+ (element-type server-socket)
+ :auto-close t)))
+ (if (eq (stream-type server-socket) :bivalent)
+ ;; HACK: remember socket, so we can do peer lookup
+ (make-bivalent-stream stream :plist `(:socket ,socket))
+ stream))
+ nil))
+
+(defmethod receive-from ((socket datagram-socket) size &key buffer extract)
+ (multiple-value-bind (rbuf len address port)
+ (socket-receive (socket socket) buffer size)
+ (declare (ignore port))
+ (let ((buf
+ (if (not extract)
+ rbuf
+ (subseq rbuf 0 len)))) ;; FIXME: am I right?
+ (when buffer
+ (replace buffer buf :end2 len))
+ (values
+ (if buffer buffer buf)
+ len
+ address))))
+
+(defmethod send-to ((socket datagram-socket) buffer size &key remote-host remote-port)
+ (let* ((rhost (typecase remote-host
+ (string (lookup-hostname remote-host))
+ (otherwise remote-host)))
+ (s (socket socket))
+ (stream (progn
+ (socket-connect s rhost remote-port)
+ (socket-make-stream s :input t :output t :buffering :none))))
+ (write-sequence buffer stream)
+ size))
+
+
+
+(defun make-socket (&key
+ (type :stream)
+ (remote-host "localhost")
+ local-port
+ remote-port
+ (connect :active)
+ (format :text)
+ (reuse-address t)
+ &allow-other-keys)
+ "Return a stream connected to remote-host if connect is :active, or
+something listening on local-port that can be fed to accept-connection
+if connect is :passive.
+
+This is an incomplete implementation of ACL's make-socket function!
+It was written to provide the functionality necessary to port
+AllegroServe. Refer to
+http://franz.com/support/documentation/6.1/doc/pages/operators/socket/make-socket.htm
+to read about the missing parts."
+ (check-type remote-host string)
+ (let ((element-type (ecase format
+ (:text 'base-char)
+ (:binary 'signed-byte)
+ (:bivalent 'unsigned-byte)))
+ (socket
+ (if (eq type :datagram)
+ (progn
+ (setf connect :passive-udp)
+ (make-instance 'inet-socket :type :datagram :protocol :udp))
+ (make-instance 'inet-socket :type :stream :protocol :tcp))))
+ (ecase connect
+ (:passive-udp
+ (setf (sockopt-reuse-address socket) reuse-address)
+ (if local-port
+ (socket-bind socket #(0 0 0 0) local-port))
+ (make-instance 'datagram-socket
+ :port (nth-value 1 (socket-name socket))
+ :socket socket
+ :element-type element-type
+ :stream-type format))
+ (:passive
+ (setf (sockopt-reuse-address socket) reuse-address)
+ (if local-port
+ (socket-bind socket #(0 0 0 0) local-port))
+ (socket-listen socket 10) ;Arbitrarily chosen backlog value
+ (make-instance 'server-socket
+ :port (nth-value 1 (socket-name socket))
+ :socket socket
+ :element-type element-type
+ :stream-type format))
+ (:active
+ (socket-connect socket (lookup-hostname remote-host) remote-port)
+ (let ((stream (socket-make-stream socket :input t :output t
+ :element-type element-type
+ ; :buffering :none
+ )))
+ (if (eq :bivalent format)
+ ;; HACK: remember socket, so we can do peer lookup
+ (make-bivalent-stream stream :plist `(:socket ,socket))
+ stream))))))
+
+(defmethod close ((server server-socket) &key abort)
+ "Kill a passive (listening) socket. (Active sockets are actually
+streams and handled by their close methods."
+ (declare (ignore abort))
+ (socket-close (socket server)))
+
+#+ignore
+(declaim (ftype (function ((unsigned-byte 32) &key (:values t))
+ (or (values fixnum fixnum fixnum fixnum)
+ (values simple-string)))
+ ipaddr-to-dotted))
+(defun ipaddr-to-dotted (ipaddr &key values)
+ "Convert from 32-bit integer to dotted string."
+ (declare (type (unsigned-byte 32) ipaddr))
+ (let ((a (logand #xff (ash ipaddr -24)))
+ (b (logand #xff (ash ipaddr -16)))
+ (c (logand #xff (ash ipaddr -8)))
+ (d (logand #xff ipaddr)))
+ (if values
+ (values a b c d)
+ (format nil "~d.~d.~d.~d" a b c d))))
+
+(defun ipaddr-to-vector (ipaddr)
+ "Convert from 32-bit integer to a vector of octets."
+ (declare (type (unsigned-byte 32) ipaddr))
+ (let ((a (logand #xff (ash ipaddr -24)))
+ (b (logand #xff (ash ipaddr -16)))
+ (c (logand #xff (ash ipaddr -8)))
+ (d (logand #xff ipaddr)))
+ (make-array 4 :initial-contents (list a b c d))))
+
+(declaim (ftype (function (vector)
+ (values (unsigned-byte 32)))
+ vector-to-ipaddr))
+(defun vector-to-ipaddr (sensible-ipaddr)
+ "Convert from 4-integer vector to 32-bit integer."
+ (loop with result = 0
+ for component across sensible-ipaddr
+ do (setf result (+ (ash result 8) component))
+ finally (return result)))
+
+(defun string-tokens (string)
+ (labels ((get-token (str pos1 acc)
+ (let ((pos2 (position #\Space str :start pos1)))
+ (if (not pos2)
+ (nreverse acc)
+ (get-token str (1+ pos2) (cons (read-from-string (subseq str pos1 pos2))
+ acc))))))
+ (get-token (concatenate 'string string " ") 0 nil)))
+
+(declaim (ftype (function (string &key (:errorp t))
+ (or null (unsigned-byte 32)))
+ dotted-to-ipaddr))
+(defun dotted-to-ipaddr (dotted &key (errorp t))
+ "Convert from dotted string to 32-bit integer."
+ (declare (string dotted))
+ (if errorp
+ (let ((ll (string-tokens (substitute #\Space #\. dotted))))
+ (+ (ash (first ll) 24) (ash (second ll) 16)
+ (ash (third ll) 8) (fourth ll)))
+ (ignore-errors
+ (let ((ll (string-tokens (substitute #\Space #\. dotted))))
+ (+ (ash (first ll) 24) (ash (second ll) 16)
+ (ash (third ll) 8) (fourth ll))))))
+
+(defun ipaddr-to-hostname (ipaddr &key ignore-cache)
+ (when ignore-cache
+ (warn ":IGNORE-CACHE keyword in IPADDR-TO-HOSTNAME not supported."))
+ (host-ent-name (get-host-by-address (ipaddr-to-vector ipaddr))))
+
+(defun lookup-hostname (host &key ignore-cache)
+ (when ignore-cache
+ (warn ":IGNORE-CACHE keyword in LOOKUP-HOSTNAME not supported."))
+ (if (stringp host)
+ (host-ent-address (get-host-by-name host))
+ (dotted-to-ipaddr (ipaddr-to-dotted host))))
+
+(defun remote-host (socket-stream)
+ (let (socket)
+ (if (and (typep socket-stream 'chunked-stream)
+ (setf socket (getf (stream-plist socket-stream) :socket)))
+ (vector-to-ipaddr (socket-peername socket))
+ (progn (warn "Could not get remote host for ~S" socket-stream)
+ 0))))
+
+(defun remote-port (socket-stream)
+ (let (socket)
+ (if (and (typep socket-stream 'chunked-stream)
+ (setq socket (getf (stream-plist socket-stream) :socket)))
+ (nth-value 1 (socket-peername socket))
+ (progn (warn "Could not get remote port for ~S" socket-stream)
+ 0))))
+
+(defun local-host (thing)
+ (typecase thing
+ (chunked-stream (let ((socket (getf (stream-plist thing) :socket)))
+ (if socket (vector-to-ipaddr (socket-name socket))
+ (progn (warn "Socket not in plist of ~S -- could not get local host" thing)
+ 0))))
+ (server-socket (vector-to-ipaddr #(127 0 0 1)))
+ (t (progn (warn "Could not get local host for ~S" thing)
+ 0))))
+
+(defun local-port (thing)
+ (typecase thing
+ (chunked-stream (let ((socket (getf (stream-plist thing) :socket)))
+ (if socket (nth-value 1 (socket-name socket))
+ (progn (warn "Socket not in plist of ~S -- could not get local port" thing)
+ 0))))
+ (server-socket (port thing))
+ (t (progn (warn "Could not get local port for ~S" thing)
+ 0))))
+
+;; Now, throw chunking in the mix
+
+(defclass chunked-stream (de.dataheaven.chunked-stream-mixin::chunked-stream-mixin
+ gray-stream::buffered-bivalent-stream)
+ ((plist :initarg :plist :accessor stream-plist)))
+
+
+(defun make-bivalent-stream (lisp-stream &key plist)
+ (make-instance 'chunked-stream :lisp-stream lisp-stream :plist plist))
+
+
+(defun socket-control (stream &key (output-chunking nil oc-p) output-chunking-eof (input-chunking nil ic-p))
+ (when oc-p
+ (when output-chunking
+ (de.dataheaven.chunked-stream-mixin::initialize-output-chunking stream))
+ (setf (de.dataheaven.chunked-stream-mixin::output-chunking-p stream)
+ output-chunking))
+ (when output-chunking-eof
+ (de.dataheaven.chunked-stream-mixin::disable-output-chunking stream))
+ (when ic-p
+ (when input-chunking
+ (de.dataheaven.chunked-stream-mixin::initialize-input-chunking stream))
+ (setf (de.dataheaven.chunked-stream-mixin::input-chunking-p stream)
+ input-chunking)))
+
+
+(provide 'acl-socket)
Added: branches/trunk-reorg/thirdparty/acl-compat/sbcl/acl-sys.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/sbcl/acl-sys.lisp Thu Feb 7 03:21:48 2008
@@ -0,0 +1,11 @@
+(in-package :acl-compat.system)
+
+(defun command-line-arguments ()
+ sb-ext:*posix-argv*)
+
+(defun command-line-argument (n)
+ (nth n sb-ext:*posix-argv*))
+
+(defun reap-os-subprocess (&key (wait nil))
+ (declare (ignore wait))
+ nil)
Added: branches/trunk-reorg/thirdparty/acl-compat/scl/acl-excl.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/scl/acl-excl.lisp Thu Feb 7 03:21:48 2008
@@ -0,0 +1,264 @@
+;;;;
+;;;; ACL-COMPAT - EXCL
+;;;;
+
+;;;; Implementation-specific parts of acl-compat.excl (see
+;;;; acl-excl-common.lisp)
+
+(defpackage :acl-compat.excl
+ (:use #:common-lisp #:ext)
+ (:export
+ #:if*
+ #:*initial-terminal-io*
+ #:*cl-default-special-bindings*
+ #:filesys-size
+ #:filesys-write-date
+ #:stream-input-fn
+ #:match-regexp
+ #:compile-regexp
+ #:*current-case-mode*
+ #:intern*
+ #:filesys-type
+ #:errorset
+ #:atomically
+ #:fast
+ #:without-package-locks
+ #:string-to-octets
+ #:write-vector
+
+ ;; TODO: find better place for bivalent stream classes
+ #:bivalent-input-stream
+ #:bivalent-output-stream
+ #:bivalent-stream
+ #:make-bivalent-input-stream
+ #:make-bivalent-output-stream
+ #:make-bivalent-stream
+ ))
+
+(in-package :acl-compat.excl)
+
+(defun stream-input-fn (stream)
+ stream)
+
+(defun filesys-type (file-or-directory-name)
+ (if (eq :directory (unix:unix-file-kind
+ (namestring file-or-directory-name)))
+ :directory
+ (if (probe-file file-or-directory-name)
+ :file
+ nil)))
+
+(defmacro atomically (&body forms)
+ `(mp:without-scheduling , at forms))
+
+(defun unix-signal (signal pid)
+ ;; fixxme: did I get the arglist right? only invocation I have seen
+ ;; is (excl::unix-signal 15 0) in net.aserve:start
+ (unix:unix-kill pid signal))
+
+(defmacro without-package-locks (&body forms)
+ `(progn , at forms))
+
+
+;;; Bivalent Gray streams
+
+
+(defclass lisp-stream-mixin ()
+ ;; For bivalent streams, lisp-stream must be a stream of type
+ ;; unsigned-byte
+ ((lisp-stream :initarg :lisp-stream
+ :accessor lisp-stream)))
+
+(defclass bivalent-input-stream (lisp-stream-mixin
+ fundamental-character-input-stream
+ fundamental-binary-input-stream))
+
+(defclass bivalent-output-stream (lisp-stream-mixin
+ fundamental-character-output-stream
+ fundamental-binary-output-stream))
+
+(defclass bivalent-stream (bivalent-input-stream bivalent-output-stream))
+
+
+(defun make-bivalent-input-stream (lisp-stream)
+ (declare (type system:lisp-stream lisp-stream))
+ (make-instance 'bivalent-input-stream :lisp-stream lisp-stream))
+
+(defun make-bivalent-output-stream (lisp-stream)
+ (declare (type system:lisp-stream lisp-stream))
+ (make-instance 'bivalent-output-stream :lisp-stream lisp-stream))
+
+(defun make-bivalent-stream (lisp-stream)
+ (declare (type system:lisp-stream lisp-stream))
+ (make-instance 'bivalent-stream :lisp-stream lisp-stream))
+
+
+(defmethod open-stream-p ((stream lisp-stream-mixin))
+ (common-lisp::open-stream-p (lisp-stream stream)))
+
+(defmethod close ((stream lisp-stream-mixin) &key abort)
+ (close (lisp-stream stream) :abort abort))
+
+(defmethod input-stream-p ((stream lisp-stream-mixin))
+ (input-stream-p (lisp-stream stream)))
+
+(defmethod output-stream-p ((stream lisp-stream-mixin))
+ (output-stream-p (lisp-stream stream)))
+
+(defmethod stream-element-type ((stream bivalent-input-stream))
+ '(or character (unsigned-byte 8)))
+
+(defmethod stream-read-char ((stream bivalent-input-stream))
+ (code-char (read-byte (lisp-stream stream) nil :eof)))
+
+(defmethod stream-read-byte ((stream bivalent-input-stream))
+ (read-byte (lisp-stream stream) nil :eof))
+
+;; stream-unread-char
+
+(defmethod stream-read-char-no-hang ((stream bivalent-input-stream))
+ (if (listen (lisp-stream stream))
+ (code-char (read-byte (lisp-stream stream)))
+ nil))
+
+;; stream-peek-char
+
+(defmethod stream-listen ((stream bivalent-input-stream))
+ (listen (lisp-stream stream)))
+
+(defmethod stream-clear-input ((stream bivalent-input-stream))
+ (clear-input (lisp-stream stream)))
+
+(defmethod stream-read-sequence ((stream bivalent-input-stream)
+ (seq vector) &optional start end)
+ (unless start (setf start 0))
+ (unless end (setf end (length seq)))
+ (assert (<= end (length seq)))
+ (if (subtypep (array-element-type seq) 'character)
+ (loop for count upfrom start
+ for i from start below end
+ do (setf (aref seq i) (code-char (read-byte stream)))
+ finally (return count))
+ (read-sequence seq (lisp-stream stream)
+ :start start :end end)))
+
+(defmethod stream-read-sequence ((stream bivalent-input-stream)
+ (seq cons) &optional (start 0) end)
+ (unless start (setf start 0))
+ (unless end (setf end (length seq)))
+ (let ((seq (nthcdr start seq)))
+ (loop for count upfrom start
+ for head on seq
+ for i below (- end start)
+ while head
+ do (setf (car head) (read-byte stream))
+ finally (return count))))
+
+(defmethod stream-read-sequence ((stream bivalent-input-stream)
+ (seq null) &optional (start 0) end)
+ (declare (ignore end))
+ start)
+
+(defmethod stream-element-type ((stream bivalent-output-stream))
+ '(or character (unsigned-byte 8)))
+
+(defmethod stream-write-char ((stream bivalent-output-stream) character)
+ (write-byte (char-code character) (lisp-stream stream)))
+
+(defmethod stream-write-byte ((stream bivalent-output-stream) byte)
+ (write-byte byte (lisp-stream stream)))
+
+(defmethod stream-line-column ((stream bivalent-output-stream))
+ nil)
+
+(defmethod stream-finish-output ((stream bivalent-output-stream))
+ (finish-output (lisp-stream stream)))
+
+(defmethod stream-force-output ((stream bivalent-output-stream))
+ (force-output (lisp-stream stream)))
+
+(defmethod stream-clear-output ((stream bivalent-output-stream))
+ (clear-output (lisp-stream stream)))
+
+(defmethod stream-write-sequence ((stream bivalent-output-stream)
+ (seq vector) &optional (start 0) end)
+ (let ((length (length seq)))
+ (unless end (setf end length))
+ (assert (<= end length)))
+ (unless start (setf start 0))
+ (when (< end start)
+ (cerror "Continue with switched start and end ~s <-> ~s"
+ "Stream-write-sequence: start (~S) and end (~S) exchanged."
+ start end seq)
+ (rotatef start end))
+ (cond
+ ((subtypep (array-element-type seq) '(unsigned-byte 8))
+ (write-sequence seq (lisp-stream stream) :start start :end end))
+ ((subtypep (array-element-type seq) 'character)
+ (loop for i from start below end
+ do (stream-write-char stream (aref seq i))))
+ ((subtypep (array-element-type seq) 'integer)
+ (loop for i from start below end
+ do (stream-write-byte stream (aref seq i)))))
+ seq)
+
+(defmethod stream-write-sequence ((stream bivalent-output-stream)
+ (seq cons) &optional (start 0) end)
+ (let ((length (length seq)))
+ (unless end (setf end length))
+ (assert (<= end length)))
+ (unless start (setf start 0))
+ (when (< end start)
+ (cerror "Continue with switched start and end ~s <-> ~s"
+ "Stream-write-sequence: start (~S) and end (~S) exchanged."
+ start end seq)
+ (rotatef start end))
+ (let ((seq (nthcdr start seq)))
+ (loop for element in seq
+ for i below (- end start)
+ while seq
+ do (etypecase element
+ (character (stream-write-char stream element))
+ (integer (stream-write-byte stream element)))))
+ seq)
+
+(defmethod stream-write-sequence ((stream bivalent-output-stream)
+ (seq null) &optional (start 0) end)
+ (declare (ignore start end))
+ seq)
+
+;;; End bivalent Gray streams
+
+(defun string-to-octets (string &key (null-terminate t) (start 0)
+ end mb-vector make-mb-vector?
+ (external-format :default))
+ "This function returns a lisp-usb8-vector and the number of bytes copied."
+ (declare (ignore external-format))
+ ;; The end parameter is different in ACL's lambda list, but this
+ ;; variant lets us give an argument :end nil explicitly, and the
+ ;; right thing will happen
+ (unless end (setf end (length string)))
+ (let* ((number-of-octets (if null-terminate (1+ (- end start))
+ (- end start)))
+ (mb-vector (cond
+ ((and mb-vector (>= (length mb-vector) number-of-octets))
+ mb-vector)
+ ((or (not mb-vector) make-mb-vector?)
+ (make-array (list number-of-octets)
+ :element-type '(unsigned-byte 8)
+ :initial-element 0))
+ (t (error "Was given a vector of length ~A, ~
+ but needed at least length ~A."
+ (length mb-vector) number-of-octets)))))
+ (declare (type (simple-array (unsigned-byte 8) (*)) mb-vector))
+ (loop for from-index from start below end
+ for to-index upfrom 0
+ do (progn
+ (setf (aref mb-vector to-index)
+ (char-code (aref string from-index)))))
+ (when null-terminate
+ (setf (aref mb-vector (1- number-of-octets)) 0))
+ (values mb-vector number-of-octets)))
+
+
+(provide 'acl-excl)
Added: branches/trunk-reorg/thirdparty/acl-compat/scl/acl-mp.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/scl/acl-mp.lisp Thu Feb 7 03:21:48 2008
@@ -0,0 +1,155 @@
+;; This package is designed for cmucl. It implements ACL-style
+;; multiprocessing on top of cmucl (basically, process run reasons and
+;; some function renames).
+;;
+;; Written by Rudi Schlatte, based on the work done by Jochen Schmidt
+;; for Lispworks.
+
+(in-package :acl-compat-mp)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Import equivalent parts from the CMU MP package ;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(shadowing-import '(mp:*current-process*
+ ;; mp::process-preset
+ mp::process-reset
+ mp:process-interrupt
+ mp::process-name
+ mp::process-wait-function
+ mp:process-run-reasons
+ mp:process-add-run-reason
+ mp:process-revoke-run-reason
+ mp:process-arrest-reasons
+ mp:process-add-arrest-reason
+ mp:process-revoke-arrest-reason
+ mp:process-whostate
+ ; mp:without-interrupts
+ mp:process-wait
+ mp:with-timeout
+ mp:without-scheduling
+ ))
+
+(export '(*current-process*
+ ;; process-preset
+ process-reset
+ process-interrupt
+ process-name
+ process-wait-function
+ process-whostate
+ process-wait
+ with-timeout
+ without-scheduling
+ process-run-reasons
+ process-add-run-reason
+ process-revoke-run-reason
+ process-arrest-reasons
+ process-add-arrest-reason
+ process-revoke-arrest-reason
+ ))
+
+
+(defun process-allow-schedule ()
+ (mp:process-yield))
+
+(defvar *process-plists* (make-hash-table :test #'eq)
+ "maps processes to their plists.
+See the functions process-plist, (setf process-plist).")
+
+(defun process-property-list (process)
+ (gethash process *process-plists*))
+
+(defun (setf process-property-list) (new-value process)
+ (setf (gethash process *process-plists*) new-value))
+
+#||
+
+;;; rudi 2002-06-09: This is not needed as of cmucl 18d, thanks to Tim
+;;; Moore who added run reasons to cmucl's multithreading. Left in
+;;; for the time being just in case someone wants to get acl-compat
+;;; running on older cmucl's. Can be deleted safely.
+
+(defvar *process-run-reasons* (make-hash-table :test #'eq)
+ "maps processes to their run-reasons.
+See the functions process-run-reasons, (setf process-run-reasons),
+process-add-run-reason, process-revoke-run-reason.")
+
+(defun process-run-reasons (process)
+ (gethash process *process-run-reasons*))
+
+(defun (setf process-run-reasons) (new-value process)
+ (mp:without-scheduling
+ (prog1
+ (setf (gethash process *process-run-reasons*) new-value)
+ (if new-value
+ (mp:enable-process process)
+ (mp:disable-process process)))))
+
+(defun process-revoke-run-reason (process object)
+ (without-scheduling
+ (setf (process-run-reasons process)
+ (remove object (process-run-reasons process))))
+ (when (and (eq process mp:*current-process*))
+ (mp:process-yield)))
+
+(defun process-add-run-reason (process object)
+ (setf (process-run-reasons process)
+ (pushnew object (process-run-reasons process))))
+||#
+
+(defun process-run-function (name-or-options preset-function
+ &rest preset-arguments)
+ (let ((process (ctypecase name-or-options
+ (string (make-process :name name-or-options))
+ (list (apply #'make-process name-or-options)))))
+ (apply #'acl-mp::process-preset process preset-function preset-arguments)
+ process))
+
+(defun process-preset (process preset-function &rest arguments)
+ (mp:process-preset process
+ #'(lambda ()
+ (apply-with-bindings preset-function
+ arguments
+ (process-initial-bindings process)))))
+
+(defvar *process-initial-bindings* (make-hash-table :test #'eq))
+
+(defun process-initial-bindings (process)
+ (gethash process *process-initial-bindings*))
+
+(defun (setf process-initial-bindings) (bindings process)
+ (setf (gethash process *process-initial-bindings*) bindings))
+
+
+;;; ;;;
+;;; Contributed by Tim Moore ;;;
+;;; ;;;
+(defun apply-with-bindings (function args bindings)
+ (if bindings
+ (progv
+ (mapcar #'car bindings)
+ (mapcar #'(lambda (binding)
+ (eval (cdr binding))))
+ (apply function args))
+ (apply function args)))
+
+(defun make-process (&key (name "Anonymous") reset-action run-reasons
+ arrest-reasons (priority 0) quantum resume-hook
+ suspend-hook initial-bindings run-immediately)
+ (declare (ignore priority quantum reset-action resume-hook suspend-hook
+ run-immediately))
+ (mp:make-process nil :name name
+ :run-reasons run-reasons
+ :arrest-reasons arrest-reasons
+ :initial-bindings initial-bindings))
+
+(defun process-kill (process)
+ (mp:destroy-process process))
+
+
+(defun make-process-lock (&key name)
+ (mp:make-lock name))
+
+(defmacro with-process-lock ((lock &key norecursive) &body forms)
+ (declare (ignore norecursive))
+ `(mp:with-lock-held (,lock) , at forms))
Added: branches/trunk-reorg/thirdparty/acl-compat/scl/acl-socket.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/scl/acl-socket.lisp Thu Feb 7 03:21:48 2008
@@ -0,0 +1,196 @@
+;; This package is designed for scl. It implements the
+;; ACL-style socket interface on top of scl.
+;;
+;; Written by Rudi Schlatte, based on the work done by Jochen Schmidt
+;; for Lispworks and net.lisp in the port library of CLOCC.
+;;
+;; This was modified for SCL by Kevin Rosenberg
+
+(defpackage acl-socket
+ (:use "MP" "COMMON-LISP")
+ #+cl-ssl (:import-from :ssl "MAKE-SSL-CLIENT-STREAM" "MAKE-SSL-SERVER-STREAM")
+ (:export #:socket #:make-socket #:accept-connection
+ #:ipaddr-to-dotted #:dotted-to-ipaddr #:ipaddr-to-hostname #:lookup-hostname
+ #:remote-host #:remote-port #:local-host #:local-port #:socket-control
+ #+cl-ssl #:make-ssl-client-stream #+cl-ssl #:make-ssl-server-stream)
+ (:nicknames socket))
+
+(in-package socket)
+
+(defclass socket ()
+ ((fd :type fixnum
+ :initarg :fd
+ :reader fd)))
+
+(defmethod print-object ((socket socket) stream)
+ (print-unreadable-object (socket stream :type t :identity t)
+ (format stream "@~d" (fd socket))))
+
+(defclass server-socket (socket)
+ ((element-type :type (member signed-byte unsigned-byte base-char)
+ :initarg :element-type
+ :reader element-type
+ :initform (error "No value supplied for element-type"))
+ (port :type fixnum
+ :initarg :port
+ :reader port
+ :initform (error "No value supplied for port"))
+ (stream-type :type (member :text :binary :bivalent)
+ :initarg :stream-type
+ :reader stream-type
+ :initform (error "No value supplied for stream-type"))))
+
+#+cl-ssl
+(defmethod make-ssl-server-stream ((lisp-stream system:lisp-stream)
+ &rest options)
+ (apply #'make-ssl-server-stream (system:fd-stream-fd lisp-stream) options))
+
+(defmethod print-object ((socket server-socket) stream)
+ (print-unreadable-object (socket stream :type t :identity nil)
+ (format stream "@~d on port ~d" (fd socket) (port socket))))
+
+(defmethod accept-connection ((server-socket server-socket)
+ &key (wait t))
+ "Return a bidirectional stream connected to socket, or nil if no
+client wanted to initiate a connection and wait is nil."
+ ;; fixxme: perhaps check whether we run multiprocessing and use
+ ;; sys:wait-until-fd-usable instead of
+ ;; mp:process-wait-until-fd-usable here?
+
+ ;; api pipe fitting: wait t ==> timeout nil
+ (when (mp:process-wait-until-fd-usable (fd server-socket) :input
+ (if wait nil 0))
+ (let ((stream (sys:make-fd-stream
+ (ext:accept-tcp-connection (fd server-socket))
+ :input t :output t
+ :element-type (element-type server-socket)
+ :auto-close t)))
+ (if (eq (stream-type server-socket) :bivalent)
+ (excl:make-bivalent-stream stream)
+ stream))))
+
+(defun make-socket (&key (remote-host "localhost")
+ local-port
+ remote-port
+ (connect :active)
+ (format :text)
+ &allow-other-keys)
+ "Return a stream connected to remote-host if connect is :active, or
+something listening on local-port that can be fed to accept-connection
+if connect is :passive.
+
+This is an incomplete implementation of ACL's make-socket function!
+It was written to provide the functionality necessary to port
+AllegroServe. Refer to
+http://franz.com/support/documentation/6.1/doc/pages/operators/socket/make-socket.htm
+to read about the missing parts."
+ (check-type remote-host string)
+ (let ((element-type (ecase format
+ (:text 'base-char)
+ (:binary 'signed-byte)
+ (:bivalent 'unsigned-byte))))
+ (ecase connect
+ (:passive
+ (make-instance 'server-socket
+ :port local-port
+ :fd (ext:create-inet-listener local-port)
+ :element-type element-type
+ :stream-type format))
+ (:active
+ (let ((stream (sys:make-fd-stream
+ (ext:connect-to-inet-socket remote-host remote-port)
+ :input t :output t :element-type element-type)))
+ (if (eq :bivalent format)
+ (excl:make-bivalent-stream stream)
+ stream))))))
+
+(defmethod close ((server server-socket) &key abort)
+ "Kill a passive (listening) socket. (Active sockets are actually
+streams and handled by their close methods."
+ (declare (ignore abort))
+ (unix:unix-close (fd server)))
+
+(declaim (ftype (function ((unsigned-byte 32) &key (:values t))
+ (values simple-string))
+ ipaddr-to-dotted))
+(defun ipaddr-to-dotted (ipaddr &key values)
+ (declare (type (unsigned-byte 32) ipaddr))
+ (let ((a (logand #xff (ash ipaddr -24)))
+ (b (logand #xff (ash ipaddr -16)))
+ (c (logand #xff (ash ipaddr -8)))
+ (d (logand #xff ipaddr)))
+ (if values
+ (values a b c d)
+ (format nil "~d.~d.~d.~d" a b c d))))
+
+(defun string-tokens (string)
+ (labels ((get-token (str pos1 acc)
+ (let ((pos2 (position #\Space str :start pos1)))
+ (if (not pos2)
+ (nreverse acc)
+ (get-token str (1+ pos2) (cons (read-from-string (subseq str pos1 pos2))
+ acc))))))
+ (get-token (concatenate 'string string " ") 0 nil)))
+
+(declaim (ftype (function (string &key (:errorp t))
+ (values (unsigned-byte 32)))
+ dotted-to-ipaddr))
+(defun dotted-to-ipaddr (dotted &key (errorp t))
+ (declare (string dotted))
+ (if errorp
+ (let ((ll (string-tokens (substitute #\Space #\. dotted))))
+ (+ (ash (first ll) 24) (ash (second ll) 16)
+ (ash (third ll) 8) (fourth ll)))
+ (ignore-errors
+ (let ((ll (string-tokens (substitute #\Space #\. dotted))))
+ (+ (ash (first ll) 24) (ash (second ll) 16)
+ (ash (third ll) 8) (fourth ll))))))
+
+(defun ipaddr-to-hostname (ipaddr &key ignore-cache)
+ (when ignore-cache
+ (warn ":IGNORE-CACHE keyword in IPADDR-TO-HOSTNAME not supported."))
+ (ext:host-entry-name (ext:lookup-host-entry ipaddr)))
+
+(defun lookup-hostname (host &key ignore-cache)
+ (when ignore-cache
+ (warn ":IGNORE-CACHE keyword in LOOKUP-HOSTNAME not supported."))
+ (if (stringp host)
+ (car (ext:host-entry-addr-list (ext:lookup-host-entry host)))
+ (dotted-to-ipaddr (ipaddr-to-dotted host))))
+
+(defgeneric get-fd (stream))
+
+(defmethod get-fd ((stream excl::lisp-stream-mixin))
+ (system:fd-stream-fd (excl::lisp-stream stream)))
+
+(defmethod get-fd ((stream system:lisp-stream))
+ (system:fd-stream-fd stream))
+
+(defun remote-host (socket-stream)
+ (ext:get-peer-host-and-port (get-fd socket-stream)))
+
+(defun remote-port (socket-stream)
+ (multiple-value-bind (host port)
+ (ext:get-peer-host-and-port (get-fd socket-stream))
+ (declare (ignore host))
+ port))
+
+(defun local-host (socket-stream)
+ (ext:get-socket-host-and-port (get-fd socket-stream)))
+
+(defun local-port (socket-stream)
+ (if (typep socket-stream 'socket::server-socket)
+ (port socket-stream)
+ (multiple-value-bind (host port)
+ (ext:get-socket-host-and-port (get-fd socket-stream))
+ (declare (ignore host))
+ port)))
+
+(defun socket-control (stream &key output-chunking output-chunking-eof input-chunking)
+ (declare (ignore stream))
+ (warn "SOCKET-CONTROL function not implemented.")
+ (when (or output-chunking output-chunking-eof input-chunking)
+ (error "Chunking is not yet supported in scl. Restart the server with chunking off.")))
+
+
+(provide 'acl-socket)
Added: branches/trunk-reorg/thirdparty/acl-compat/scl/acl-sys.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/scl/acl-sys.lisp Thu Feb 7 03:21:48 2008
@@ -0,0 +1,18 @@
+(in-package :sys)
+
+(ignore-errors
+(export 'command-line-arguments)
+(export 'command-line-argument)
+(export 'reap-os-subprocess)
+
+(defun command-line-arguments ()
+ ext:*command-line-strings*)
+
+(defun command-line-argument (n)
+ (nth n ext:*command-line-strings*))
+
+(defun reap-os-subprocess (&key (wait nil))
+ (declare (ignore wait))
+ nil)
+
+)
Added: branches/trunk-reorg/thirdparty/acl-compat/test-acl-socket.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/test-acl-socket.lisp Thu Feb 7 03:21:48 2008
@@ -0,0 +1,61 @@
+;;; Unit tests for the ACL-SOCKET compatibility package.
+
+(in-package cl-user)
+
+(require :acl-socket)
+
+(use-package '(acl-socket))
+
+(defun test1 ()
+ (let ((stream (make-socket :connect :active :remote-host "127.0.0.1" :remote-port 2500)))
+ (when stream
+ (read-line stream)
+ (format stream "helo foo")
+ (write-char #\Return stream)
+ (write-char #\Linefeed stream)
+ (finish-output stream)
+ (read-line stream)
+ (close stream))))
+
+(defun test2 ()
+ (let ((stream (make-socket :connect :active :remote-host "127.0.0.1" :remote-port 2500)))
+ (when stream
+ (socket-control stream :output-chunking t)
+ (read-line stream)
+ (format stream "helo foo")
+ (write-char #\Return stream)
+ (write-char #\Linefeed stream)
+ (finish-output stream)
+ (read-line stream)
+ (close stream))))
+
+(defun test3 ()
+ (let ((stream (make-socket :connect :active :remote-host "127.0.0.1" :remote-port 2500)))
+ (when stream
+ (socket-control stream :input-chunking t)
+ (prog1
+ (read-line stream)
+ (close stream)))))
+
+(defun test4 ()
+ (let ((stream (or (make-socket :connect :active :remote-host "127.0.0.1" :remote-port 2500)
+ (error "Failed to connect."))))
+ (socket-control stream :input-chunking t)
+ (format t "File number 1: ")
+ #1=(handler-case
+ (loop
+ for char = (read-char stream nil stream)
+ until (eq char stream)
+ do (write-char char))
+ (excl::socket-chunking-end-of-file (e) (socket-control stream :input-chunking t)))
+ (format t "~%File number 2: ")
+ #1#
+ (terpri)
+ (values)))
+
+
+
+
+
+
+
More information about the Bknr-cvs
mailing list