[bknr-cvs] r2225 - in branches/trunk-reorg/thirdparty: . kmrcl-1.97

6 Oct 2007

Author: hhubner
Date: 2007-10-06 17:39:22 -0400 (Sat, 06 Oct 2007)
New Revision: 2225
Added:
   branches/trunk-reorg/thirdparty/kmrcl-1.97/
   branches/trunk-reorg/thirdparty/kmrcl-1.97/ChangeLog
   branches/trunk-reorg/thirdparty/kmrcl-1.97/LICENSE
   branches/trunk-reorg/thirdparty/kmrcl-1.97/Makefile
   branches/trunk-reorg/thirdparty/kmrcl-1.97/README
   branches/trunk-reorg/thirdparty/kmrcl-1.97/attrib-class.lisp
   branches/trunk-reorg/thirdparty/kmrcl-1.97/buff-input.lisp
   branches/trunk-reorg/thirdparty/kmrcl-1.97/byte-stream.lisp
   branches/trunk-reorg/thirdparty/kmrcl-1.97/color.lisp
   branches/trunk-reorg/thirdparty/kmrcl-1.97/console.lisp
   branches/trunk-reorg/thirdparty/kmrcl-1.97/datetime.lisp
   branches/trunk-reorg/thirdparty/kmrcl-1.97/docbook.lisp
   branches/trunk-reorg/thirdparty/kmrcl-1.97/equal.lisp
   branches/trunk-reorg/thirdparty/kmrcl-1.97/functions.lisp
   branches/trunk-reorg/thirdparty/kmrcl-1.97/ifstar.lisp
   branches/trunk-reorg/thirdparty/kmrcl-1.97/impl.lisp
   branches/trunk-reorg/thirdparty/kmrcl-1.97/io.lisp
   branches/trunk-reorg/thirdparty/kmrcl-1.97/kmrcl-tests.asd
   branches/trunk-reorg/thirdparty/kmrcl-1.97/kmrcl.asd
   branches/trunk-reorg/thirdparty/kmrcl-1.97/listener.lisp
   branches/trunk-reorg/thirdparty/kmrcl-1.97/lists.lisp
   branches/trunk-reorg/thirdparty/kmrcl-1.97/macros.lisp
   branches/trunk-reorg/thirdparty/kmrcl-1.97/math.lisp
   branches/trunk-reorg/thirdparty/kmrcl-1.97/mop.lisp
   branches/trunk-reorg/thirdparty/kmrcl-1.97/os.lisp
   branches/trunk-reorg/thirdparty/kmrcl-1.97/package.lisp
   branches/trunk-reorg/thirdparty/kmrcl-1.97/processes.lisp
   branches/trunk-reorg/thirdparty/kmrcl-1.97/random.lisp
   branches/trunk-reorg/thirdparty/kmrcl-1.97/repl.lisp
   branches/trunk-reorg/thirdparty/kmrcl-1.97/run-tests.lisp
   branches/trunk-reorg/thirdparty/kmrcl-1.97/seqs.lisp
   branches/trunk-reorg/thirdparty/kmrcl-1.97/signals.lisp
   branches/trunk-reorg/thirdparty/kmrcl-1.97/sockets.lisp
   branches/trunk-reorg/thirdparty/kmrcl-1.97/strings.lisp
   branches/trunk-reorg/thirdparty/kmrcl-1.97/strmatch.lisp
   branches/trunk-reorg/thirdparty/kmrcl-1.97/symbols.lisp
   branches/trunk-reorg/thirdparty/kmrcl-1.97/tests.lisp
   branches/trunk-reorg/thirdparty/kmrcl-1.97/web-utils.lisp
   branches/trunk-reorg/thirdparty/kmrcl-1.97/xml-utils.lisp
Removed:
   branches/trunk-reorg/thirdparty/kmrcl-1.72/
Log:
bring kmrcl up to date
Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/ChangeLog
===================================================================

--- branches/trunk-reorg/thirdparty/kmrcl-1.97/ChangeLog	2007-10-06 21:23:47 UTC (rev 2224)
+++ branches/trunk-reorg/thirdparty/kmrcl-1.97/ChangeLog	2007-10-06 21:39:22 UTC (rev 2225)
@@ -0,0 +1,53 @@
+18 Sep 2007  Kevin Rosenberg kevin@rosenberg.net
+	* Version 1.97
+	* datetime.lisp: Improve output format for date-string
+
+10 Sep 2007  Kevin Rosenberg kevin@rosenberg.net
+	* Version 1.96
+	* byte-stream.lisp: Use without-package-locks as suggested
+	by Daniel Gackle.	
+
+01 Jun 2007  Kevin Rosenberg kevin@rosenberg.net
+	* Version 1.95
+	* {datetime,package}.lisp: Add day-of-week and pretty-date-ut
+
+07 Jan 2007  Kevin Rosenberg kevin@rosenberg.net
+	* Version 1.94
+	* signals.lisp: Conditionalize Lispworks support to :unix *features*
+
+07 Jan 2007  Kevin Rosenberg kevin@rosenberg.net
+	* Version 1.93
+	* signals.lisp: Add new file for signal processing
+	
+31 Dec 2006  Kevin Rosenberg kevin@rosenberg.net
+	* impl.lisp, sockets.lisp, equal.lisp, datetime.lisp: Declare ignored variables
+	
+29 Nov 2006  Kevin Rosenberg kevin@rosenberg.net
+	* Version 1.92
+	* strings.lisp: Add uri-query-to-alist
+
+24 Oct 2006  Kevin Rosenberg kevin@rosenberg.net
+	* Version 1.91
+	* io.lisp: Fix output from read-file-to-string
+
+22 Sep 2006  Kevin Rosenberg kevin@rosenberg.net
+	* Version 1.90
+	* sockets.lisp: Commit patch from Joerg Hoehle for CLISP sockets
+
+04 Sep 2006  Kevin Rosenberg kevin@rosenberg.net
+	* Version 1.89
+	* kmrcl.asd, mop.lisp: Add support for CLISP MOP
+	* strings.lisp: Add prefixed-number-string macro with type optimization used
+	by prefixed-fixnum-string and prefixed-integer-string
+	* package.lisp: export prefixed-integer-string
+
+27 Jul 2006  Kevin Rosenberg kevin@rosenberg.net
+	* Version 1.88
+	* strings.lisp, package.lisp: Add binary-sequence-to-hex-string
+
+26 Jul 2006  Kevin Rosenberg kevin@rosenberg.net
+	* Version 1.87
+	* proceeses.lisp, sockets.lisp: Apply patch from Travis Cross
+	for SBCL, posted on
+	http://common-lisp.net/pipermail/tbnl-devel/2005-December/000524.html
+
Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/LICENSE
===================================================================
--- branches/trunk-reorg/thirdparty/kmrcl-1.97/LICENSE	2007-10-06 21:23:47 UTC (rev 2224)
+++ branches/trunk-reorg/thirdparty/kmrcl-1.97/LICENSE	2007-10-06 21:39:22 UTC (rev 2225)
@@ -0,0 +1,78 @@
+Copyright (C) 2000-2006 by Kevin M. Rosenberg.
+
+This code is free software; you can redistribute it and/or modify it
+under the terms of the version 2.1 of the GNU Lesser General Public
+License as published by the Free Software Foundation, as clarified by
+the Franz preamble to the LGPL found in
+http://opensource.franz.com/preamble.html. The preambled is copied below.
+
+This code is distributed in the hope that it will be useful,
+but without any warranty; without even the implied warranty of
+merchantability or fitness for a particular purpose.  See the GNU
+Lesser General Public License for more details.
+
+The GNU Lessor General Public License can be found in your Debian file
+system in /usr/share/common-licenses/LGPL.
+
+Preamble to the Gnu Lesser General Public License
+-------------------------------------------------
+Copyright (c) 2000 Franz Incorporated, Berkeley, CA 94704
+
+The concept of the GNU Lesser General Public License version 2.1
+("LGPL") has been adopted to govern the use and distribution of
+above-mentioned application. However, the LGPL uses terminology that
+is more appropriate for a program written in C than one written in
+Lisp. Nevertheless, the LGPL can still be applied to a Lisp program if
+certain clarifications are made. This document details those
+clarifications. Accordingly, the license for the open-source Lisp
+applications consists of this document plus the LGPL. Wherever there
+is a conflict between this document and the LGPL, this document takes
+precedence over the LGPL.
+
+A "Library" in Lisp is a collection of Lisp functions, data and
+foreign modules. The form of the Library can be Lisp source code (for
+processing by an interpreter) or object code (usually the result of
+compilation of source code or built with some other
+mechanisms). Foreign modules are object code in a form that can be
+linked into a Lisp executable. When we speak of functions we do so in
+the most general way to include, in addition, methods and unnamed
+functions. Lisp "data" is also a general term that includes the data
+structures resulting from defining Lisp classes. A Lisp application
+may include the same set of Lisp objects as does a Library, but this
+does not mean that the application is necessarily a "work based on the
+Library" it contains.
+
+The Library consists of everything in the distribution file set before
+any modifications are made to the files. If any of the functions or
+classes in the Library are redefined in other files, then those
+redefinitions ARE considered a work based on the Library. If
+additional methods are added to generic functions in the Library,
+those additional methods are NOT considered a work based on the
+Library. If Library classes are subclassed, these subclasses are NOT
+considered a work based on the Library. If the Library is modified to
+explicitly call other functions that are neither part of Lisp itself
+nor an available add-on module to Lisp, then the functions called by
+the modified Library ARE considered a work based on the Library. The
+goal is to ensure that the Library will compile and run without
+getting undefined function errors.
+
+It is permitted to add proprietary source code to the Library, but it
+must be done in a way such that the Library will still run without
+that proprietary code present. Section 5 of the LGPL distinguishes
+between the case of a library being dynamically linked at runtime and
+one being statically linked at build time. Section 5 of the LGPL
+states that the former results in an executable that is a "work that
+uses the Library." Section 5 of the LGPL states that the latter
+results in one that is a "derivative of the Library", which is
+therefore covered by the LGPL. Since Lisp only offers one choice,
+which is to link the Library into an executable at build time, we
+declare that, for the purpose applying the LGPL to the Library, an
+executable that results from linking a "work that uses the Library"
+with the Library is considered a "work that uses the Library" and is
+therefore NOT covered by the LGPL.
+
+Because of this declaration, section 6 of LGPL is not applicable to
+the Library. However, in connection with each distribution of this
+executable, you must also deliver, in accordance with the terms and
+conditions of the LGPL, the source code of Library (or your derivative
+thereof) that is incorporated into this executable.
Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/Makefile
===================================================================
--- branches/trunk-reorg/thirdparty/kmrcl-1.97/Makefile	2007-10-06 21:23:47 UTC (rev 2224)
+++ branches/trunk-reorg/thirdparty/kmrcl-1.97/Makefile	2007-10-06 21:39:22 UTC (rev 2225)
@@ -0,0 +1,32 @@
+.PHONY: all clean test test-acl test-sbcl
+
+test-file:=`pwd`/run-tests.lisp
+all:
+
+clean:
+	@find . -type f -name "*.fasl*" -or -name "*.ufsl" -or -name "*.x86f" \
+	  -or -name "*.fas" -or -name "*.pfsl" -or -name "*.dfsl" \
+	  -or -name "*~" -or -name ".#*" -or -name "#*#" | xargs rm -f
+
+test: test-alisp
+
+test-alisp:
+	alisp8 -q -L $(test-file)
+
+test-mlisp:
+	mlisp -q -L $(test-file)
+
+test-sbcl:
+	sbcl --noinform --disable-debugger --userinit $(test-file)
+
+test-cmucl:
+	lisp -init $(test-file)
+
+test-lw:
+	lw-console -init $(test-file)
+
+test-scl: 
+	scl -init $(test-file)
+
+test-clisp: 
+	clisp -norc -q -i $(test-file)
Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/README
===================================================================
--- branches/trunk-reorg/thirdparty/kmrcl-1.97/README	2007-10-06 21:23:47 UTC (rev 2224)
+++ branches/trunk-reorg/thirdparty/kmrcl-1.97/README	2007-10-06 21:39:22 UTC (rev 2225)
@@ -0,0 +1,6 @@
+KMRCL is a collection of utility functions. It is used as a base for
+some of Kevin M. Rosenberg's Common Lisp packages.
+
+The web site for KMRCL is http://files.b9.com/kmrcl/
+
+
Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/attrib-class.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/kmrcl-1.97/attrib-class.lisp	2007-10-06 21:23:47 UTC (rev 2224)
+++ branches/trunk-reorg/thirdparty/kmrcl-1.97/attrib-class.lisp	2007-10-06 21:39:22 UTC (rev 2225)
@@ -0,0 +1,106 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: kmrcl-*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          attrib-class.lisp
+;;;; Purpose:       Defines metaclass allowing use of attributes on slots
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Apr 2000
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of KMRCL, is Copyright (c) 2002-2003 by Kevin M. Rosenberg
+;;;;
+;;;; KMRCL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+;; Disable attrib class until understand changes in sbcl/cmucl
+;; using COMPUTE-SLOT-ACCESSOR-INFO and defining method
+;; for slot access of ALL-ATTRIBUTES. Does this work on Allegro/LW?
+
+;;;; Defines a metaclass that allows the use of attributes (or subslots)
+;;;; on slots. Based on example in AMOP, but modified to use ACL's MOP.
+
+(in-package #:kmrcl)
+
+(defclass attributes-class (kmr-mop:standard-class)
+  ()
+  (:documentation "metaclass that implements attributes on slots. Based
+on example from AMOP"))
+
+(defclass attributes-dsd (kmr-mop:standard-direct-slot-definition)
+  ((attributes :initarg :attributes :initform nil
+               :accessor dsd-attributes)))
+
+(defclass attributes-esd (kmr-mop:standard-effective-slot-definition)
+  ((attributes :initarg :attributes :initform nil
+               :accessor esd-attributes)))
+
+;; encapsulating macro for Lispworks
+(kmr-mop:process-slot-option attributes-class :attributes)
+
+#+(or cmu scl sbcl openmcl)
+(defmethod kmr-mop:validate-superclass ((class attributes-class)
+                                        (superclass kmr-mop:standard-class))
+  t)
+
+(defmethod kmr-mop:direct-slot-definition-class ((cl attributes-class) #+kmr-normal-dsdc &rest initargs)
+  (declare (ignore initargs))
+  (kmr-mop:find-class 'attributes-dsd))
+
+(defmethod kmr-mop:effective-slot-definition-class ((cl attributes-class) #+kmr-normal-dsdc &rest initargs)
+  (declare (ignore initargs))
+  (kmr-mop:find-class 'attributes-esd))
+
+(defmethod kmr-mop:compute-effective-slot-definition
+    ((cl attributes-class) #+kmr-normal-cesd name dsds)
+  #+kmr-normal-cesd (declare (ignore name))
+  (let ((esd (call-next-method)))
+    (setf (esd-attributes esd) (remove-duplicates (mapappend #'dsd-attributes dsds)))
+    esd))
+
+;; This does not work in Lispworks prior to version 4.3
+
+(defmethod kmr-mop:compute-slots ((class attributes-class))
+  (let* ((normal-slots (call-next-method))
+         (alist (mapcar
+                 #'(lambda (slot)
+                     (cons (kmr-mop:slot-definition-name slot)
+                           (mapcar #'(lambda (attr) (list attr))
+                                   (esd-attributes slot))))
+                 normal-slots)))
+
+    (cons (make-instance
+           'attributes-esd
+           :name 'all-attributes
+           :initform `',alist
+           :initfunction #'(lambda () alist)
+           :allocation :instance
+           :documentation "Attribute bucket"
+           :type t
+           )
+          normal-slots)))
+
+(defun slot-attribute (instance slot-name attribute)
+  (cdr (slot-attribute-bucket instance slot-name attribute)))
+
+(defun (setf slot-attribute) (new-value instance slot-name attribute)
+  (setf (cdr (slot-attribute-bucket instance slot-name attribute))
+    new-value))
+
+(defun slot-attribute-bucket (instance slot-name attribute)
+  (let* ((all-buckets (slot-value instance 'all-attributes))
+         (slot-bucket (assoc slot-name all-buckets)))
+    (unless slot-bucket
+      (error "The slot named ~S of ~S has no attributes."
+             slot-name instance))
+    (let ((attr-bucket (assoc attribute (cdr slot-bucket))))
+      (unless attr-bucket
+        (error "The slot named ~S of ~S has no attributes named ~S."
+               slot-name instance attribute))
+      attr-bucket)))
+
+
+
Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/buff-input.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/kmrcl-1.97/buff-input.lisp	2007-10-06 21:23:47 UTC (rev 2224)
+++ branches/trunk-reorg/thirdparty/kmrcl-1.97/buff-input.lisp	2007-10-06 21:39:22 UTC (rev 2225)
@@ -0,0 +1,182 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          buff-input.lisp
+;;;; Purpose:       Buffered line input
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Apr 2000
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; KMRCL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(in-package :kmrcl)
+
+(eval-when (:compile-toplevel)
+  (declaim (optimize (speed 3) (safety 0) (space 0) (debug 0))))
+
+(defconstant +max-field+ 10000)
+(defconstant +max-fields-per-line+ 20)
+(defconstant +field-delim+ #|)
+(defconstant +eof-char+ #\rubout)
+(defconstant +newline+ #\Newline)
+
+(declaim (type character +eof-char+ +field-delim+ +newline+)
+         (type fixnum +max-field+ +max-fields-per-line+))
+
+;; Buffered fields parsing function
+;; Uses fill-pointer for size
+
+(defun make-fields-buffer (&optional (max-fields +max-fields-per-line+)
+                                   (max-field-len +max-field+))
+  (let ((bufs (make-array max-fields :element-type 'vector :fill-pointer 0 :adjustable nil)))
+    (dotimes (i +max-fields-per-line+)
+      (setf (aref bufs i) (make-array max-field-len :element-type 'character :fill-pointer 0 :adjustable nil)))
+    bufs))
+
+(defun read-buffered-fields (fields strm &optional (field-delim +field-delim+)
+                             (eof 'eof))
+  "Read a line from a stream into a field buffers"
+  (declare (type base-char field-delim)
+           (type vector fields))
+  (setf (fill-pointer fields) 0)
+  (do ((ifield 0 (1+ ifield))
+       (linedone nil)
+       (is-eof nil))
+      (linedone (if is-eof eof fields))
+    (declare (type fixnum ifield)
+             (type boolean linedone is-eof))
+    (let ((field (aref fields ifield)))
+      (declare (type base-string field))
+      (do ((ipos 0)
+           (fielddone nil)
+           (rc (read-char strm nil +eof-char+)
+              (read-char strm nil +eof-char+)))
+          (fielddone (unread-char rc strm))
+        (declare (type fixnum ipos)
+                 (type base-char rc)
+                 (type boolean fielddone))
+        (cond
+         ((char= rc field-delim)
+          (setf (fill-pointer field) ipos)
+          (setq fielddone t))
+         ((char= rc +newline+)
+          (setf (fill-pointer field) ipos)
+          (setf (fill-pointer fields) ifield)
+          (setq fielddone t)
+          (setq linedone t))
+         ((char= rc +eof-char+)
+          (setf (fill-pointer field) ipos)
+          (setf (fill-pointer fields) ifield)
+          (setq fielddone t)
+          (setq linedone t)
+          (setq is-eof t))
+         (t
+          (setf (char field ipos) rc)
+          (incf ipos)))))))
+
+;; Buffered fields parsing
+;; Does not use fill-pointer
+;; Returns 2 values -- string array and length array
+(defstruct field-buffers
+  (nfields 0 :type fixnum)
+  (buffers)
+  (field-lengths))
+
+(defun make-fields-buffer2 (&optional (max-fields +max-fields-per-line+)
+                                   (max-field-len +max-field+))
+  (let ((bufs (make-array max-fields :element-type 'vector :fill-pointer nil :adjustable nil))
+        (bufstruct (make-field-buffers)))
+    (dotimes (i +max-fields-per-line+)
+      (setf (aref bufs i) (make-array max-field-len :element-type 'character :fill-pointer nil :adjustable nil)))
+    (setf (field-buffers-buffers bufstruct) bufs)
+    (setf (field-buffers-field-lengths bufstruct) (make-array +max-fields-per-line+
+                                                              :element-type 'fixnum :fill-pointer nil :adjustable nil))
+    (setf (field-buffers-nfields bufstruct) 0)
+    bufstruct))
+
+
+(defun read-buffered-fields2 (fields strm &optional (field-delim +field-delim+)
+                              (eof 'eof))
+  "Read a line from a stream into a field buffers"
+  (declare (character field-delim))
+  (setf (field-buffers-nfields fields) 0)
+  (do ((ifield 0 (1+ ifield))
+       (linedone nil)
+       (is-eof nil))
+      (linedone (if is-eof eof fields))
+    (declare (fixnum ifield)
+             (t linedone is-eof))
+    (let ((field (aref (field-buffers-buffers fields) ifield)))
+      (declare (simple-string field))
+      (do ((ipos 0)
+           (fielddone nil)
+           (rc (read-char strm nil +eof-char+)
+              (read-char strm nil +eof-char+)))
+          (fielddone (unread-char rc strm))
+        (declare (fixnum ipos)
+                 (character rc)
+                 (t fielddone))
+        (cond
+         ((char= rc field-delim)
+          (setf (aref (field-buffers-field-lengths fields) ifield) ipos)
+          (setq fielddone t))
+         ((char= rc +newline+)
+          (setf (aref (field-buffers-field-lengths fields) ifield) ipos)
+          (setf (field-buffers-nfields fields) ifield)
+          (setq fielddone t)
+          (setq linedone t))
+         ((char= rc +eof-char+)
+          (setf (aref (field-buffers-field-lengths fields) ifield) ipos)
+          (setf (field-buffers-nfields fields) ifield)
+          (setq fielddone t)
+          (setq linedone t)
+          (setq is-eof t))
+         (t
+          (setf (char field ipos) rc)
+          (incf ipos)))))))
+
+(defun bfield (fields i)
+  (if (>= i (field-buffers-nfields fields))
+      nil
+    (subseq (aref (field-buffers-buffers fields) i) 0 (aref (field-buffers-field-lengths fields) i))))
+
+;;; Buffered line parsing function
+
+(defconstant +max-line+ 20000)
+(let ((linebuffer (make-array +max-line+
+                              :element-type 'character
+                              :fill-pointer 0)))
+  (defun read-buffered-line (strm eof)
+    "Read a line from astream into a vector buffer"
+    (declare (optimize (speed 3) (space 0) (safety 0)))
+    (let ((pos 0)
+          (done nil))
+      (declare (fixnum pos) (type boolean done))
+      (setf (fill-pointer linebuffer) 0)
+      (do ((c (read-char strm nil +eof-char+)
+              (read-char strm nil +eof-char+)))
+          (done (progn
+                  (unless (eql c +eof-char+) (unread-char c strm))
+                  (if (eql c +eof-char+) eof linebuffer)))
+        (declare (character c))
+        (cond
+         ((>= pos +max-line+)
+          (warn "Line overflow")
+          (setf done t))
+         ((char= c #\Newline)
+          (when (plusp pos)
+            (setf (fill-pointer linebuffer) (1- pos)))
+          (setf done t))
+         ((char= +eof-char+)
+          (setf done t))
+         (t
+          (setf (char linebuffer pos) c)
+          (incf pos)))))))
+
Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/byte-stream.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/kmrcl-1.97/byte-stream.lisp	2007-10-06 21:23:47 UTC (rev 2224)
+++ branches/trunk-reorg/thirdparty/kmrcl-1.97/byte-stream.lisp	2007-10-06 21:39:22 UTC (rev 2225)
@@ -0,0 +1,270 @@
+;;; -*- Syntax: Ansi-Common-Lisp; Base: 10; Mode: lisp; Package: kmrcl -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          byte-stream.lisp
+;;;; Purpose:       Byte array input/output streams
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  June 2003
+;;;;
+;;;; $Id$
+;;;;
+;;;; Works for CMUCL, SBCL, and AllergoCL only
+;;;;
+;;;; This file, part of KMRCL, is Copyright (c) 2003 by Kevin M. Rosenberg
+;;;; and by onShore Development, Inc.
+;;;;
+;;;; KMRCL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(in-package #:kmrcl)
+
+;; Intial CMUCL version by OnShored. Ported to SBCL by Kevin Rosenberg
+
+#+sbcl
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (when (sb-ext:without-package-locks
+            (sb-pcl::structure-class-p
+             (find-class (intern "FILE-STREAM" "SB-IMPL"))))
+    (push :old-sb-file-stream cl:*features*)))
+
+#+(or cmu sbcl)
+(progn
+(defstruct (byte-array-output-stream
+             (:include #+cmu system:lisp-stream
+                       #+(and sbcl old-sb-file-stream) sb-impl::file-stream
+                       #+(and sbcl (not old-sb-file-stream)) sb-sys:fd-stream
+                       (bout #'byte-array-bout)
+                       (misc #'byte-array-out-misc))
+             (:print-function %print-byte-array-output-stream)
+             (:constructor make-byte-array-output-stream ()))
+  ;; The buffer we throw stuff in.
+  (buffer (make-array 128 :element-type '(unsigned-byte 8)))
+  ;; Index of the next location to use.
+  (index 0 :type fixnum))
+
+(defun %print-byte-array-output-stream (s stream d)
+  (declare (ignore s d))
+  (write-string "#<Byte-Array-Output Stream>" stream))
+
+(setf (documentation 'make-binary-output-stream 'function)
+  "Returns an Output stream which will accumulate all output given it for
+   the benefit of the function Get-Output-Stream-Data.")
+
+(defun byte-array-bout (stream byte)
+  (let ((current (byte-array-output-stream-index stream))
+        (workspace (byte-array-output-stream-buffer stream)))
+    (if (= current (length workspace))
+        (let ((new-workspace (make-array (* current 2) :element-type '(unsigned-byte 8))))
+          (replace new-workspace workspace)
+          (setf (aref new-workspace current) byte)
+          (setf (byte-array-output-stream-buffer stream) new-workspace))
+        (setf (aref workspace current) byte))
+    (setf (byte-array-output-stream-index stream) (1+ current))))
+
+(defun byte-array-out-misc (stream operation &optional arg1 arg2)
+  (declare (ignore arg2))
+  (case operation
+    (:file-position
+     (if (null arg1)
+         (byte-array-output-stream-index stream)))
+    (:element-type '(unsigned-byte 8))))
+
+(defun get-output-stream-data (stream)
+  "Returns an array of all data sent to a stream made by
+Make-Byte-Array-Output-Stream since the last call to this function and
+clears buffer."
+  (declare (type byte-array-output-stream stream))
+    (prog1
+        (dump-output-stream-data stream)
+      (setf (byte-array-output-stream-index stream) 0)))
+
+(defun dump-output-stream-data (stream)
+  "Returns an array of all data sent to a stream made by
+Make-Byte-Array-Output-Stream since the last call to this function."
+  (declare (type byte-array-output-stream stream))
+  (let* ((length (byte-array-output-stream-index stream))
+         (result (make-array length :element-type '(unsigned-byte 8))))
+    (replace result (byte-array-output-stream-buffer stream))
+    result))
+
+) ; progn
+
+
+#+sbcl
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (sb-ext:without-package-locks
+      (defvar *system-copy-fn* (if (fboundp (intern "COPY-SYSTEM-AREA" "SB-KERNEL"))
+                                   (intern "COPY-SYSTEM-AREA" "SB-KERNEL")
+                                   (intern "COPY-SYSTEM-UB8-AREA" "SB-KERNEL")))
+    (defconstant +system-copy-multiplier+ (if (fboundp (intern "COPY-FROM-SYSTEM-AREA" "SB-KERNEL"))
+                                              sb-vm:n-byte-bits
+                                         1))))
+
+#+(or cmu sbcl)
+(progn
+  (defstruct (byte-array-input-stream
+             (:include #+cmu system:lisp-stream
+                       ;;#+sbcl sb-impl::file-stream
+                       #+(and sbcl old-sb-file-stream) sb-impl::file-stream
+                       #+(and sbcl (not old-sb-file-stream)) sb-sys:fd-stream
+                       (in #'byte-array-inch)
+                       (bin #'byte-array-binch)
+                       (n-bin #'byte-array-stream-read-n-bytes)
+                       (misc #'byte-array-in-misc))
+             (:print-function %print-byte-array-input-stream)
+                                        ;(:constructor nil)
+             (:constructor internal-make-byte-array-input-stream
+                           (byte-array current end)))
+  (byte-array nil :type vector)
+  (current nil)
+  (end nil))
+
+
+(defun %print-byte-array-input-stream (s stream d)
+  (declare (ignore s d))
+  (write-string "#<Byte-Array-Input Stream>" stream))
+
+(defun byte-array-inch (stream eof-errorp eof-value)
+  (let ((byte-array (byte-array-input-stream-byte-array stream))
+        (index (byte-array-input-stream-current stream)))
+    (cond ((= index (byte-array-input-stream-end stream))
+           #+cmu
+           (eof-or-lose stream eof-errorp eof-value)
+           #+sbcl
+           (sb-impl::eof-or-lose stream eof-errorp eof-value)
+           )
+          (t
+           (setf (byte-array-input-stream-current stream) (1+ index))
+           (aref byte-array index)))))
+
+(defun byte-array-binch (stream eof-errorp eof-value)
+  (let ((byte-array (byte-array-input-stream-byte-array stream))
+        (index (byte-array-input-stream-current stream)))
+    (cond ((= index (byte-array-input-stream-end stream))
+           #+cmu
+           (eof-or-lose stream eof-errorp eof-value)
+           #+sbcl
+           (sb-impl::eof-or-lose stream eof-errorp eof-value)
+           )
+          (t
+           (setf (byte-array-input-stream-current stream) (1+ index))
+           (aref byte-array index)))))
+
+(defun byte-array-stream-read-n-bytes (stream buffer start requested eof-errorp)
+  (declare (type byte-array-input-stream stream))
+  (let* ((byte-array (byte-array-input-stream-byte-array stream))
+         (index (byte-array-input-stream-current stream))
+         (available (- (byte-array-input-stream-end stream) index))
+         (copy (min available requested)))
+    (when (plusp copy)
+      (setf (byte-array-input-stream-current stream)
+        (+ index copy))
+      #+cmu
+      (system:without-gcing
+       (system::system-area-copy (system:vector-sap byte-array)
+                         (* index vm:byte-bits)
+                         (if (typep buffer 'system::system-area-pointer)
+                             buffer
+                             (system:vector-sap buffer))
+                         (* start vm:byte-bits)
+                         (* copy vm:byte-bits)))
+      #+sbcl
+      (sb-sys:without-gcing
+       (funcall *system-copy-fn* (sb-sys:vector-sap byte-array)
+                         (* index +system-copy-multiplier+)
+                         (if (typep buffer 'sb-sys::system-area-pointer)
+                             buffer
+                             (sb-sys:vector-sap buffer))
+                         (* start +system-copy-multiplier+)
+                         (* copy +system-copy-multiplier+))))
+    (if (and (> requested copy) eof-errorp)
+        (error 'end-of-file :stream stream)
+        copy)))
+
+(defun byte-array-in-misc (stream operation &optional arg1 arg2)
+  (declare (ignore arg2))
+  (case operation
+    (:file-position
+     (if arg1
+         (setf (byte-array-input-stream-current stream) arg1)
+         (byte-array-input-stream-current stream)))
+    (:file-length (length (byte-array-input-stream-byte-array stream)))
+    (:unread (decf (byte-array-input-stream-current stream)))
+    (:listen (or (/= (the fixnum (byte-array-input-stream-current stream))
+                     (the fixnum (byte-array-input-stream-end stream)))
+                 :eof))
+    (:element-type 'base-char)))
+
+(defun make-byte-array-input-stream (buffer &optional (start 0) (end (length buffer)))
+  "Returns an input stream which will supply the bytes of BUFFER between
+  Start and End in order."
+  (internal-make-byte-array-input-stream buffer start end))
+
+) ;; progn
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (setq cl:*features* (delete :old-sb-file-stream cl:*features*)))
+
+;;; Simple streams implementation by Kevin Rosenberg
+
+#+allegro
+(progn
+
+  (defclass extendable-buffer-output-stream (excl:buffer-output-simple-stream)
+    ()
+    )
+
+  (defun make-byte-array-output-stream ()
+    "Returns an Output stream which will accumulate all output given it for
+   the benefit of the function Get-Output-Stream-Data."
+    (make-instance 'extendable-buffer-output-stream
+      :buffer (make-array 128 :element-type '(unsigned-byte 8))
+      :external-form :octets))
+
+  (defun get-output-stream-data (stream)
+    "Returns an array of all data sent to a stream made by
+Make-Byte-Array-Output-Stream since the last call to this function
+and clears buffer."
+    (prog1
+        (dump-output-stream-data stream)
+      (file-position stream 0)))
+
+  (defun dump-output-stream-data (stream)
+    "Returns an array of all data sent to a stream made by
+Make-Byte-Array-Output-Stream since the last call to this function."
+    (force-output stream)
+    (let* ((length (file-position stream))
+           (result (make-array length :element-type '(unsigned-byte 8))))
+      (replace result (slot-value stream 'excl::buffer))
+      result))
+
+  (excl::without-package-locks
+   (defmethod excl:device-extend ((stream extendable-buffer-output-stream)
+                                  need action)
+     (declare (ignore action))
+     (let* ((len (file-position stream))
+            (new-len (max (+ len need) (* 2 len)))
+            (old-buf (slot-value stream 'excl::buffer))
+            (new-buf (make-array new-len :element-type '(unsigned-byte 8))))
+       (declare (fixnum len)
+                (optimize (speed 3) (safety 0)))
+       (dotimes (i len)
+         (setf (aref new-buf i) (aref old-buf i)))
+       (setf (slot-value stream 'excl::buffer) new-buf)
+       (setf (slot-value stream 'excl::buffer-ptr) new-len)
+       )
+     t))
+
+)
+
+#+allegro
+(progn
+  (defun make-byte-array-input-stream (buffer &optional (start 0)
+                                                        (end (length buffer)))
+    (excl:make-buffer-input-stream buffer start end :octets))
+  ) ;; progn
+
+
Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/color.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/kmrcl-1.97/color.lisp	2007-10-06 21:23:47 UTC (rev 2224)
+++ branches/trunk-reorg/thirdparty/kmrcl-1.97/color.lisp	2007-10-06 21:39:22 UTC (rev 2225)
@@ -0,0 +1,315 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: kmrcl -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          color.lisp
+;;;; Purpose:       Functions for color
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Oct 2003
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of KMRCL, is Copyright (c) 2002-2003 by Kevin M. Rosenberg
+;;;;
+;;;; KMRCL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(in-package #:kmrcl)
+
+;; The HSV colour space has three coordinates: hue, saturation, and
+;; value (sometimes called brighness) respectively. This colour system is
+;; attributed to "Smith" around 1978 and used to be called the hexcone
+;; colour model. The hue is an angle from 0 to 360 degrees, typically 0
+;; is red, 60 degrees yellow, 120 degrees green, 180 degrees cyan, 240
+;; degrees blue, and 300 degrees magenta. Saturation typically ranges
+;; from 0 to 1 (sometimes 0 to 100%) and defines how grey the colour is,
+;; 0 indicates grey and 1 is the pure primary colour. Value is similar to
+;; luninance except it also varies the colour saturation. If the colour
+;; space is represented by disks of varying lightness then the hue and
+;; saturation are the equivalent to polar coordinates (r,theta) of any
+;; point in the plane. The disks on the right show this for various
+;; values.
+
+(defun hsv->rgb (h s v)
+  (declare (optimize (speed 3) (safety 0)))
+  (when (zerop s)
+    (return-from hsv->rgb (values v v v)))
+
+  (while (minusp h)
+         (incf h 360))
+  (while (>= h 360)
+         (decf h 360))
+
+  (let ((h-pos (/ h 60)))
+    (multiple-value-bind (h-int h-frac) (truncate h-pos)
+      (declare (fixnum h-int))
+      (let ((p (* v (- 1 s)))
+            (q (* v (- 1 (* s h-frac))))
+            (t_ (* v (- 1 (* s (- 1 h-frac)))))
+            r g b)
+
+        (cond
+         ((zerop h-int)
+          (setf r v
+                g t_
+                b p))
+         ((= 1 h-int)
+          (setf r q
+                g v
+                b p))
+         ((= 2 h-int)
+          (setf r p
+                g v
+                b t_))
+         ((= 3 h-int)
+          (setf r p
+                g q
+                b v))
+         ((= 4 h-int)
+          (setf r t_
+                g p
+                b v))
+         ((= 5 h-int)
+          (setf r v
+                g p
+                b q)))
+        (values r g b)))))
+
+
+(defun hsv255->rgb255 (h s v)
+  (declare (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)))
+
+  (when (zerop s)
+    (return-from hsv255->rgb255 (values v v v)))
+
+  (locally (declare (type fixnum h s v))
+    (while (minusp h)
+      (incf h 360))
+    (while (>= h 360)
+      (decf h 360))
+
+    (let ((h-pos (/ h 60)))
+      (multiple-value-bind (h-int h-frac) (truncate h-pos)
+        (declare (fixnum h-int))
+        (let* ((fs (/ s 255))
+               (fv (/ v 255))
+               (p (round (* 255 fv (- 1 fs))))
+               (q (round (* 255 fv (- 1 (* fs h-frac)))))
+               (t_ (round (* 255 fv (- 1 (* fs (- 1 h-frac))))))
+               r g b)
+
+          (cond
+           ((zerop h-int)
+            (setf r v
+                  g t_
+                  b p))
+           ((= 1 h-int)
+            (setf r q
+                  g v
+                  b p))
+           ((= 2 h-int)
+            (setf r p
+                  g v
+                  b t_))
+           ((= 3 h-int)
+            (setf r p
+                  g q
+                  b v))
+           ((= 4 h-int)
+            (setf r t_
+                  g p
+                  b v))
+           ((= 5 h-int)
+            (setf r v
+                  g p
+                  b q)))
+          (values r g b))))))
+
+
+
+(defun rgb->hsv (r g b)
+  (declare (optimize (speed 3) (safety 0)))
+
+  (let* ((min (min r g b))
+         (max (max r g b))
+         (delta (- max min))
+         (v max)
+         (s 0)
+         (h nil))
+
+    (when (plusp max)
+      (setq s (/ delta max)))
+
+    (when (plusp delta)
+      (setq h (cond
+               ((= max r)
+                (nth-value 0 (/ (- g b) delta)))
+               ((= max g)
+                (nth-value 0 (+ 2 (/ (- b r) delta))))
+               (t
+                (nth-value 0 (+ 4 (/ (- r g) delta))))))
+      (setq h (the fixnum (* 60 h)))
+      (when (minusp h)
+        (incf h 360)))
+
+    (values h s v)))
+
+(defun rgb255->hsv255 (r g b)
+  "Integer convert from rgb from 0-255 -> h from 0-360 and sv from 0-255"
+  (declare (fixnum r g b)
+           (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)))
+
+  (let* ((min (min r g b))
+         (max (max r g b))
+         (delta (- max min))
+         (v max)
+         (s 0)
+         (h nil))
+    (declare (fixnum min max delta v s)
+             (type (or null fixnum) h))
+
+    (when (plusp max)
+      (setq s (truncate (the fixnum (* 255 delta)) max)))
+
+    (when (plusp delta)
+      (setq h (cond
+               ((= max r)
+                (truncate (the fixnum (* 60 (the fixnum (- g b)))) delta))
+               ((= max g)
+                (the fixnum
+                     (+ 120 (truncate (the fixnum (* 60 (the fixnum (- b r)))) delta))))
+               (t
+                (the fixnum
+                     (+ 240 (truncate (the fixnum (* 60 (the fixnum (- r g)))) delta))))))
+      (when (minusp h)
+        (incf h 360)))
+
+    (values h s v)))
+
+
+(defun hsv-equal (h1 s1 v1 h2 s2 v2 &key (limit .001))
+  (declare (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)))
+  (flet ((~= (a b)
+           (cond
+            ((and (null a) (null b))
+             t)
+            ((or (null a) (null b))
+             nil)
+            (t
+             (< (abs (- a b)) limit)))))
+    (cond
+     ((and (~= 0 v1) (~= 0 v2))
+      t)
+     ((or (null h1) (null h2))
+      (when (and (~= 0 s1) (~= 0 s2) (~= v1 v2))
+        t))
+     (t
+      (when (~= h1 h2) (~= s1 s2) (~= v1 v2)
+        t)))))
+
+(defun hsv255-equal (h1 s1 v1 h2 s2 v2 &key (limit 1))
+  (declare (type fixnum s1 v1 s2 v2 limit)
+           (type (or null fixnum) h1 h2)
+           (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)))
+  (flet ((~= (a b)
+           (declare (type (or null fixnum) a b))
+           (cond
+            ((and (null a) (null b))
+             t)
+            ((or (null a) (null b))
+             nil)
+            (t
+             (<= (abs (the fixnum (- a b))) limit)))))
+    (cond
+     ((and (~= 0 v1) (~= 0 v2))
+      t)
+     ((or (null h1) (null h2))
+      (when (and (~= 0 s1) (~= 0 s2) (~= v1 v2))
+        t))
+     (t
+      (when (~= h1 h2) (~= s1 s2) (~= v1 v2)
+        t)))))
+
+(defun hsv-similar (h1 s1 v1 h2 s2 v2 &key
+                       (hue-range 15) (value-range .2) (saturation-range 0.2)
+                       (gray-limit 0.3) (black-limit 0.3))
+  "Returns T if two HSV values are similar."
+  (cond
+   ;; all black colors are similar
+   ((and (<= v1 black-limit) (<= v2 black-limit))
+    t)
+   ;; all desaturated (gray) colors are similar for a value, despite hue
+   ((and (<= s1 gray-limit) (<= s2 gray-limit))
+    (when (<= (abs (- v1 v2)) value-range)
+      t))
+   (t
+    (when (and (<= (abs (hue-difference h1 h2)) hue-range)
+               (<= (abs (- v1 v2)) value-range)
+               (<= (abs (- s1 s2)) saturation-range))
+      t))))
+
+
+(defun hsv255-similar (h1 s1 v1 h2 s2 v2
+                          &key (hue-range 15) (value-range 50) (saturation-range 50)
+                          (gray-limit 75) (black-limit 75))
+  "Returns T if two HSV values are similar."
+  (declare (fixnum s1 v1 s2 v2 hue-range value-range saturation-range
+                   gray-limit black-limit)
+           (type (or null fixnum) h1 h2)
+           (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)))
+  (cond
+   ;; all black colors are similar
+   ((and (<= v1 black-limit) (<= v2 black-limit))
+    t)
+   ;; all desaturated (gray) colors are similar for a value, despite hue
+   ((and (<= s1 gray-limit) (<= s2 gray-limit))
+    (when (<= (abs (- v1 v2)) value-range)
+      t))
+   (t
+    (when (and (<= (abs (hue-difference-fixnum h1 h2)) hue-range)
+               (<= (abs (- v1 v2)) value-range)
+               (<= (abs (- s1 s2)) saturation-range))
+      t))))
+
+
+
+(defun hue-difference (h1 h2)
+  "Return difference between two hues around 360 degree circle"
+  (cond
+   ((and (null h1) (null h2))
+    t)
+   ((or (null h1) (null h2))
+    360)
+   (t
+    (let ((diff (- h2 h1)))
+      (cond
+       ((< diff -180)
+        (+ 360 diff)
+        )
+       ((> diff 180)
+        (- (- 360 diff)))
+       (t
+        diff))))))
+
+
+(defun hue-difference-fixnum (h1 h2)
+  "Return difference between two hues around 360 degree circle"
+  (cond
+   ((and (null h1) (null h2))
+    t)
+   ((or (null h1) (null h2))
+    360)
+   (t
+    (locally (declare (type fixnum h1 h2))
+      (let ((diff (- h2 h1)))
+        (cond
+         ((< diff -180)
+          (+ 360 diff)
+          )
+         ((> diff 180)
+          (- (- 360 diff)))
+         (t
+          diff)))))))
+
Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/console.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/kmrcl-1.97/console.lisp	2007-10-06 21:23:47 UTC (rev 2224)
+++ branches/trunk-reorg/thirdparty/kmrcl-1.97/console.lisp	2007-10-06 21:39:22 UTC (rev 2225)
@@ -0,0 +1,50 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          console.lisp
+;;;; Purpose:       Console interactiion
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Dec 2002
+;;;;
+;;;; $Id$
+;;;;a
+;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;; and by onShore Development, Inc.
+;;;;
+;;;; KMRCL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(in-package #:kmrcl)
+
+(defvar *console-msgs* t)
+
+(defvar *console-msgs-types* nil)
+
+(defun cmsg (template &rest args)
+  "Format output to console"
+  (when *console-msgs*
+    (setq template (concatenate 'string "~&;; " template "~%"))
+    (apply #'format t template args)))
+
+(defun cmsg-c (condition template &rest args)
+  "Push CONDITION keywords into *console-msgs-types* to print console msgs
+   for that CONDITION.  TEMPLATE and ARGS function identically to
+   (format t TEMPLATE ARGS) "
+  (when (or (member :verbose *console-msgs-types*)
+            (member condition *console-msgs-types*))
+    (apply #'cmsg template args)))
+
+(defun cmsg-add (condition)
+  (pushnew condition *console-msgs-types*))
+
+(defun cmsg-remove (condition)
+  (setf *console-msgs-types* (remove condition *console-msgs-types*)))
+
+(defun fixme (template &rest args)
+  "Format output to console"
+  (setq template (concatenate 'string "~&;; ** FIXME ** " template "~%"))
+  (apply #'format t template args)
+  (values))
Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/datetime.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/kmrcl-1.97/datetime.lisp	2007-10-06 21:23:47 UTC (rev 2224)
+++ branches/trunk-reorg/thirdparty/kmrcl-1.97/datetime.lisp	2007-10-06 21:39:22 UTC (rev 2225)
@@ -0,0 +1,157 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          datetime.lisp
+;;;; Purpose:       Date & Time functions for KMRCL package
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Apr 2000
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; KMRCL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(in-package #:kmrcl)
+
+
+;;; Formatting functions
+
+(defun pretty-date (year month day &optional (hour 12) (m 0) (s 0))
+  (multiple-value-bind (sec min hr dy mn yr wkday)
+    (decode-universal-time
+     (encode-universal-time s m hour day month year))
+    (values (elt '("Monday" "Tuesday" "Wednesday" "Thursday"
+                   "Friday" "Saturday" "Sunday")
+                 wkday)
+            (elt '("January" "February" "March" "April" "May" "June"
+                   "July" "August" "September" "October" "November"
+                   "December")
+                 (1- mn))
+            (format nil "~A" dy)
+            (format nil "~A" yr)
+            (format nil "~2,'0D:~2,'0D:~2,'0D" hr min sec))))
+
+(defun pretty-date-ut (&optional (tm (get-universal-time)))
+  (multiple-value-bind (sec min hr dy mn yr) (decode-universal-time tm)
+    (pretty-date yr mn dy hr min sec)))
+
+(defun date-string (ut)
+  (if (typep ut 'integer)
+      (multiple-value-bind (sec min hr day mon year dow daylight-p zone)
+          (decode-universal-time ut)
+        (declare (ignore daylight-p zone))
+        (format nil "~[Mon~;Tue~;Wed~;Thu~;Fri~;Sat~;Sun~] ~d ~[Jan~;Feb~;Mar~;Apr~;May~;Jun~;Jul~;Aug~;Sep~;Oct~;Nov~;Dec~] ~d ~2,'0d:~2,'0d:~2,'0d"
+                dow
+                day
+                (1- mon)
+                year
+                hr min sec))))
+
+(defun print-seconds (secs)
+  (print-float-units secs "sec"))
+
+(defun print-float-units (val unit)
+  (cond
+    ((< val 1d-6)
+     (format t "~,2,9F nano~A" val unit))
+    ((< val 1d-3)
+     (format t "~,2,6F micro~A" val unit))
+    ((< val 1)
+     (format t "~,2,3F milli~A" val unit))
+    ((> val 1d9)
+     (format t "~,2,-9F giga~A" val unit))
+    ((> val 1d6)
+     (format t "~,2,-6F mega~A" val unit))
+    ((> val 1d3)
+     (format t "~,2,-3F kilo~A" val unit))
+    (t
+     (format t "~,2F ~A" val unit))))
+
+(defconstant +posix-epoch+
+  (encode-universal-time 0 0 0 1 1 1970 0))
+
+(defun posix-time-to-utime (time)
+  (+ time +posix-epoch+))
+
+(defun utime-to-posix-time (utime)
+  (- utime +posix-epoch+))
+
+;; Monthnames taken from net-telent-date to support lml2
+
+(defvar *monthnames*
+  '((1 . "January")
+    (2 . "February")
+    (3 . "March")
+    (4 . "April")
+    (5 . "May")
+    (6 . "June")
+    (7 . "July")
+    (8 . "August")
+    (9 . "September")
+    (10 . "October")
+    (11 . "November")
+    (12 . "December")))
+
+(defun monthname (stream arg colon-p at-p &optional width (mincol 0) (colinc 1) (minpad 0) (padchar #\Space))
+  "Print the name of the month (1=January) corresponding to ARG on STREAM.  This is intended for embedding in a FORMAT directive: WIDTH governs the number of characters of text printed, MINCOL, COLINC, MINPAD, PADCHAR work as for ~A"
+  (declare (ignore colon-p))
+  (let ((monthstring (cdr (assoc arg *monthnames*))))
+    (if (not monthstring) (return-from monthname nil))
+    (let ((truncate (if width (min width (length monthstring)) nil)))
+      (format stream
+              (if at-p "~V,V,V,V@A" "~V,V,V,VA")
+              mincol colinc minpad padchar
+              (subseq monthstring 0 truncate)))))
+
+(defconstant* +zellers-adj+ #(0 3 2 5 0 3 5 1 4 6 2 4))
+
+(defun day-of-week (year month day)
+  "Day of week calculation using Zeller's Congruence.
+Input: The year y, month m (1 ≤ m ≤ 12) and day d (1 ≤ d ≤ 31).
+Output: n - the day of the week (Sunday = 0, Saturday = 6)."
+
+  (when (< month 3)
+    (decf year))
+  (mod
+   (+ year (floor year 4) (- (floor year 100)) (floor year 400)
+      (aref +zellers-adj+ (1- month)) day)
+   7))
+
+;;;; Daylight Saving Time calculations
+
+;; Daylight Saving Time begins for most of the United States at 2
+;; a.m. on the first Sunday of April. Time reverts to standard time at
+;; 2 a.m. on the last Sunday of October. In the U.S., each time zone
+;; switches at a different time.
+
+;; In the European Union, Summer Time begins and ends at 1 am
+;; Universal Time (Greenwich Mean Time). It starts the last Sunday in
+;; March, and ends the last Sunday in October. In the EU, all time
+;; zones change at the same moment.
+
+;; Spring forward, Fall back
+;; During DST, clocks are turned forward an hour, effectively moving
+;; an hour of daylight from the morning to the evening.
+
+;; United States                  European Union
+
+;; Year  DST Begins DST Ends     Summertime     Summertime
+;;       at 2 a.m.  at 2 a.m.    period begins  period ends
+;;                               at 1 a.m. UT   at 1 a.m. UT
+;; ----------------------------------------------------------
+;; 2000  April 2   October 29    March 26       October 29
+;; 2001  April 1   October 28    March 25       October 28
+;; 2002  April 7   October 27    March 31       October 27
+;; 2003  April 6   October 26    March 30       October 26
+;; 2004  April 4   October 31    March 28       October 31
+;; 2005  April 3   October 30    March 27       October 30
+;; 2006  April 2   October 29    March 26       October 29
+;; 2007  April 1   October 28    March 25       October 28
+;; 2008  April 6   October 26    March 30       October 26
+
+
Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/docbook.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/kmrcl-1.97/docbook.lisp	2007-10-06 21:23:47 UTC (rev 2224)
+++ branches/trunk-reorg/thirdparty/kmrcl-1.97/docbook.lisp	2007-10-06 21:39:22 UTC (rev 2225)
@@ -0,0 +1,110 @@
+(in-package kmrcl)
+
+(defpackage docbook
+  (:use #:cl #:cl-who #:kmrcl)
+  (:export
+   #:docbook-file
+   #:docbook-stream
+   #:xml-file->sexp-file
+   ))
+(in-package docbook)
+
+(defmacro docbook-stream (stream tree)
+  `(progn
+     (print-prologue ,stream)
+     (write-char #\Newline ,stream)
+     (let (cl-who::*indent* t)
+       (cl-who:with-html-output (,stream) ,tree))))
+
+(defun print-prologue (stream)
+  (write-string "<?xml version='1.0' ?>   <!-- -*- DocBook -*- -->" stream)
+  (write-char #\Newline stream)
+  (write-string "<!DOCTYPE book PUBLIC \"-//OASIS//DTD DocBook XML V4.2//EN\"" stream)
+  (write-char #\Newline stream)
+  (write-string "     \"http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd\" [" stream)
+  (write-char #\Newline stream)
+  (write-string "<!ENTITY % myents SYSTEM \"entities.xml\">" stream)
+  (write-char #\Newline stream)
+  (write-string "%myents;" stream)
+  (write-char #\Newline stream)
+  (write-string "]>" stream)
+  (write-char #\Newline stream))
+
+(defmacro docbook-file (name tree)
+  (let ((%name (gensym)))
+    `(let ((,%name ,name))
+      (with-open-file (stream ,%name :direction :output
+                       :if-exists :supersede)
+        (docbook-stream stream ,tree))
+      (values))))
+
+#+allegro
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (require 'pxml)
+  (require 'uri))
+
+(defun is-whitespace-string (s)
+  (and (stringp s)
+       (kmrcl:is-string-whitespace s)))
+
+(defun atom-processor (a)
+  (when a
+    (typecase a
+      (symbol
+       (nth-value 0 (kmrcl:ensure-keyword a)))
+      (string
+       (kmrcl:collapse-whitespace a))
+      (t
+       a))))
+
+(defun entity-callback (var token &optional public)
+  (declare (ignore token public))
+  (cond
+   ((and (net.uri:uri-scheme var)
+         (string= "http" (net.uri:uri-scheme var)))
+    nil)
+   (t
+    (let ((path (net.uri:uri-path var)))
+      (if (probe-file path)
+          (ignore-errors (open path))
+        (make-string-input-stream
+         (let ((*print-circle* nil))
+           (format nil "<!ENTITY ~A '~A'>" path path))))))))
+
+#+allegro
+(defun xml-file->sexp-file (file &key (preprocess nil))
+  (let* ((path (etypecase file
+                 (string (parse-namestring file))
+                 (pathname file)))
+         (new-path (make-pathname :defaults path
+                                  :type "sexp"))
+         raw-sexp)
+
+    (if preprocess
+        (multiple-value-bind (xml error status)
+            (kmrcl:command-output (format nil
+                                          "sh -c "export XML_CATALOG_FILES='~A'; cd ~A; xsltproc --xinclude pprint.xsl ~A""
+                                          "catalog-debian.xml"
+                                          (namestring (make-pathname :defaults (if (pathname-directory path)
+                                                                                   path
+                                                                                 *default-pathname-defaults*)
+                                                                     :name nil :type nil))
+                                          (namestring path)))
+          (unless (and (zerop status) (or (null error) (zerop (length error))))
+            (error "Unable to preprocess XML file ~A, status ~D.~%Error: ~A"
+                   path status error))
+          (setq raw-sexp (net.xml.parser:parse-xml
+                          (apply #'concatenate 'string xml)
+                          :content-only nil)))
+      (with-open-file (input path :direction :input)
+        (setq raw-sexp (net.xml.parser:parse-xml input :external-callback #'entity-callback))))
+
+    (with-open-file (output new-path :direction :output
+                     :if-exists :supersede)
+      (let ((filtered (kmrcl:remove-from-tree-if #'is-whitespace-string
+                                                 raw-sexp
+                                                 #'atom-processor)))
+        (write filtered :stream output :pretty t))))
+  (values))
+
+
Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/equal.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/kmrcl-1.97/equal.lisp	2007-10-06 21:23:47 UTC (rev 2224)
+++ branches/trunk-reorg/thirdparty/kmrcl-1.97/equal.lisp	2007-10-06 21:39:22 UTC (rev 2225)
@@ -0,0 +1,138 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          equal.lisp
+;;;; Purpose:       Generalized equal function for KMRCL package
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Apr 2000
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; KMRCL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+
+(in-package #:kmrcl)
+
+
+(defun generalized-equal (obj1 obj2)
+  (if (not (equal (type-of obj1) (type-of obj2)))
+      (progn
+        (terpri)
+        (describe obj1)
+        (describe obj2)
+        nil)
+    (typecase obj1
+      (double-float
+       (let ((diff (abs (/ (- obj1 obj2) obj1))))
+         (if (> diff (* 10 double-float-epsilon))
+             nil
+           t)))
+      (complex
+       (and (generalized-equal (realpart obj1) (realpart obj2))
+            (generalized-equal (imagpart obj1) (imagpart obj2))))
+      (structure-object
+       (generalized-equal-fielded-object obj1 obj2))
+      (standard-object
+       (generalized-equal-fielded-object obj1 obj2))
+      (hash-table
+       (generalized-equal-hash-table obj1 obj2)
+       )
+      (function
+       (generalized-equal-function obj1 obj2))
+      (string
+       (string= obj1 obj2))
+      (array
+       (generalized-equal-array obj1 obj2))
+      (t
+       (equal obj1 obj2)))))
+
+
+(defun generalized-equal-function (obj1 obj2)
+  (string= (function-to-string obj1) (function-to-string obj2)))
+
+(defun generalized-equal-array (obj1 obj2)
+  (block test
+    (when (not (= (array-total-size obj1) (array-total-size obj2)))
+      (return-from test nil))
+    (dotimes (i (array-total-size obj1))
+      (unless (generalized-equal (aref obj1 i) (aref obj2 i))
+        (return-from test nil)))
+    (return-from test t)))
+
+(defun generalized-equal-hash-table (obj1 obj2)
+  (block test
+    (when (not (= (hash-table-count obj1) (hash-table-count obj2)))
+      (return-from test nil))
+    (maphash
+     #'(lambda (k v)
+         (multiple-value-bind (value found) (gethash k obj2)
+           (unless (and found (generalized-equal v value))
+             (return-from test nil))))
+     obj1)
+    (return-from test t)))
+
+(defun generalized-equal-fielded-object (obj1 obj2)
+  (block test
+    (when (not (equal (class-of obj1) (class-of obj2)))
+      (return-from test nil))
+    (dolist (field (class-slot-names (class-name (class-of obj1))))
+      (unless (generalized-equal (slot-value obj1 field) (slot-value obj2 field))
+        (return-from test nil)))
+    (return-from test t)))
+
+(defun class-slot-names (c-name)
+  "Given a CLASS-NAME, returns a list of the slots in the class."
+  #+(or allegro cmu lispworks sbcl scl)
+  (mapcar #'kmr-mop:slot-definition-name
+          (kmr-mop:class-slots (kmr-mop:find-class c-name)))
+  #+(and mcl (not openmcl))
+  (let* ((class (find-class c-name nil)))
+    (when (typep class 'standard-class)
+      (nconc (mapcar #'car (ccl:class-instance-slots class))
+             (mapcar #'car (ccl:class-class-slots class)))))
+  #-(or allegro lispworks cmu sbcl scl (and mcl (not openmcl)))
+  (declare (ignore c-name))
+  #-(or allegro lispworks cmu sbcl scl (and mcl (not openmcl)))
+  (error "class-slot-names is not defined on this platform")
+  )
+
+(defun structure-slot-names (s-name)
+  "Given a STRUCTURE-NAME, returns a list of the slots in the structure."
+  #+allegro (class-slot-names s-name)
+  #+lispworks (structure:structure-class-slot-names
+               (find-class s-name))
+  #+(or sbcl cmu) (mapcar #'kmr-mop:slot-definition-name
+                          (kmr-mop:class-slots (kmr-mop:find-class s-name)))
+  #+scl (mapcar #'kernel:dsd-name
+                (kernel:dd-slots
+                 (kernel:layout-info
+                  (kernel:class-layout (find-class s-name)))))
+  #+(and mcl (not openmcl))
+  (let* ((sd (gethash s-name ccl::%defstructs%))
+               (slots (if sd (ccl::sd-slots sd))))
+          (mapcar #'car (if (symbolp (caar slots)) slots (cdr slots))))
+  #-(or allegro lispworks cmu sbcl scl (and mcl (not openmcl)))
+  (declare (ignore s-name))
+  #-(or allegro lispworks cmu sbcl scl (and mcl (not openmcl)))
+  (error "structure-slot-names is not defined on this platform")
+  )
+
+(defun function-to-string (obj)
+  "Returns the lambda code for a function. Relies on
+Allegro implementation-dependent features."
+  (multiple-value-bind (lambda closurep name) (function-lambda-expression obj)
+    (declare (ignore closurep))
+    (if lambda
+          (format nil "#'~s" lambda)
+      (if name
+          (format nil "#'~s" name)
+        (progn
+          (print obj)
+          (break))))))
+
Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/functions.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/kmrcl-1.97/functions.lisp	2007-10-06 21:23:47 UTC (rev 2224)
+++ branches/trunk-reorg/thirdparty/kmrcl-1.97/functions.lisp	2007-10-06 21:39:22 UTC (rev 2225)
@@ -0,0 +1,53 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          functions.lisp
+;;;; Purpose:       Function routines for KMRCL package
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Apr 2000
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; KMRCL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(in-package :kmrcl)
+
+(defun memo-proc (fn)
+  "Memoize results of call to fn, returns a closure with hash-table"
+  (let ((cache (make-hash-table :test #'equal)))
+    #'(lambda (&rest args)
+        (multiple-value-bind (val foundp) (gethash args cache)
+          (if foundp
+              val
+            (setf (gethash args cache) (apply fn args)))))))
+
+(defun memoize (fn-name)
+  (setf (fdefinition fn-name) (memo-proc (fdefinition fn-name))))
+
+(defmacro defun-memo (fn args &body body)
+  "Define a memoized function"
+  `(memoize (defun ,fn ,args . ,body)))
+
+(defmacro _f (op place &rest args)
+  (multiple-value-bind (vars forms var set access)
+                       (get-setf-expansion place)
+    `(let* (,@(mapcar #'list vars forms)
+            (,(car var) (,op ,access ,@args)))
+       ,set)))
+
+(defun compose (&rest fns)
+  (if fns
+      (let ((fn1 (car (last fns)))
+            (fns (butlast fns)))
+        #'(lambda (&rest args)
+            (reduce #'funcall fns
+                    :from-end t
+                    :initial-value (apply fn1 args))))
+      #'identity))
+
Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/ifstar.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/kmrcl-1.97/ifstar.lisp	2007-10-06 21:23:47 UTC (rev 2224)
+++ branches/trunk-reorg/thirdparty/kmrcl-1.97/ifstar.lisp	2007-10-06 21:39:22 UTC (rev 2225)
@@ -0,0 +1,61 @@
+;; the if* macro used in Allegro:
+;;
+;; This is in the public domain... please feel free to put this definition
+;; in your code or distribute it with your version of lisp.
+
+(in-package #:kmrcl)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (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 ,@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 ,@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) ,@col) totalcol))))
+             ((eq state :compl)
+              (cond ((not (string-equal lookat "elseif"))
+                     (error "if*: missing elseif clause ")))
+              (setq state :init)))))
+
Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/impl.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/kmrcl-1.97/impl.lisp	2007-10-06 21:23:47 UTC (rev 2224)
+++ branches/trunk-reorg/thirdparty/kmrcl-1.97/impl.lisp	2007-10-06 21:39:22 UTC (rev 2225)
@@ -0,0 +1,148 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          impl.lisp
+;;;; Purpose:       Implementation Dependent routines for kmrcl
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Sep 2003
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; KMRCL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(in-package #:kmrcl)
+
+(defun canonicalize-directory-name (filename)
+  (flet ((un-unspecific (value)
+           (if (eq value :unspecific) nil value)))
+    (let* ((path (pathname filename))
+           (name (un-unspecific (pathname-name path)))
+           (type (un-unspecific (pathname-type path)))
+           (new-dir
+            (cond ((and name type) (list (concatenate 'string name "." type)))
+                  (name (list name))
+                  (type (list type))
+                  (t nil))))
+      (if new-dir
+          (make-pathname
+           :directory (append (un-unspecific (pathname-directory path))
+                              new-dir)
+                    :name nil :type nil :version nil :defaults path)
+          path))))
+
+
+(defun probe-directory (filename &key (error-if-does-not-exist nil))
+  (let* ((path (canonicalize-directory-name filename))
+         (probe
+          #+allegro (excl:probe-directory path)
+          #+clisp (values
+                   (ignore-errors
+                     (#+lisp=cl ext:probe-directory
+                                #-lisp=cl lisp:probe-directory
+                                path)))
+          #+(or cmu scl) (when (eq :directory
+                                   (unix:unix-file-kind (namestring path)))
+                           path)
+          #+lispworks (when (lw:file-directory-p path)
+                        path)
+          #+sbcl (when (eq :directory
+                           (sb-unix:unix-file-kind (namestring path)))
+                   path)
+          #-(or allegro clisp cmu lispworks sbcl scl)
+          (probe-file path)))
+    (if probe
+        probe
+        (when error-if-does-not-exist
+          (error "Directory ~A does not exist." filename)))))
+
+(defun cwd (&optional dir)
+  "Change directory and set default pathname"
+  (cond
+   ((not (null dir))
+    (when (and (typep dir 'logical-pathname)
+               (translate-logical-pathname dir))
+      (setq dir (translate-logical-pathname dir)))
+    (when (stringp dir)
+      (setq dir (parse-namestring dir)))
+    #+allegro (excl:chdir dir)
+    #+clisp (#+lisp=cl ext:cd #-lisp=cl lisp:cd dir)
+    #+(or cmu scl) (setf (ext:default-directory) dir)
+    #+cormanlisp (ccl:set-current-directory dir)
+    #+(and mcl (not openmcl)) (ccl:set-mac-default-directory dir)
+    #+openmcl (ccl:cwd dir)
+    #+gcl (si:chdir dir)
+    #+lispworks (hcl:change-directory dir)
+    (setq cl:*default-pathname-defaults* dir))
+   (t
+    (let ((dir
+           #+allegro (excl:current-directory)
+           #+clisp (#+lisp=cl ext:default-directory #-lisp=cl lisp:default-directory)
+           #+(or cmu scl) (ext:default-directory)
+           #+sbcl (sb-unix:posix-getcwd/)
+           #+cormanlisp (ccl:get-current-directory)
+           #+lispworks (hcl:get-working-directory)
+           #+mcl (ccl:mac-default-directory)
+           #-(or allegro clisp cmu scl cormanlisp mcl sbcl lispworks) (truename ".")))
+      (when (stringp dir)
+        (setq dir (parse-namestring dir)))
+      dir))))
+
+
+
+(defun quit (&optional (code 0))
+  "Function to exit the Lisp implementation. Copied from CLOCC's QUIT function."
+    #+allegro (excl:exit code :quiet t)
+    #+clisp (#+lisp=cl ext:quit #-lisp=cl lisp:quit code)
+    #+(or cmu scl) (ext:quit code)
+    #+cormanlisp (win32:exitprocess code)
+    #+gcl (lisp:bye code)
+    #+lispworks (lw:quit :status code)
+    #+lucid (lcl:quit code)
+    #+sbcl (sb-ext:quit :unix-status (typecase code (number code) (null 0) (t 1)))
+    #+mcl (ccl:quit code)
+    #-(or allegro clisp cmu scl cormanlisp gcl lispworks lucid sbcl mcl)
+    (error 'not-implemented :proc (list 'quit code)))
+
+
+(defun command-line-arguments ()
+  #+allegro (system:command-line-arguments)
+  #+sbcl sb-ext:*posix-argv*
+  )
+
+(defun copy-file (from to &key link overwrite preserve-symbolic-links
+                  (preserve-time t) remove-destination force verbose)
+  #+allegro (sys:copy-file from to :link link :overwrite overwrite
+                           :preserve-symbolic-links preserve-symbolic-links
+                           :preserve-time preserve-time
+                           :remove-destination remove-destination
+                           :force force :verbose verbose)
+  #-allegro
+  (declare (ignore verbose preserve-symbolic-links overwrite))
+  (cond
+    ((and (typep from 'stream) (typep to 'stream))
+     (copy-binary-stream from to))
+    ((not (probe-file from))
+     (error "File ~A does not exist." from))
+    ((eq link :hard)
+     (run-shell-command "ln -f ~A ~A" (namestring from) (namestring to)))
+    (link
+     (multiple-value-bind (stdout stderr status)
+         (command-output "ln -f ~A ~A" (namestring from) (namestring to))
+       (declare (ignore stdout stderr))
+       ;; try symbolic if command failed
+       (unless (zerop status)
+         (run-shell-command "ln -sf ~A ~A" (namestring from) (namestring to)))))
+    (t
+     (when (and (or force remove-destination) (probe-file to))
+       (delete-file to))
+     (let* ((options (if preserve-time
+                         "-p"
+                         ""))
+            (cmd (format nil "cp ~A ~A ~A" options (namestring from) (namestring to))))
+       (run-shell-command cmd)))))
Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/io.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/kmrcl-1.97/io.lisp	2007-10-06 21:23:47 UTC (rev 2224)
+++ branches/trunk-reorg/thirdparty/kmrcl-1.97/io.lisp	2007-10-06 21:39:22 UTC (rev 2225)
@@ -0,0 +1,329 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          io.lisp
+;;;; Purpose:       Input/Output functions for KMRCL package
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Apr 2000
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of KMRCL, is Copyright (c) 2002-2003 by Kevin M. Rosenberg
+;;;;
+;;;; KMRCL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(in-package #:kmrcl)
+
+(defun print-file-contents (file &optional (strm *standard-output*))
+  "Opens a reads a file. Returns the contents as a single string"
+  (when (probe-file file)
+    (let ((eof (cons 'eof nil)))
+      (with-open-file (in file :direction :input)
+        (do ((line (read-line in nil eof)
+                   (read-line in nil eof)))
+            ((eq line eof))
+          (write-string line strm)
+          (write-char #\newline strm))))))
+
+(defun read-stream-to-string (in)
+  (with-output-to-string (out)
+    (let ((eof (gensym)))
+      (do ((line (read-line in nil eof)
+                 (read-line in nil eof)))
+          ((eq line eof))
+        (format out "~A~%" line)))))
+
+(defun read-file-to-string (file)
+  "Opens a reads a file. Returns the contents as a single string"
+  (with-open-file (in file :direction :input)
+    (read-stream-to-string in)))
+
+(defun read-file-to-usb8-array (file)
+  "Opens a reads a file. Returns the contents as single unsigned-byte array"
+  (with-open-file (in file :direction :input :element-type '(unsigned-byte 8))
+    (let* ((file-len (file-length in))
+           (usb8 (make-array file-len :element-type '(unsigned-byte 8)))
+           (pos (read-sequence usb8 in)))
+      (unless (= file-len pos)
+        (error "Length read (~D) doesn't match file length (~D)~%" pos file-len))
+      usb8)))
+
+
+(defun read-stream-to-strings (in)
+  (let ((lines '())
+        (eof (gensym)))
+    (do ((line (read-line in nil eof)
+               (read-line in nil eof)))
+        ((eq line eof))
+      (push line lines))
+    (nreverse lines)))
+
+(defun read-file-to-strings (file)
+  "Opens a reads a file. Returns the contents as a list of strings"
+  (with-open-file (in file :direction :input)
+    (read-stream-to-strings in)))
+
+(defun file-subst (old new file1 file2)
+  (with-open-file (in file1 :direction :input)
+    (with-open-file (out file2 :direction :output
+                         :if-exists :supersede)
+      (stream-subst old new in out))))
+
+(defun print-n-chars (char n stream)
+  (declare (fixnum n) (optimize (speed 3) (safety 0) (space 0)))
+  (dotimes (i n)
+    (declare (fixnum i))
+    (write-char char stream)))
+
+(defun print-n-strings (str n stream)
+  (declare (fixnum n) (optimize (speed 3) (safety 0) (space 0)))
+  (dotimes (i n)
+    (declare (fixnum i))
+    (write-string str stream)))
+
+(defun indent-spaces (n &optional (stream *standard-output*))
+  "Indent n*2 spaces to output stream"
+  (print-n-chars #\space (+ n n) stream))
+
+
+(defun indent-html-spaces (n &optional (stream *standard-output*))
+  "Indent n*2 html spaces to output stream"
+  (print-n-strings "&nbsp;" (+ n n) stream))
+
+
+(defun print-list (l &optional (output *standard-output*))
+  "Print a list to a stream"
+  (format output "~{~A~%~}" l))
+
+(defun print-rows (rows &optional (ostrm *standard-output*))
+  "Print a list of list rows to a stream"
+  (dolist (r rows) (format ostrm "~{~A~^ ~}~%" r)))
+
+
+;; Buffered stream substitute
+
+(defstruct buf
+  vec (start -1) (used -1) (new -1) (end -1))
+
+(defun bref (buf n)
+  (svref (buf-vec buf)
+         (mod n (length (buf-vec buf)))))
+
+(defun (setf bref) (val buf n)
+  (setf (svref (buf-vec buf)
+               (mod n (length (buf-vec buf))))
+        val))
+
+(defun new-buf (len)
+  (make-buf :vec (make-array len)))
+
+(defun buf-insert (x b)
+  (setf (bref b (incf (buf-end b))) x))
+
+(defun buf-pop (b)
+  (prog1
+    (bref b (incf (buf-start b)))
+    (setf (buf-used b) (buf-start b)
+          (buf-new  b) (buf-end   b))))
+
+(defun buf-next (b)
+  (when (< (buf-used b) (buf-new b))
+    (bref b (incf (buf-used b)))))
+
+(defun buf-reset (b)
+  (setf (buf-used b) (buf-start b)
+        (buf-new  b) (buf-end   b)))
+
+(defun buf-clear (b)
+  (setf (buf-start b) -1 (buf-used  b) -1
+        (buf-new   b) -1 (buf-end   b) -1))
+
+(defun buf-flush (b str)
+  (do ((i (1+ (buf-used b)) (1+ i)))
+      ((> i (buf-end b)))
+    (princ (bref b i) str)))
+
+
+(defun stream-subst (old new in out)
+  (declare (string old new))
+  (let* ((pos 0)
+         (len (length old))
+         (buf (new-buf len))
+         (from-buf nil))
+    (declare (fixnum pos len))
+    (do ((c (read-char in nil :eof)
+            (or (setf from-buf (buf-next buf))
+                (read-char in nil :eof))))
+        ((eql c :eof))
+      (declare (character c))
+      (cond ((char= c (char old pos))
+             (incf pos)
+             (cond ((= pos len)            ; 3
+                    (princ new out)
+                    (setf pos 0)
+                    (buf-clear buf))
+                   ((not from-buf)         ; 2
+                    (buf-insert c buf))))
+            ((zerop pos)                   ; 1
+             (princ c out)
+             (when from-buf
+               (buf-pop buf)
+               (buf-reset buf)))
+            (t                             ; 4
+             (unless from-buf
+               (buf-insert c buf))
+             (princ (buf-pop buf) out)
+             (buf-reset buf)
+             (setf pos 0))))
+    (buf-flush buf out)))
+
+(declaim (inline write-fixnum))
+(defun write-fixnum (n s)
+  #+allegro (excl::print-fixnum s 10 n)
+  #-allegro (write-string (write-to-string n) s))
+
+
+
+
+(defun null-output-stream ()
+  (when (probe-file #p"/dev/null")
+    (open #p"/dev/null" :direction :output :if-exists :overwrite))
+  )
+
+
+(defun directory-tree (filename)
+  "Returns a tree of pathnames for sub-directories of a directory"
+  (let* ((root (canonicalize-directory-name filename))
+         (subdirs (loop for path in (directory
+                                     (make-pathname :name :wild
+                                                    :type :wild
+                                                    :defaults root))
+                        when (probe-directory path)
+                        collect (canonicalize-directory-name path))))
+    (when (find nil subdirs)
+      (error "~A" subdirs))
+    (when (null root)
+      (error "~A" root))
+    (if subdirs
+        (cons root (mapcar #'directory-tree subdirs))
+        (if (probe-directory root)
+            (list root)
+            (error "root not directory ~A" root)))))
+
+
+(defmacro with-utime-decoding ((utime &optional zone) &body body)
+  "UTIME is a universal-time, ZONE is a number of hours offset from UTC, or NIL to use local time.  Execute BODY in an environment where SECOND MINUTE HOUR DAY-OF-MONTH MONTH YEAR DAY-OF-WEEK DAYLIGHT-P ZONE are bound to the decoded components of the universal time"
+  `(multiple-value-bind
+       (second minute hour day-of-month month year day-of-week daylight-p zone)
+       (decode-universal-time ,utime ,@(if zone (list zone)))
+     (declare (ignorable second minute hour day-of-month month year day-of-week daylight-p zone))
+     ,@body))
+
+(defvar +datetime-number-strings+
+  (make-array 61 :adjustable nil :element-type 'string :fill-pointer nil
+              :initial-contents
+              '("00" "01" "02" "03" "04" "05" "06" "07" "08" "09" "10" "11"
+                "12" "13" "14" "15" "16" "17" "18" "19" "20" "21" "22" "23"
+                "24" "25" "26" "27" "28" "29" "30" "31" "32" "33" "34" "35"
+                "36" "37" "38" "39" "40" "41" "42" "43" "44" "45" "46" "47"
+                "48" "49" "50" "51" "52" "53" "54" "55" "56" "57" "58" "59"
+                "60")))
+
+(defun is-dst (utime)
+  (with-utime-decoding (utime)
+    daylight-p))
+
+
+(defmacro with-utime-decoding-utc-offset ((utime utc-offset) &body body)
+  (with-gensyms (zone)
+    `(let* ((,zone (cond
+                    ((eq :utc ,utc-offset)
+                     0)
+                    ((null utc-offset)
+                     nil)
+                    (t
+                     (if (is-dst ,utime)
+                         (1- (- ,utc-offset))
+                       (- ,utc-offset))))))
+       (if ,zone
+           (with-utime-decoding (,utime ,zone)
+             ,@body)
+         (with-utime-decoding (,utime)
+           ,@body)))))
+
+
+(defun write-utime-hms (utime &key utc-offset stream)
+  (if stream
+      (write-utime-hms-stream utime stream utc-offset)
+    (with-output-to-string (s)
+      (write-utime-hms-stream utime s utc-offset))))
+
+(defun write-utime-hms-stream (utime stream &optional utc-offset)
+  (with-utime-decoding-utc-offset (utime utc-offset)
+    (write-string (aref +datetime-number-strings+ hour) stream)
+    (write-char #: stream)
+    (write-string (aref +datetime-number-strings+ minute) stream)
+    (write-char #: stream)
+    (write-string (aref +datetime-number-strings+ second) stream)))
+
+(defun write-utime-hm (utime &key utc-offset stream)
+  (if stream
+      (write-utime-hm-stream utime stream utc-offset)
+    (with-output-to-string (s)
+      (write-utime-hm-stream utime s utc-offset))))
+
+(defun write-utime-hm-stream (utime stream &optional utc-offset)
+  (with-utime-decoding-utc-offset (utime utc-offset)
+    (write-string (aref +datetime-number-strings+ hour) stream)
+    (write-char #: stream)
+    (write-string (aref +datetime-number-strings+ minute) stream)))
+
+
+(defun write-utime-ymdhms (utime &key stream utc-offset)
+  (if stream
+      (write-utime-ymdhms-stream utime stream utc-offset)
+    (with-output-to-string (s)
+      (write-utime-ymdhms-stream utime s utc-offset))))
+
+(defun write-utime-ymdhms-stream (utime stream &optional utc-offset)
+  (with-utime-decoding-utc-offset (utime utc-offset)
+    (write-string (prefixed-fixnum-string year nil 4) stream)
+    (write-char #/ stream)
+    (write-string (aref +datetime-number-strings+ month) stream)
+    (write-char #/ stream)
+    (write-string (aref +datetime-number-strings+ day-of-month) stream)
+    (write-char #\space stream)
+    (write-string (aref +datetime-number-strings+ hour) stream)
+    (write-char #: stream)
+    (write-string (aref +datetime-number-strings+ minute) stream)
+    (write-char #: stream)
+    (write-string (aref +datetime-number-strings+ second) stream)))
+
+(defun write-utime-ymdhm (utime &key stream utc-offset)
+  (if stream
+      (write-utime-ymdhm-stream utime stream utc-offset)
+    (with-output-to-string (s)
+      (write-utime-ymdhm-stream utime s utc-offset))))
+
+(defun write-utime-ymdhm-stream (utime stream &optional utc-offset)
+  (with-utime-decoding-utc-offset (utime utc-offset)
+    (write-string (prefixed-fixnum-string year nil 4) stream)
+    (write-char #/ stream)
+    (write-string (aref +datetime-number-strings+ month) stream)
+    (write-char #/ stream)
+    (write-string (aref +datetime-number-strings+ day-of-month) stream)
+    (write-char #\space stream)
+    (write-string (aref +datetime-number-strings+ hour) stream)
+    (write-char #: stream)
+    (write-string (aref +datetime-number-strings+ minute) stream)))
+
+(defun copy-binary-stream (in out &key (chunk-size 16384))
+  (do* ((buf (make-array chunk-size :element-type '(unsigned-byte 8)))
+        (pos (read-sequence buf in) (read-sequence buf in)))
+      ((zerop pos))
+    (write-sequence buf out :end pos)))
+
Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/kmrcl-tests.asd
===================================================================
--- branches/trunk-reorg/thirdparty/kmrcl-1.97/kmrcl-tests.asd	2007-10-06 21:23:47 UTC (rev 2224)
+++ branches/trunk-reorg/thirdparty/kmrcl-1.97/kmrcl-tests.asd	2007-10-06 21:39:22 UTC (rev 2225)
@@ -0,0 +1,26 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          kmrcl-tests.asd
+;;;; Purpose:       ASDF system definitionf for kmrcl testing package
+;;;; Author:        Kevin M. Rosenberg
+;;;; Date Started:  Apr 2003
+;;;;
+;;;; $Id$
+;;;; *************************************************************************
+
+(defpackage #:kmrcl-tests-system
+  (:use #:asdf #:cl))
+(in-package #:kmrcl-tests-system)
+
+(defsystem kmrcl-tests
+    :depends-on (:rt :kmrcl)
+    :components
+    ((:file "tests")))
+
+(defmethod perform ((o test-op) (c (eql (find-system 'kmrcl-tests))))
+  (or (funcall (intern (symbol-name '#:do-tests)
+		       (find-package '#:regression-test)))
+      (error "test-op failed")))
+
Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/kmrcl.asd
===================================================================
--- branches/trunk-reorg/thirdparty/kmrcl-1.97/kmrcl.asd	2007-10-06 21:23:47 UTC (rev 2224)
+++ branches/trunk-reorg/thirdparty/kmrcl-1.97/kmrcl.asd	2007-10-06 21:39:22 UTC (rev 2225)
@@ -0,0 +1,67 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          kmrcl.asd
+;;;; Purpose:       ASDF system definition for KMRCL package
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Apr 2000
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; KMRCL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(in-package #:cl-user)
+(defpackage #:kmrcl-system (:use #:asdf #:cl))
+(in-package #:kmrcl-system)
+
+#+(or allegro cmu clisp lispworks sbcl scl openmcl)
+(pushnew :kmr-mop cl:*features*)
+
+(defsystem kmrcl
+    :name "kmrcl"
+    :author "Kevin M. Rosenberg kevin@rosenberg.net"
+    :maintainer "Kevin M. Rosenberg kmr@debian.org"
+    :licence "LLGPL"
+    :depends-on (#+sbcl sb-posix)
+    :components
+    ((:file "package")
+     (:file "ifstar" :depends-on ("package"))
+     (:file "byte-stream" :depends-on ("package"))
+     (:file "macros" :depends-on ("package"))
+     (:file "functions" :depends-on ("macros"))
+     (:file "lists" :depends-on ("macros"))
+     (:file "seqs" :depends-on ("macros"))
+     (:file "impl" :depends-on ("macros"))
+     (:file "io" :depends-on ("macros" "impl"))
+     (:file "console" :depends-on ("macros"))
+     (:file "strings" :depends-on ("macros" "seqs"))
+     (:file "strmatch" :depends-on ("strings"))
+     (:file "buff-input" :depends-on ("macros"))
+     (:file "random" :depends-on ("macros"))
+     (:file "symbols" :depends-on ("macros"))
+     (:file "datetime" :depends-on ("macros"))
+     (:file "math" :depends-on ("macros"))
+     (:file "color" :depends-on ("macros"))
+     #+kmr-mop (:file "mop" :depends-on ("macros"))
+     ;; #+kmr-mop (:file "attrib-class" :depends-on ("seqs" "mop"))
+     (:file "equal" :depends-on ("macros" #+kmr-mop "mop"))
+     (:file "web-utils" :depends-on ("macros" "strings"))
+     (:file "xml-utils" :depends-on ("macros"))
+     (:file "sockets" :depends-on ("strings"))
+     (:file "processes" :depends-on ("macros"))
+     (:file "listener" :depends-on ("sockets" "processes" "console"))
+     (:file "repl" :depends-on ("listener" "strings"))
+     (:file "os" :depends-on ("macros" "impl"))
+     (:file "signals" :depends-on ("package"))
+     ))
+
+(defmethod perform ((o test-op) (c (eql (find-system 'kmrcl))))
+  (operate 'load-op 'kmrcl-tests)
+  (operate 'test-op 'kmrcl-tests :force t))
+
Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/listener.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/kmrcl-1.97/listener.lisp	2007-10-06 21:23:47 UTC (rev 2224)
+++ branches/trunk-reorg/thirdparty/kmrcl-1.97/listener.lisp	2007-10-06 21:39:22 UTC (rev 2225)
@@ -0,0 +1,288 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: modlisp -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          listener.lisp
+;;;; Purpose:       Listener and worker processes
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Jun 2003
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of KMRCL, is Copyright (c) 2002-2003 by Kevin M. Rosenberg
+;;;;
+;;;; KMRCL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(in-package #:kmrcl)
+
+;;; Variables and data structures for Listener
+
+(defvar *listener-count* 0
+  "used to name listeners")
+
+(defvar *worker-count* 0
+  "used to name workers")
+
+(defvar *active-listeners* nil
+    "List of active listeners")
+
+(defclass listener ()
+  ((port :initarg :port :accessor port)
+   (function :initarg :function :accessor listener-function
+             :initform nil)
+   (function-args :initarg :function-args :accessor function-args
+                  :initform nil)
+   (process :initarg :process :accessor process :initform nil)
+   (socket :initarg :socket :accessor socket :initform nil)
+   (workers :initform nil :accessor workers
+            :documentation "list of worker threads")
+   (name :initform "" :accessor name :initarg :name)
+   (base-name :initform "listener" :accessor base-name :initarg :base-name)
+   (wait :initform nil :accessor wait :initarg :wait)
+   (timeout :initform nil :accessor timeout :initarg :timeout)
+   (number-fixed-workers :initform nil :accessor number-fixed-workers
+                         :initarg :number-fixed-workers)
+   (catch-errors :initform nil :accessor catch-errors :initarg :catch-errors)
+   (remote-host-checker :initform nil :accessor remote-host-checker
+                        :initarg :remote-host-checker)
+   (format :initform :text :accessor listener-format :initarg :format)))
+
+(defclass fixed-worker ()
+  ((listener :initarg :listener :accessor listener :initform nil)
+   (name :initarg :name :accessor name :initform nil)
+   (process :initarg :process :accessor process :initform nil)))
+
+(defclass worker (fixed-worker)
+  ((connection :initarg :connection :accessor connection :initform nil)
+   (thread-fun :initarg :thread-fun :accessor thread-fun :initform nil)))
+
+
+(defmethod print-object ((obj listener) s)
+  (print-unreadable-object (obj s :type t :identity nil)
+    (format s "port ~A" (port obj))))
+
+(defmethod print-object ((obj fixed-worker) s)
+  (print-unreadable-object (obj s :type t :identity nil)
+    (format s "port ~A" (port (listener obj)))))
+
+;; High-level API
+
+(defun init/listener (listener state)
+  (check-type listener listener)
+  (case state
+    (:start
+     (when (member listener *active-listeners*)
+       (cmsg "~&listener ~A already initialized" listener)
+       (return-from init/listener))
+     (when (listener-startup listener)
+       (push listener *active-listeners*)
+       listener))
+    (:stop
+     (unless (member listener *active-listeners*)
+       (cmsg "~&listener ~A is not in active list" listener)
+       (return-from init/listener listener))
+     (listener-shutdown listener)
+     (setq *active-listeners* (remove listener *active-listeners*)))
+    (:restart
+     (init/listener listener :stop)
+     (init/listener listener :start))))
+
+(defun stop-all/listener ()
+  (dolist (listener *active-listeners*)
+    (ignore-errors
+       (init/listener listener :stop))))
+
+(defun listener-startup (listener)
+  (handler-case
+      (progn
+        (setf (name listener) (next-server-name (base-name listener)))
+        (make-socket-server listener))
+    (error (e)
+      (format t "~&Error while trying to start listener on port ~A~&  ~A"
+              (port listener) e)
+      (decf *listener-count*)
+      nil)
+    (:no-error (res)
+      (declare (ignore res))
+      listener)))
+
+(defun listener-shutdown (listener)
+  (dolist (worker (workers listener))
+    (when (and (typep worker 'worker)
+               (connection worker))
+      (errorset (close-active-socket
+                 (connection worker)) nil)
+      (setf (connection worker) nil))
+    (when (process worker)
+      (errorset (destroy-process (process worker)) nil)
+      (setf (process worker) nil)))
+  (setf (workers listener) nil)
+  (with-slots (process socket) listener
+    (when socket
+      (errorset (close-passive-socket socket) nil)
+      (setf socket nil))
+    (when process
+      (errorset (destroy-process process) nil)
+      (setf process nil))))
+
+;; Low-level functions
+
+(defun next-server-name (base-name)
+  (format nil "~D-~A-socket-server" (incf *listener-count*) base-name))
+
+(defun next-worker-name (base-name)
+  (format nil "~D-~A-worker"  (incf *worker-count*) base-name))
+
+(defun make-socket-server (listener)
+  #+lispworks
+  (progn
+    (setf (process listener)
+      (comm:start-up-server :process-name (name listener)
+                            :service (port listener)
+                            :function
+                            #'(lambda (handle)
+                                (lw-worker handle listener)))))
+  #-lispworks
+  (progn
+    (setf (socket listener) (create-inet-listener
+                             (port listener)
+                             :format (listener-format listener)))
+    (if (number-fixed-workers listener)
+        (start-fixed-number-of-workers listener)
+        (setf (process listener) (make-process
+                                  (name listener)
+                                  #'(lambda ()
+                                      (start-socket-server listener))))))
+  listener)
+
+
+(defmethod initialize-instance :after
+    ((self worker) &key listener connection name &allow-other-keys)
+  (flet ((do-work ()
+           (apply (listener-function listener)
+                  connection
+                  (function-args listener))))
+    (unless connection
+      (error "connection not provided to modlisp-worker"))
+    (setf (slot-value self 'listener) listener)
+    (setf (slot-value self 'name) name)
+    (setf (slot-value self 'connection) connection)
+    (setf (slot-value self 'thread-fun)
+          #'(lambda ()
+              (unwind-protect
+                   (if (catch-errors listener)
+                       (handler-case
+                           (if (timeout listener)
+                               (with-timeout ((timeout listener))
+                                 (do-work))
+                               (do-work))
+                         (error (e)
+                           (cmsg "Error ~A [~A]" e name)))
+                       (if (timeout listener)
+                           (with-timeout ((timeout listener))
+                             (do-work))
+                           (do-work)))
+                (progn
+                  (errorset (finish-output connection) nil)
+                  (errorset (close-active-socket connection) nil)
+                  (cmsg-c :threads "~A ended" name)
+                  (setf (workers listener)
+                        (remove self (workers listener)))))))))
+
+(defun accept-and-check-tcp-connection (listener)
+  (multiple-value-bind (conn socket) (accept-tcp-connection (socket listener))
+    (when (and (remote-host-checker listener)
+               (not (funcall (remote-host-checker listener)
+                             (remote-host socket))))
+      (cmsg-c :thread "Deny connection from ~A" (remote-host conn))
+      (errorset (close-active-socket conn) nil)
+      (setq conn nil))
+    conn))
+
+(defun start-socket-server (listener)
+  (unwind-protect
+      (loop
+       (let ((connection (accept-and-check-tcp-connection listener)))
+         (when connection
+           (if (wait listener)
+               (unwind-protect
+                    (apply (listener-function listener)
+                           connection
+                           (function-args listener))
+                 (progn
+                   (errorset (finish-output connection) nil)
+                   (errorset (close-active-socket connection) nil)))
+               (let ((worker (make-instance 'worker :listener listener
+                                            :connection connection
+                                            :name (next-worker-name
+                                                   (base-name listener)))))
+                 (setf (process worker)
+                       (make-process (name worker) (thread-fun worker)))
+                 (push worker (workers listener)))))))
+    (errorset (close-passive-socket (socket listener)) nil)))
+
+#+lispworks
+(defun lw-worker (handle listener)
+  (let ((connection (make-instance 'comm:socket-stream
+                      :socket handle
+                      :direction :io
+                      :element-type 'base-char)))
+    (if (wait listener)
+        (progn
+          (apply (listener-function listener)
+                 connection
+                 (function-args listener))
+          (finish-output connection))
+        (let ((worker (make-instance 'worker :listener listener
+                                     :connection connection
+                                     :name (next-worker-name
+                                            (base-name listener)))))
+          (setf (process worker)
+                (make-process (name worker) (thread-fun worker)))
+          (push worker (workers listener))))))
+
+;; Fixed pool of workers
+
+(defun start-fixed-number-of-workers (listener)
+  (dotimes (i (number-fixed-workers listener))
+    (let ((name (next-worker-name (base-name listener))))
+      (push
+       (make-instance 'fixed-worker
+                      :name name
+                      :listener listener
+                      :process
+                      (make-process
+                       name #'(lambda () (fixed-worker name listener))))
+       (workers listener)))))
+
+
+(defun fixed-worker (name listener)
+  (loop
+   (let ((connection (accept-and-check-tcp-connection listener)))
+     (when connection
+       (flet ((do-work ()
+                (apply (listener-function listener)
+                       connection
+                       (function-args listener))))
+         (unwind-protect
+              (handler-case
+                  (if (catch-errors listener)
+                      (handler-case
+                          (if (timeout listener)
+                              (with-timeout ((timeout listener))
+                                (do-work))
+                              (do-work))
+                        (error (e)
+                          (cmsg "Error ~A [~A]" e name)))
+                      (if (timeout listener)
+                          (with-timeout ((timeout listener))
+                            (do-work))
+                          (do-work)))
+                (error (e)
+                  (format t "Error: ~A" e)))
+           (errorset (finish-output connection) nil)
+           (errorset (close connection) nil)))))))
+
Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/lists.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/kmrcl-1.97/lists.lisp	2007-10-06 21:23:47 UTC (rev 2224)
+++ branches/trunk-reorg/thirdparty/kmrcl-1.97/lists.lisp	2007-10-06 21:39:22 UTC (rev 2225)
@@ -0,0 +1,203 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          lists.lisp
+;;;; Purpose:       Functions for lists for KMRCL package
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Apr 2000
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; KMRCL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(in-package #:kmrcl)
+
+(defun mklist (obj)
+  "Make into list if atom"
+  (if (listp obj) obj (list obj)))
+
+(defun map-and-remove-nils (fn lst)
+  "mao a list by function, eliminate elements where fn returns nil"
+  (let ((acc nil))
+    (dolist (x lst (nreverse acc))
+      (let ((val (funcall fn x)))
+        (when val (push val acc))))))
+
+(defun filter (fn lst)
+  "Filter a list by function, eliminate elements where fn returns nil"
+  (let ((acc nil))
+    (dolist (x lst (nreverse acc))
+      (when (funcall fn x)
+        (push x acc)))))
+
+(defun appendnew (l1 l2)
+  "Append two lists, filtering out elem from second list that are already in first list"
+  (dolist (elem l2 l1)
+    (unless (find elem l1)
+      (setq l1 (append l1 (list elem))))))
+
+(defun remove-from-tree-if (pred tree &optional atom-processor)
+  "Strip from tree of atoms that satistify predicate"
+  (if (atom tree)
+      (unless (funcall pred tree)
+        (if atom-processor
+            (funcall atom-processor tree)
+          tree))
+    (let ((car-strip (remove-from-tree-if pred (car tree) atom-processor))
+          (cdr-strip (remove-from-tree-if pred (cdr tree) atom-processor)))
+      (cond
+       ((and car-strip (atom (cadr tree)) (null cdr-strip))
+        (list car-strip))
+       ((and car-strip cdr-strip)
+        (cons car-strip cdr-strip))
+       (car-strip
+        car-strip)
+       (cdr-strip
+        cdr-strip)))))
+
+(defun find-tree (sym tree)
+  "Finds an atom as a car in tree and returns cdr tree at that positions"
+  (if (or (null tree) (atom tree))
+      nil
+    (if (eql sym (car tree))
+        (cdr tree)
+      (aif (find-tree sym (car tree))
+          it
+        (aif (find-tree sym (cdr tree))
+            it
+            nil)))))
+
+(defun flatten (lis)
+  (cond ((atom lis) lis)
+        ((listp (car lis))
+         (append (flatten (car lis)) (flatten (cdr lis))))
+        (t (append (list (car lis)) (flatten (cdr lis))))))
+
+;;; Keyword functions
+
+(defun remove-keyword (key arglist)
+  (loop for sublist = arglist then rest until (null sublist)
+        for (elt arg . rest) = sublist
+        unless (eq key elt) append (list elt arg)))
+
+(defun remove-keywords (key-names args)
+  (loop for ( name val ) on args by #'cddr
+        unless (member (symbol-name name) key-names
+                       :key #'symbol-name :test 'equal)
+        append (list name val)))
+
+(defun mapappend (func seq)
+  (apply #'append (mapcar func seq)))
+
+(defun mapcar-append-string-nontailrec (func v)
+  "Concatenate results of mapcar lambda calls"
+  (aif (car v)
+       (concatenate 'string (funcall func it)
+                    (mapcar-append-string-nontailrec func (cdr v)))
+       ""))
+
+
+(defun mapcar-append-string (func v &optional (accum ""))
+  "Concatenate results of mapcar lambda calls"
+  (aif (car v)
+       (mapcar-append-string
+        func
+        (cdr v)
+        (concatenate 'string accum (funcall func it)))
+       accum))
+
+(defun mapcar2-append-string-nontailrec (func la lb)
+  "Concatenate results of mapcar lambda call's over two lists"
+  (let ((a (car la))
+        (b (car lb)))
+    (if (and a b)
+      (concatenate 'string (funcall func a b)
+                   (mapcar2-append-string-nontailrec func (cdr la) (cdr lb)))
+      "")))
+
+(defun mapcar2-append-string (func la lb &optional (accum ""))
+  "Concatenate results of mapcar lambda call's over two lists"
+  (let ((a (car la))
+        (b (car lb)))
+    (if (and a b)
+        (mapcar2-append-string func (cdr la)  (cdr lb)
+                               (concatenate 'string accum (funcall func a b)))
+      accum)))
+
+(defun append-sublists (list)
+  "Takes a list of lists and appends all sublists"
+  (let ((results (car list)))
+    (dolist (elem (cdr list) results)
+      (setq results (append results elem)))))
+
+
+;; alists and plists
+
+(defun alist-elem-p (elem)
+  (and (consp elem) (atom (car elem)) (atom (cdr elem))))
+
+(defun alistp (alist)
+  (when (listp alist)
+    (dolist (elem alist)
+      (unless (alist-elem-p elem)
+        (return-from alistp nil)))
+    t))
+
+(defmacro update-alist (akey value alist &key (test '#'eql) (key '#'identity))
+  "Macro to support below (setf get-alist)"
+  (let ((elem (gensym "ELEM-"))
+        (val (gensym "VAL-")))
+    `(let ((,elem (assoc ,akey ,alist :test ,test :key ,key))
+           (,val ,value))
+       (cond
+        (,elem
+         (setf (cdr ,elem) ,val))
+        (,alist
+         (setf (cdr (last ,alist)) (list (cons ,akey ,val))))
+         (t
+          (setf ,alist (list (cons ,akey ,val)))))
+       ,alist)))
+
+(defun get-alist (key alist &key (test #'eql))
+  (cdr (assoc key alist :test test)))
+
+(defun (setf get-alist) (value key alist &key (test #'eql))
+  "This won't work if the alist is NIL."
+  (update-alist key value alist :test test)
+  value)
+
+(defun alist-plist (alist)
+  (apply #'append (mapcar #'(lambda (x) (list (car x) (cdr x))) alist)))
+
+(defun plist-alist (plist)
+  (do ((alist '())
+       (pl plist (cddr pl)))
+      ((null pl) alist)
+    (setq alist (acons (car pl) (cadr pl) alist))))
+
+(defmacro update-plist (pkey value plist &key (test '#'eql))
+  "Macro to support below (setf get-alist)"
+  (let ((pos (gensym)))
+    `(let ((,pos (member ,pkey ,plist :test ,test)))
+       (if ,pos
+           (progn
+             (setf (cadr ,pos) ,value)
+             ,plist)
+         (setf ,plist (append ,plist (list ,pkey ,value)))))))
+
+
+(defun unique-slot-values (list slot &key (test 'eql))
+  (let ((uniq '()))
+    (dolist (item list (nreverse uniq))
+      (let ((value (slot-value item slot)))
+        (unless (find value uniq :test test)
+          (push value uniq))))))
+
+
+
Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/macros.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/kmrcl-1.97/macros.lisp	2007-10-06 21:23:47 UTC (rev 2224)
+++ branches/trunk-reorg/thirdparty/kmrcl-1.97/macros.lisp	2007-10-06 21:39:22 UTC (rev 2225)
@@ -0,0 +1,279 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          gentils.lisp
+;;;; Purpose:       Main general utility functions for KMRCL package
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Apr 2000
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; KMRCL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(in-package #:kmrcl)
+
+(defmacro let-when ((var test-form) &body body)
+  `(let ((,var ,test-form))
+      (when ,var ,@body)))
+
+(defmacro let-if ((var test-form) if-true &optional if-false)
+  `(let ((,var ,test-form))
+      (if ,var ,if-true ,if-false)))
+
+;; Anaphoric macros
+
+(defmacro aif (test then &optional else)
+  `(let ((it ,test))
+     (if it ,then ,else)))
+
+(defmacro awhen (test-form &body body)
+  `(aif ,test-form
+        (progn ,@body)))
+
+(defmacro awhile (expr &body body)
+  `(do ((it ,expr ,expr))
+       ((not it))
+     ,@body))
+
+(defmacro aand (&rest args)
+  (cond ((null args) t)
+        ((null (cdr args)) (car args))
+        (t `(aif ,(car args) (aand ,@(cdr args))))))
+
+(defmacro acond (&rest clauses)
+  (if (null clauses)
+      nil
+      (let ((cl1 (car clauses))
+            (sym (gensym)))
+        `(let ((,sym ,(car cl1)))
+           (if ,sym
+               (let ((it ,sym)) ,@(cdr cl1))
+               (acond ,@(cdr clauses)))))))
+
+(defmacro alambda (parms &body body)
+  `(labels ((self ,parms ,@body))
+     #'self))
+
+(defmacro aif2 (test &optional then else)
+  (let ((win (gensym)))
+    `(multiple-value-bind (it ,win) ,test
+       (if (or it ,win) ,then ,else))))
+
+(defmacro awhen2 (test &body body)
+  `(aif2 ,test
+         (progn ,@body)))
+
+(defmacro awhile2 (test &body body)
+  (let ((flag (gensym)))
+    `(let ((,flag t))
+       (while ,flag
+         (aif2 ,test
+               (progn ,@body)
+               (setq ,flag nil))))))
+
+(defmacro acond2 (&rest clauses)
+  (if (null clauses)
+      nil
+      (let ((cl1 (car clauses))
+            (val (gensym))
+            (win (gensym)))
+        `(multiple-value-bind (,val ,win) ,(car cl1)
+           (if (or ,val ,win)
+               (let ((it ,val)) ,@(cdr cl1))
+               (acond2 ,@(cdr clauses)))))))
+
+(defmacro mac (expr)
+"Expand a macro"
+  `(pprint (macroexpand-1 ',expr)))
+
+(defmacro print-form-and-results (form)
+  `(format t "~&~A --> ~S~%" (write-to-string ',form) ,form))
+
+
+;;; Loop macros
+
+(defmacro until (test &body body)
+  `(do ()
+       (,test)
+     ,@body))
+
+(defmacro while (test &body body)
+  `(do ()
+       ((not ,test))
+     ,@body))
+
+(defmacro for ((var start stop) &body body)
+  (let ((gstop (gensym)))
+    `(do ((,var ,start (1+ ,var))
+          (,gstop ,stop))
+         ((> ,var ,gstop))
+       ,@body)))
+
+(defmacro with-each-stream-line ((var stream) &body body)
+  (let ((eof (gensym))
+        (eof-value (gensym))
+        (strm (gensym)))
+    `(let ((,strm ,stream)
+           (,eof ',eof-value))
+      (do ((,var (read-line ,strm nil ,eof) (read-line ,strm nil ,eof)))
+          ((eql ,var ,eof))
+        ,@body))))
+
+(defmacro with-each-file-line ((var file) &body body)
+  (let ((stream (gensym)))
+    `(with-open-file (,stream ,file :direction :input)
+      (with-each-stream-line (,var ,stream)
+        ,@body))))
+
+
+(defmacro in (obj &rest choices)
+  (let ((insym (gensym)))
+    `(let ((,insym ,obj))
+       (or ,@(mapcar #'(lambda (c) `(eql ,insym ,c))
+                     choices)))))
+
+(defmacro mean (&rest args)
+  `(/ (+ ,@args) ,(length args)))
+
+(defmacro with-gensyms (syms &body body)
+  `(let ,(mapcar #'(lambda (s) `(,s (gensym)))
+          syms)
+     ,@body))
+
+
+(defmacro time-seconds (&body body)
+  (let ((t1 (gensym)))
+    `(let ((,t1 (get-internal-real-time)))
+       (values
+        (progn ,@body)
+        (coerce (/ (- (get-internal-real-time) ,t1)
+                   internal-time-units-per-second)
+                'double-float)))))
+
+(defmacro time-iterations (n &body body)
+  (let ((i (gensym))
+        (count (gensym)))
+    `(progn
+       (let ((,count ,n))
+         (format t "~&Test with ~d iterations: ~W" ,count (quote ,body))
+         (let ((t1 (get-internal-real-time)))
+           (dotimes (,i ,count)
+             ,@body)
+           (let* ((t2 (get-internal-real-time))
+                  (secs (coerce (/ (- t2 t1)
+                                   internal-time-units-per-second)
+                                'double-float)))
+             (format t "~&Total time: ")
+             (print-seconds secs)
+             (format t ", time per iteration: ")
+             (print-seconds (coerce (/ secs ,n) 'double-float))))))))
+
+(defmacro mv-bind (vars form &body body)
+  `(multiple-value-bind ,vars ,form
+     ,@body))
+
+;; From USENET
+(defmacro deflex (var val &optional (doc nil docp))
+  "Defines a top level (global) lexical VAR with initial value VAL,
+      which is assigned unconditionally as with DEFPARAMETER. If a DOC
+      string is provided, it is attached to both the name |VAR| and the
+      name *STORAGE-FOR-DEFLEX-VAR-|VAR|* as a documentation string of
+      kind 'VARIABLE. The new VAR will have lexical scope and thus may
+      be shadowed by LET bindings without affecting its global value."
+  (let* ((s0 (load-time-value (symbol-name '#:*storage-for-deflex-var-)))
+         (s1 (symbol-name var))
+         (p1 (symbol-package var))
+         (s2 (load-time-value (symbol-name '#:*)))
+         (backing-var (intern (concatenate 'string s0 s1 s2) p1)))
+    `(progn
+      (defparameter ,backing-var ,val ,@(when docp `(,doc)))
+      ,@(when docp
+              `((setf (documentation ',var 'variable) ,doc)))
+      (define-symbol-macro ,var ,backing-var))))
+
+(defmacro def-cached-vector (name element-type)
+  (let ((get-name (concat-symbol "get-" name "-vector"))
+        (release-name (concat-symbol "release-" name "-vector"))
+        (table-name (concat-symbol "*cached-" name "-table*"))
+        (lock-name (concat-symbol "*cached-" name "-lock*")))
+    `(eval-when (:compile-toplevel :load-toplevel :execute)
+       (defvar ,table-name (make-hash-table :test 'equal))
+       (defvar ,lock-name (kmrcl::make-lock ,name))
+
+         (defun ,get-name (size)
+           (kmrcl::with-lock-held (,lock-name)
+             (let ((buffers (gethash (cons size ,element-type) ,table-name)))
+               (if buffers
+                   (let ((buffer (pop buffers)))
+                     (setf (gethash (cons size ,element-type) ,table-name) buffers)
+                     buffer)
+                 (make-array size :element-type ,element-type)))))
+
+         (defun ,release-name (buffer)
+           (kmrcl::with-lock-held (,lock-name)
+             (let ((buffers (gethash (cons (array-total-size buffer)
+                                           ,element-type)
+                                     ,table-name)))
+               (setf (gethash (cons (array-total-size buffer)
+                                    ,element-type) ,table-name)
+                 (cons buffer buffers))))))))
+
+(defmacro def-cached-instance (name)
+  (let* ((new-name (concat-symbol "new-" name "-instance"))
+         (release-name (concat-symbol "release-" name "-instance"))
+         (cache-name (concat-symbol "*cached-" name "-instance-table*"))
+         (lock-name (concat-symbol "*cached-" name "-instance-lock*")))
+    `(eval-when (:compile-toplevel :load-toplevel :execute)
+       (defvar ,cache-name nil)
+       (defvar ,lock-name (kmrcl::make-lock ',name))
+
+         (defun ,new-name ()
+           (kmrcl::with-lock-held (,lock-name)
+             (if ,cache-name
+                 (pop ,cache-name)
+                 (make-instance ',name))))
+
+         (defun ,release-name (instance)
+           (kmrcl::with-lock-held (,lock-name)
+             (push instance ,cache-name))))))
+
+(defmacro with-ignore-errors (&rest forms)
+  `(progn
+     ,@(mapcar
+        (lambda (x) (list 'ignore-errors x))
+        forms)))
+
+(defmacro ppmx (form)
+  "Pretty prints the macro expansion of FORM."
+  `(let* ((exp1 (macroexpand-1 ',form))
+          (exp (macroexpand exp1))
+          (*print-circle* nil))
+     (cond ((equal exp exp1)
+            (format t "~&Macro expansion:")
+            (pprint exp))
+           (t (format t "~&First step of expansion:")
+              (pprint exp1)
+              (format t "~%~%Final expansion:")
+              (pprint exp)))
+     (format t "~%~%")
+     (values)))
+
+(defmacro defconstant* (sym value &optional doc)
+  "Ensure VALUE is evaluated only once."
+   `(defconstant ,sym (if (boundp ',sym)
+                          (symbol-value ',sym)
+                          ,value)
+     ,@(when doc (list doc))))
+
+(defmacro defvar-unbound (sym &optional (doc ""))
+    "defvar with a documentation string."
+    `(progn
+      (defvar ,sym)
+      (setf (documentation ',sym 'variable) ,doc)))
+
Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/math.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/kmrcl-1.97/math.lisp	2007-10-06 21:23:47 UTC (rev 2224)
+++ branches/trunk-reorg/thirdparty/kmrcl-1.97/math.lisp	2007-10-06 21:39:22 UTC (rev 2225)
@@ -0,0 +1,110 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          math.lisp
+;;;; Purpose:       General purpose math functions
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Nov 2002
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; KMRCL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+
+(in-package #:kmrcl)
+
+(defun deriv (f dx)
+  #'(lambda (x)
+      (/ (- (funcall f (+ x dx)) (funcall f x))
+         dx)))
+
+(defun sin^ (x)
+    (funcall (deriv #'sin 1d-8) x))
+
+;;; (sin^ pi)
+
+(defmacro ensure-integer (obj)
+  "Ensure object is an integer. If it is a string, then parse it"
+  `(if (stringp ,obj)
+      (parse-integer ,obj)
+     ,obj))
+
+(defun histogram (v n-bins &key min max)
+  (declare (fixnum n-bins))
+  (when (listp v)
+    (setq v (coerce v 'vector)))
+  (when (zerop (length v))
+    (return-from histogram (values nil nil nil)) )
+  (let ((n (length v))
+        (bins (make-array n-bins :element-type 'integer :initial-element 0))
+        found-min found-max)
+    (declare (fixnum n))
+    (unless (and min max)
+      (setq found-min (aref v 0)
+            found-max (aref v 0))
+      (loop for i fixnum from 1 to (1- n)
+          do
+            (let ((x (aref v i)))
+              (cond
+               ((> x found-max)
+                (setq found-max x))
+               ((< x found-min)
+                (setq found-min x)))))
+      (unless min
+        (setq min found-min))
+      (unless max
+        (setq max found-max)))
+    (let ((width (/ (- max min) n-bins)))
+      (setq width (+ width (* double-float-epsilon width)))
+      (dotimes (i n)
+        (let ((bin (nth-value 0 (truncate (- (aref v i) min) width))))
+          (declare (fixnum bin))
+          (when (and (not (minusp bin))
+                     (< bin n-bins))
+            (incf (aref bins bin))))))
+    (values bins min max)))
+
+
+(defun fixnum-width ()
+  (nth-value 0 (truncate (+ (/ (log (1+ most-positive-fixnum)) (log 2)) .5))))
+
+(defun scaled-epsilon (float &optional (operation '+))
+  "Return the smallest number that would return a value different from
+  FLOAT if OPERATION were applied to FLOAT and this number.  OPERATION
+  should be either + or -, and defauls to +."
+  (multiple-value-bind (significand exponent)
+      (decode-float float)
+    (multiple-value-bind (1.0-significand 1.0-exponent)
+        (decode-float (float 1.0 float))
+      (if (and (eq operation '-)
+               (= significand 1.0-significand))
+          (scale-float (typecase float
+                         (short-float short-float-negative-epsilon)
+                         (single-float single-float-negative-epsilon)
+                         (double-float double-float-negative-epsilon)
+                         (long-float long-float-negative-epsilon))
+                       (- exponent 1.0-exponent))
+        (scale-float (typecase float
+                       (short-float short-float-epsilon)
+                       (single-float single-float-epsilon)
+                       (double-float double-float-epsilon)
+                       (long-float long-float-epsilon))
+                     (- exponent 1.0-exponent))))))
+
+(defun sinc (x)
+  (if (zerop x)
+      1d0
+    (let ((x (coerce x 'double-float)))
+      (/ (sin x) x))))
+
+
+(defun numbers-within-percentage (a b percent)
+  "Determines if two numbers are equal within a percentage difference."
+  (let ((abs-diff (* 0.01 percent 0.5 (+ (abs a) (abs b)))))
+    (< (abs (- a b)) abs-diff)))
Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/mop.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/kmrcl-1.97/mop.lisp	2007-10-06 21:23:47 UTC (rev 2224)
+++ branches/trunk-reorg/thirdparty/kmrcl-1.97/mop.lisp	2007-10-06 21:39:22 UTC (rev 2225)
@@ -0,0 +1,187 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          mop.lisp
+;;;; Purpose:       Imports standard MOP symbols into KMRCL
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Apr 2003
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; KMRCL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+;;; This file imports MOP symbols into KMR-MOP packages and then
+;;; re-exports them to hide differences in MOP implementations.
+
+(in-package #:cl-user)
+
+#+sbcl
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (if (find-package 'sb-mop)
+      (pushnew :kmr-sbcl-mop cl:*features*)
+      (pushnew :kmr-sbcl-pcl cl:*features*)))
+
+#+cmu
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (if (eq (symbol-package 'pcl:find-class)
+          (find-package 'common-lisp))
+      (pushnew :kmr-cmucl-mop cl:*features*)
+      (pushnew :kmr-cmucl-pcl cl:*features*)))
+
+(defpackage #:kmr-mop
+  (:use
+   #:cl
+   #:kmrcl
+   #+kmr-sbcl-mop #:sb-mop
+   #+kmr-cmucl-mop #:mop
+   #+allegro #:mop
+   #+lispworks #:clos
+   #+clisp #:clos
+   #+scl #:clos
+   #+openmcl #:openmcl-mop
+   )
+  )
+
+(in-package #:kmr-mop)
+
+#+lispworks
+(defun intern-eql-specializer (slot)
+  `(eql ,slot))
+
+(defmacro process-class-option (metaclass slot-name &optional required)
+  #+lispworks
+  `(defmethod clos:process-a-class-option ((class ,metaclass)
+                                           (name (eql ,slot-name))
+                                           value)
+    (when (and ,required (null value))
+      (error "metaclass ~A class slot ~A must have a value" (quote ,metaclass) name))
+    (list name `',value))
+  #-lispworks
+  (declare (ignore metaclass slot-name required))
+  )
+
+(defmacro process-slot-option (metaclass slot-name)
+  #+lispworks
+  `(defmethod clos:process-a-slot-option ((class ,metaclass)
+                                          (option (eql ,slot-name))
+                                          value
+                                          already-processed-options
+                                          slot)
+    (list* option `',value already-processed-options))
+  #-lispworks
+  (declare (ignore metaclass slot-name))
+  )
+
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (shadowing-import
+   #+allegro
+   '(excl::compute-effective-slot-definition-initargs)
+   #+lispworks
+   '(clos::compute-effective-slot-definition-initargs)
+   #+clisp
+   '(clos::compute-effective-slot-definition-initargs)
+   #+sbcl
+   '(#+kmr-sbcl-mop class-of #-kmr-sbcl-mop sb-pcl:class-of
+     #+kmr-sbcl-mop class-name #-kmr-sbcl-mop sb-pcl:class-name
+     #+kmr-sbcl-mop class-slots #-kmr-sbcl-mop sb-pcl:class-slots
+     #+kmr-sbcl-mop find-class #-kmr-sbcl-mop sb-pcl:find-class
+     sb-pcl::standard-class
+     sb-pcl:slot-definition-name sb-pcl::finalize-inheritance
+     sb-pcl::standard-direct-slot-definition
+     sb-pcl::standard-effective-slot-definition sb-pcl::validate-superclass
+     sb-pcl::direct-slot-definition-class
+     sb-pcl::effective-slot-definition-class
+     sb-pcl::compute-effective-slot-definition
+     sb-pcl:class-direct-slots
+     sb-pcl::compute-effective-slot-definition-initargs
+     sb-pcl::slot-value-using-class
+     sb-pcl:class-prototype sb-pcl:generic-function-method-class sb-pcl:intern-eql-specializer
+     sb-pcl:make-method-lambda sb-pcl:generic-function-lambda-list
+     sb-pcl::compute-slots)
+   #+cmu
+   '(pcl:class-of  pcl:class-name pcl:class-slots pcl:find-class pcl::standard-class
+     pcl::slot-definition-name pcl:finalize-inheritance
+     pcl::standard-direct-slot-definition pcl::standard-effective-slot-definition
+     pcl::validate-superclass pcl:direct-slot-definition-class pcl::effective-slot-definition-class
+     pcl:compute-effective-slot-definition
+     pcl:class-direct-slots
+     pcl::compute-effective-slot-definition-initargs
+     pcl::slot-value-using-class
+     pcl:class-prototype pcl:generic-function-method-class pcl:intern-eql-specializer
+     pcl:make-method-lambda pcl:generic-function-lambda-list
+     pcl::compute-slots)
+   #+scl
+   '(class-of class-name class-slots find-class clos::standard-class
+     clos::slot-definition-name clos:finalize-inheritance
+     clos::standard-direct-slot-definition clos::standard-effective-slot-definition
+     clos::effective-slot-definition-class
+     clos:class-direct-slots
+     clos::validate-superclass clos:direct-slot-definition-class
+     clos:compute-effective-slot-definition
+     clos::compute-effective-slot-definition-initargs
+     clos::slot-value-using-class
+     clos::class-prototype clos:generic-function-method-class clos:intern-eql-specializer
+     clos:make-method-lambda clos:generic-function-lambda-list
+     clos::compute-slots
+     ;; note: make-method-lambda is not fbound
+     )
+   #+openmcl
+   '(openmcl-mop::slot-definition-name openmcl-mop:finalize-inheritance
+     openmcl-mop::standard-direct-slot-definition openmcl-mop::standard-effective-slot-definition
+     openmcl-mop::validate-superclass openmcl-mop:direct-slot-definition-class openmcl-mop::effective-slot-definition-class
+     openmcl-mop:compute-effective-slot-definition
+     openmcl-mop:class-direct-slots
+     openmcl-mop::compute-effective-slot-definition-initargs
+     openmcl-mop::slot-value-using-class
+     openmcl-mop:class-prototype openmcl-mop:generic-function-method-class openmcl-mop:intern-eql-specializer
+     openmcl-mop:make-method-lambda openmcl-mop:generic-function-lambda-list
+     openmcl-mop::compute-slots)   ))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (export '(class-of class-name class-slots find-class
+            standard-class
+            slot-definition-name finalize-inheritance
+            standard-direct-slot-definition
+            standard-effective-slot-definition validate-superclass
+            compute-effective-slot-definition-initargs
+            direct-slot-definition-class effective-slot-definition-class
+            compute-effective-slot-definition
+            slot-value-using-class
+            class-prototype generic-function-method-class intern-eql-specializer
+            make-method-lambda generic-function-lambda-list
+            compute-slots
+            class-direct-slots
+            ;; KMR-MOP encapsulating macros
+            process-slot-option
+            process-class-option))
+
+  #+sbcl
+  (if (find-package 'sb-mop)
+      (setq cl:*features* (delete :kmr-sbcl-mop cl:*features*))
+      (setq cl:*features* (delete :kmr-sbcl-pcl cl:*features*)))
+
+  #+cmu
+  (if (find-package 'mop)
+      (setq cl:*features* (delete :kmr-cmucl-mop cl:*features*))
+      (setq cl:*features* (delete :kmr-cmucl-pcl cl:*features*)))
+
+  (when (>= (length (generic-function-lambda-list
+                     (ensure-generic-function
+                      'compute-effective-slot-definition)))
+            3)
+    (pushnew :kmr-normal-cesd cl:*features*))
+
+  (when (>= (length (generic-function-lambda-list
+                     (ensure-generic-function
+                      'direct-slot-definition-class)))
+            3)
+    (pushnew :kmr-normal-dsdc cl:*features*))
+
+  )  ;; eval-when
Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/os.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/kmrcl-1.97/os.lisp	2007-10-06 21:23:47 UTC (rev 2224)
+++ branches/trunk-reorg/thirdparty/kmrcl-1.97/os.lisp	2007-10-06 21:39:22 UTC (rev 2225)
@@ -0,0 +1,179 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          os.lisp
+;;;; Purpose:       Operating System utilities
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Jul 2003
+;;;;
+;;;; $Id$
+;;;;
+;;;; *************************************************************************
+
+(in-package #:kmrcl)
+
+(defun command-output (control-string &rest args)
+  "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
+synchronously execute the result using a Bourne-compatible shell,
+returns (VALUES string-output error-output exit-status)"
+  (let ((command (apply #'format nil control-string args)))
+    #+sbcl
+    (let* ((process (sb-ext:run-program
+                    "/bin/sh"
+                    (list "-c" command)
+                    :input nil :output :stream :error :stream))
+           (output (read-stream-to-string (sb-impl::process-output process)))
+           (error (read-stream-to-string (sb-impl::process-error process))))
+      (close (sb-impl::process-output process))
+      (close (sb-impl::process-error process))
+      (values
+       output
+       error
+       (sb-impl::process-exit-code process)))
+
+
+    #+(or cmu scl)
+    (let* ((process (ext:run-program
+                     "/bin/sh"
+                     (list "-c" command)
+                     :input nil :output :stream :error :stream))
+           (output (read-stream-to-string (ext::process-output process)))
+           (error (read-stream-to-string (ext::process-error process))))
+      (close (ext::process-output process))
+      (close (ext::process-error process))
+
+      (values
+       output
+       error
+       (ext::process-exit-code process)))
+
+    #+allegro
+    (multiple-value-bind (output error status)
+        (excl.osi:command-output command :whole t)
+      (values output error status))
+
+    #+lispworks
+    ;; BUG: Lispworks combines output and error streams
+    (let ((output (make-string-output-stream)))
+      (unwind-protect
+          (let ((status
+                 (system:call-system-showing-output
+                  command
+                  :prefix ""
+                  :show-cmd nil
+                  :output-stream output)))
+            (values (get-output-stream-string output) nil status))
+        (close output)))
+
+    #+clisp
+    ;; BUG: CLisp doesn't allow output to user-specified stream
+    (values
+     nil
+     nil
+     (ext:run-shell-command  command :output :terminal :wait t))
+
+    #+openmcl
+    (let* ((process (ccl:run-program
+                     "/bin/sh"
+                     (list "-c" command)
+                     :input nil :output :stream :error :stream
+                     :wait t))
+           (output (read-stream-to-string (ccl::external-process-output-stream process)))
+           (error (read-stream-to-string (ccl::external-process-error-stream process))))
+      (close (ccl::external-process-output-stream process))
+      (close (ccl::external-process-error-stream process))
+      (values output
+              error
+              (nth-value 1 (ccl::external-process-status process))))
+
+    #-(or openmcl clisp lispworks allegro scl cmu sbcl)
+    (error "COMMAND-OUTPUT not implemented for this Lisp")
+
+    ))
+
+(defun run-shell-command (control-string &rest args)
+  "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
+synchronously execute the result using a Bourne-compatible shell,
+returns (VALUES output-string pid)"
+  (let ((command (apply #'format nil control-string args)))
+    #+sbcl
+    (sb-impl::process-exit-code
+     (sb-ext:run-program
+      "/bin/sh"
+      (list  "-c" command)
+      :input nil :output nil))
+
+    #+(or cmu scl)
+    (ext:process-exit-code
+     (ext:run-program
+      "/bin/sh"
+      (list  "-c" command)
+      :input nil :output nil))
+
+
+    #+allegro
+    (excl:run-shell-command command :input nil :output nil
+                            :wait t)
+
+    #+lispworks
+    (system:call-system-showing-output
+     command
+     :shell-type "/bin/sh"
+     :show-cmd nil
+     :prefix ""
+     :output-stream nil)
+
+    #+clisp             ;XXX not exactly *verbose-out*, I know
+    (ext:run-shell-command  command :output :terminal :wait t)
+
+    #+openmcl
+    (nth-value 1
+               (ccl:external-process-status
+                (ccl:run-program "/bin/sh" (list "-c" command)
+                                 :input nil :output nil
+                                 :wait t)))
+
+    #-(or openmcl clisp lispworks allegro scl cmu sbcl)
+    (error "RUN-SHELL-PROGRAM not implemented for this Lisp")
+
+    ))
+
+(defun delete-directory-and-files (dir &key (if-does-not-exist :error) (quiet t) force)
+  #+allegro (excl:delete-directory-and-files dir :if-does-not-exist if-does-not-exist
+                                             :quiet quiet :force force)
+  #-(or allegro) (declare (ignore force))
+  #-(or allegro) (cond
+                   ((probe-directory dir)
+                    (let ((cmd (format nil "rm -rf ~A" (namestring dir))))
+                      (unless quiet
+                        (format *trace-output* ";; ~A" cmd))
+                      (command-output cmd)))
+                   ((eq if-does-not-exist :error)
+                    (error "Directory ~A does not exist [delete-directory-and-files]." dir))))
+
+(defun file-size (file)
+  (when (probe-file file)
+    #+allegro (let ((stat (excl.osi:stat (namestring file))))
+                (excl.osi:stat-size stat))
+    #-allegro
+    (with-open-file (in file :direction :input)
+      (file-length in))))
+
+(defun getpid ()
+  "Return the PID of the lisp process."
+  #+allegro (excl::getpid)
+  #+(and lispworks win32) (win32:get-current-process-id)
+  #+(and lispworks (not win32)) (system::getpid)
+  #+sbcl (sb-posix:getpid)
+  #+cmu (unix:unix-getpid)
+  #+openmcl (ccl::getpid)
+  #+(and clisp unix) (system::process-id)
+  #+(and clisp win32) (cond ((find-package :win32)
+                             (funcall (find-symbol "GetCurrentProcessId"
+                                                   :win32)))
+                            (t
+                             (system::getenv "PID")))
+  )
+
+
Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/package.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/kmrcl-1.97/package.lisp	2007-10-06 21:23:47 UTC (rev 2224)
+++ branches/trunk-reorg/thirdparty/kmrcl-1.97/package.lisp	2007-10-06 21:39:22 UTC (rev 2225)
@@ -0,0 +1,324 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          package.lisp
+;;;; Purpose:       Package definition for kmrcl package
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Apr 2000
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of KMRCL, is Copyright (c) 2002-2006 by Kevin M. Rosenberg
+;;;;
+;;;; KMRCL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(in-package #:cl-user)
+
+(defpackage #:kmrcl
+  (:nicknames #:kl)
+  (:use #:cl)
+  (:export
+   #:ensure-integer
+   #:mklist
+   #:filter
+   #:map-and-remove-nils
+   #:appendnew
+   #:memo-proc
+   #:memoize
+   #:defun-memo
+   #:_f
+   #:compose
+   #:until
+   #:while
+   #:for
+
+   ;; strings.lisp
+   #:string-trim-whitespace
+   #:string-left-trim-whitespace
+   #:string-right-trim-whitespace
+   #:mapappend
+   #:mapcar-append-string
+   #:mapcar2-append-string
+   #:position-char
+   #:position-not-char
+   #:delimited-string-to-list
+   #:string-delimited-string-to-list
+   #:list-to-delimited-string
+   #:prefixed-fixnum-string
+   #:prefixed-integer-string
+   #:integer-string
+   #:fast-string-search
+   #:string-substitute
+   #:string-to-list-skip-delimiter
+   #:string-starts-with
+   #:count-string-char
+   #:count-string-char-if
+   #:hexchar
+   #:charhex
+   #:encode-uri-string
+   #:decode-uri-string
+   #:uri-query-to-alist
+   #:non-alphanumericp
+   #:random-string
+   #:first-char
+   #:last-char
+   #:ensure-string
+   #:string-right-trim-one-char
+   #:string-strip-ending
+   #:string-maybe-shorten
+   #:string-elide
+   #:shrink-vector
+   #:collapse-whitespace
+   #:string->list
+   #:trim-non-alphanumeric
+   #:binary-sequence-to-hex-string
+
+   ;; io.lisp
+   #:indent-spaces
+   #:indent-html-spaces
+   #:print-n-chars
+   #:print-n-strings
+   #:print-list
+   #:print-rows
+   #:write-fixnum
+   #:file-subst
+   #:stream-subst
+   #:null-output-stream
+   #:directory-tree
+   #:write-utime-hms
+   #:write-utime-hm
+   #:write-utime-ymdhms
+   #:write-utime-ymdhm
+   #:write-utime-hms-stream
+   #:write-utime-hm-stream
+   #:write-utime-ymdhms-stream
+   #:write-utime-ymdhm-stream
+   #:with-utime-decoding
+   #:with-utime-decoding-utc-offset
+   #:is-dst
+   #:year
+   #:month
+   #:day-of-month
+   #:hour
+   #:minute
+   #:second
+   #:daylight-p
+   #:zone
+   #:day-of-month
+   #:day-of-week
+   #:+datetime-number-strings+
+   #:utc-offset
+   #:copy-binary-stream
+
+   ;; impl.lisp
+   #:probe-directory
+   #:cwd
+   #:quit
+   #:command-line-arguments
+   #:copy-file
+   #:run-shell-command
+
+   ;; lists.lisp
+   #:remove-from-tree-if
+   #:find-tree
+   #:with-each-file-line
+   #:with-each-stream-line
+   #:remove-keyword
+   #:remove-keywords
+   #:append-sublists
+   #:alist-elem-p
+   #:alistp
+   #:get-alist
+   #:update-alist
+   #:alist-plist
+   #:plist-alist
+   #:update-plist
+   #:get-plist
+   #:flatten
+   #:unique-slot-values
+
+   ;; seq.lisp
+   #:nsubseq
+
+   ;; math.lisp
+   #:ensure-integer
+   #:histogram
+   #:fixnum-width
+   #:scaled-epsilon
+   #:sinc
+   #:numbers-within-percentage
+
+   ;; macros.lisp
+   #:time-iterations
+   #:time-seconds
+   #:in
+   #:mean
+   #:with-gensyms
+   #:let-if
+   #:let-when
+   #:aif
+   #:awhen
+   #:awhile
+   #:aand
+   #:acond
+   #:alambda
+   #:it
+   #:mac
+   #:mv-bind
+   #:deflex
+   #:def-cached-vector
+   #:def-cached-instance
+   #:with-ignore-errors
+   #:ppmx
+   #:defconstant*
+   #:defvar-unbound
+
+   ;; files.lisp
+   #:print-file-contents
+   #:read-stream-to-string
+   #:read-file-to-string
+   #:read-file-to-usb8-array
+   #:read-stream-to-strings
+   #:read-file-to-strings
+
+   ;; strings.lisp
+   #:string-append
+   #:count-string-words
+   #:substitute-string-for-char
+   #:string-trim-last-character
+   #:nstring-trim-last-character
+   #:string-hash
+   #:is-string-empty
+   #:is-char-whitespace
+   #:not-whitespace-char
+   #:is-string-whitespace
+   #:string-invert
+   #:escape-xml-string
+   #:make-usb8-array
+   #:usb8-array-to-string
+   #:string-to-usb8-array
+   #:substitute-chars-strings
+   #:add-sql-quotes
+   #:escape-backslashes
+   #:concat-separated-strings
+   #:print-separated-strings
+   #:lex-string
+   #:split-alphanumeric-string
+
+   ;; strmatch.lisp
+   #:score-multiword-match
+   #:multiword-match
+
+   ;; symbols.lisp
+   #:ensure-keyword
+   #:ensure-keyword-upcase
+   #:ensure-keyword-default-case
+   #:concat-symbol
+   #:concat-symbol-pkg
+   #:show
+   #:show-variables
+   #:show-functions
+
+   ;; From attrib-class.lisp
+   #:attributes-class
+   #:slot-attribute
+   #:slot-attributes
+
+   #:generalized-equal
+
+   ;; From buffered input
+
+   #:make-fields-buffer
+   #:read-buffered-fields
+
+   ;; From datetime.lisp
+   #:pretty-date-ut
+   #:pretty-date
+   #:date-string
+   #:print-float-units
+   #:print-seconds
+   #:posix-time-to-utime
+   #:utime-to-posix-time
+
+   ;; From random.lisp
+   #:seed-random-generator
+   #:random-choice
+
+   ;; From repl.lisp
+   #:make-repl
+   #:init/repl
+
+   ;; From web-utils
+   #:*base-url*
+   #:base-url!
+   #:make-url
+   #:*standard-html-header*
+   #:*standard-xhtml-header*
+   #:*standard-xml-header*
+   #:user-agent-ie-p
+   #:decode-uri-query-string
+   #:split-uri-query-string
+
+   ;; From xml-utils
+   #:sgml-header-stream
+   #:xml-tag-contents
+   #:positions-xml-tag-contents
+   #:cdata-string
+   #:write-cdata
+
+   ;; From console
+   #:*console-msgs*
+   #:cmsg
+   #:cmsg-c
+   #:cmsg-add
+   #:cmsg-remove
+   #:fixme
+
+   ;; byte-stream
+   #:make-binary-array-output-stream
+   #:get-output-stream-data
+   #:dump-output-stream-data
+   #:make-byte-array-input-stream
+
+   ;; sockets.lisp
+   #:make-active-socket
+   #:close-active-socket
+
+   ;; listener.lisp
+   #:init/listener
+   #:stop-all/listener
+   #:listener
+
+   ;; fformat.lisp
+   #:fformat
+
+   ;; os.lisp
+   #:command-output
+   #:run-shell-command-output-stream
+   #:delete-directory-and-files
+   #:file-size
+   #:getpid
+
+   ;; color.lisp
+   #:rgb->hsv
+   #:rgb255->hsv255
+   #:hsv->rgb
+   #:hsv255->rgb255
+   #:hsv-equal
+   #:hsv255-equal
+   #:hsv-similar
+   #:hsv255-similar
+   #:hue-difference
+   #:hue-difference-fixnum
+
+   ;; signals.lisp
+   #:set-signal-handler
+   #:remove-signal-handler
+   ))
+
+
+
Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/processes.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/kmrcl-1.97/processes.lisp	2007-10-06 21:23:47 UTC (rev 2224)
+++ branches/trunk-reorg/thirdparty/kmrcl-1.97/processes.lisp	2007-10-06 21:39:22 UTC (rev 2225)
@@ -0,0 +1,76 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: modlisp -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          processes.lisp
+;;;; Purpose:       Multiprocessing functions
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  June 2003
+;;;;
+;;;; $Id$
+;;;; *************************************************************************
+
+(in-package #:kmrcl)
+
+
+(defun make-process (name func)
+  #+allegro (mp:process-run-function name func)
+  #+cmu (mp:make-process func :name name)
+  #+lispworks (mp:process-run-function name nil func)
+  #+sb-thread (sb-thread:make-thread func :name name)
+  #+openmcl (ccl:process-run-function name func)
+  #-(or allegro cmu lispworks sb-thread openmcl) (funcall func)
+  )
+
+(defun destroy-process (process)
+  #+cmu (mp:destroy-process process)
+  #+allegro (mp:process-kill process)
+  #+sb-thread (sb-thread:destroy-thread process)
+  #+lispworks (mp:process-kill process)
+  #+openmcl (ccl:process-kill process)
+  )
+
+(defun make-lock (name)
+  #+allegro (mp:make-process-lock :name name)
+  #+cmu (mp:make-lock name)
+  #+lispworks (mp:make-lock :name name)
+  #+sb-thread (sb-thread:make-mutex :name name)
+  #+openmcl (ccl:make-lock name)
+  )
+
+(defmacro with-lock-held ((lock) &body body)
+  #+allegro
+  `(mp:with-process-lock (,lock) ,@body)
+  #+cmu
+  `(mp:with-lock-held (,lock) ,@body)
+  #+lispworks
+  `(mp:with-lock (,lock) ,@body)
+  #+sb-thread
+  `(sb-thread:with-recursive-lock (,lock) ,@body)
+  #+openmcl
+  `(ccl:with-lock-grabbed (,lock) ,@body)
+  #-(or allegro cmu lispworks sb-thread openmcl)
+  `(progn ,@body)
+  )
+
+
+(defmacro with-timeout ((seconds) &body body)
+  #+allegro
+  `(mp:with-timeout (,seconds) ,@body)
+  #+cmu
+  `(mp:with-timeout (,seconds) ,@body)
+  #+sb-thread
+  `(sb-ext:with-timeout ,seconds ,@body)
+  #+openmcl
+  `(ccl:process-wait-with-timeout "waiting"
+                                 (* ,seconds ccl:*ticks-per-second*)
+                                 #'(lambda ()
+                                     ,@body) nil)
+  #-(or allegro cmu sb-thread openmcl)
+  `(progn ,@body)
+  )
+
+(defun process-sleep (n)
+  #+allegro (mp:process-sleep n)
+  #-allegro (sleep n))
+
Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/random.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/kmrcl-1.97/random.lisp	2007-10-06 21:23:47 UTC (rev 2224)
+++ branches/trunk-reorg/thirdparty/kmrcl-1.97/random.lisp	2007-10-06 21:39:22 UTC (rev 2225)
@@ -0,0 +1,47 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          random.lisp
+;;;; Purpose:       Random number functions for KMRCL package
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Apr 2000
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; KMRCL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(in-package #:kmrcl)
+
+(defun seed-random-generator ()
+  "Evaluate a random number of items"
+  (let ((randfile (make-pathname
+                   :directory '(:absolute "dev")
+                   :name "urandom")))
+    (setf *random-state* (make-random-state t))
+    (if (probe-file randfile)
+        (with-open-file
+            (rfs randfile :element-type 'unsigned-byte)
+          (let*
+              ;; ((seed (char-code (read-char rfs))))
+              ((seed (read-byte rfs)))
+            ;;(format t "Randomizing!~%")
+            (loop
+                for item from 1 to seed
+                do (loop
+                       for it from 0 to (+ (read-byte rfs) 5)
+                       do (random 65536))))))))
+
+
+(defmacro random-choice (&rest exprs)
+  `(case (random ,(length exprs))
+     ,@(let ((key -1))
+         (mapcar #'(lambda (expr)
+                     `(,(incf key) ,expr))
+                 exprs))))
+
Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/repl.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/kmrcl-1.97/repl.lisp	2007-10-06 21:23:47 UTC (rev 2224)
+++ branches/trunk-reorg/thirdparty/kmrcl-1.97/repl.lisp	2007-10-06 21:39:22 UTC (rev 2225)
@@ -0,0 +1,96 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          repl.lisp
+;;;; Purpose:       A repl server
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Apr 2000
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; KMRCL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(in-package #:kmrcl)
+
+(defconstant +default-repl-server-port+ 4000)
+
+(defclass repl ()
+  ((listener :initarg :listener :accessor listener
+             :initform nil)))
+
+(defun make-repl (&key (port +default-repl-server-port+)
+                       announce user-checker remote-host-checker)
+  (make-instance 'listener
+    :port port
+    :base-name "repl"
+    :function 'repl-worker
+    :function-args (list user-checker announce)
+    :format :text
+    :wait nil
+    :remote-host-checker remote-host-checker
+    :catch-errors nil))
+
+(defun init/repl (repl state)
+  (init/listener repl state))
+
+
+(defun repl-worker (conn user-checker announce)
+  (when announce
+    (format conn "~A~%" announce)
+    (force-output conn))
+  (when user-checker
+    (let (login password)
+      (format conn "login: ")
+      (finish-output conn)
+      (setq login (read-socket-line conn))
+      (format conn "password: ")
+      (finish-output conn)
+      (setq password (read-socket-line conn))
+      (unless (funcall user-checker login password)
+        (format conn "Invalid login~%")
+        (finish-output conn)
+        (return-from repl-worker))))
+  #+allegro
+  (tpl::start-interactive-top-level
+   conn
+   #'tpl::top-level-read-eval-print-loop
+   nil)
+  #-allegro
+  (repl-on-stream conn)
+  )
+
+(defun read-socket-line (stream)
+  (string-right-trim-one-char #\return
+                              (read-line stream nil nil)))
+
+(defun print-prompt (stream)
+  (format stream "~&~A> " (package-name *package*))
+  (force-output stream))
+
+(defun repl-on-stream (stream)
+  (let ((*standard-input* stream)
+        (*standard-output* stream)
+        (*terminal-io* stream)
+        (*debug-io* stream))
+    #|
+    #+sbcl
+    (if (and (find-package 'sb-aclrepl)
+             (fboundp (intern "REPL-FUN" "SB-ACLREPL")))
+        (sb-aclrepl::repl-fun)
+        (%repl))
+    #-sbcl
+    |#
+    (%repl)))
+
+(defun %repl ()
+  (loop
+    (print-prompt *standard-output*)
+    (let ((form (read *standard-input*)))
+      (format *standard-output* "~&~S~%" (eval form)))))
+
Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/run-tests.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/kmrcl-1.97/run-tests.lisp	2007-10-06 21:23:47 UTC (rev 2224)
+++ branches/trunk-reorg/thirdparty/kmrcl-1.97/run-tests.lisp	2007-10-06 21:39:22 UTC (rev 2225)
@@ -0,0 +1,24 @@
+(in-package #:cl-user)
+(defpackage #:run-tests (:use #:cl))
+(in-package #:run-tests)
+
+(require 'rt)
+(load "kmrcl.asd")
+(load "kmrcl-tests.asd")
+(asdf:oos 'asdf:test-op 'kmrcl)
+
+(defun quit (&optional (code 0))
+  "Function to exit the Lisp implementation. Copied from CLOCC's QUIT function."
+    #+allegro (excl:exit code)
+    #+clisp (#+lisp=cl ext:quit #-lisp=cl lisp:quit code)
+    #+(or cmu scl) (ext:quit code)
+    #+cormanlisp (win32:exitprocess code)
+    #+gcl (lisp:bye code)
+    #+lispworks (lw:quit :status code)
+    #+lucid (lcl:quit code)
+    #+sbcl (sb-ext:quit :unix-status (typecase code (number code) (null 0) (t 1)))
+    #+mcl (ccl:quit code)
+    #-(or allegro clisp cmu scl cormanlisp gcl lispworks lucid sbcl mcl)
+    (error 'not-implemented :proc (list 'quit code)))
+
+(quit)
Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/seqs.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/kmrcl-1.97/seqs.lisp	2007-10-06 21:23:47 UTC (rev 2224)
+++ branches/trunk-reorg/thirdparty/kmrcl-1.97/seqs.lisp	2007-10-06 21:39:22 UTC (rev 2225)
@@ -0,0 +1,28 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          seqs.lisp
+;;;; Purpose:       Sequence functions for KMRCL package
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Apr 2000
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; KMRCL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(in-package :kmrcl)
+
+
+(defun nsubseq (sequence start &optional end)
+  "Return a subsequence by pointing to location in original sequence"
+  (unless end (setq end (length sequence)))
+  (make-array (- end start)
+              :element-type (array-element-type sequence)
+              :displaced-to sequence
+              :displaced-index-offset start))
Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/signals.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/kmrcl-1.97/signals.lisp	2007-10-06 21:23:47 UTC (rev 2224)
+++ branches/trunk-reorg/thirdparty/kmrcl-1.97/signals.lisp	2007-10-06 21:39:22 UTC (rev 2225)
@@ -0,0 +1,74 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: modlisp -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          signals.lisp
+;;;; Purpose:       Signal processing functions
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Jan 2007
+;;;;
+;;;; $Id: processes.lisp 10985 2006-07-26 18:52:03Z kevin $
+;;;; *************************************************************************
+
+(in-package #:kmrcl)
+
+(defun signal-key-to-number (sig)
+  "These signals and numbers are only valid on POSIX systems, perhaps
+some are Linux-specific."
+  (case sig
+    (:hup 1)
+    (:int 2)
+    (:quit 3)
+    (:kill 9)
+    (:usr1 10)
+    (:usr2 12)
+    (:pipe 13)
+    (:alrm 14)
+    (:term 15)
+    (t
+     (error "Signal ~A not known." sig))))
+
+
+(defun set-signal-handler (sig handler)
+  "Sets the handler for a signal to a function. Where possible, returns
+the old handler for the function for later restoration with remove-signal-handler
+below.
+
+To be portable, signal handlers should use (&rest dummy) function signatures
+and ignore the value. They should return T to tell some Lisp implementations (Allegro)
+that the signal was successfully handled."
+  (let ((signum (etypecase sig
+                  (integer sig)
+                  (keyword (signal-key-to-number sig)))))
+    #+allegro (excl:add-signal-handler signum handler)
+    #+cmu (system:enable-interrupt signum handler)
+    #+(and lispworks unix)
+    ;; non-documented method to get old handler, works in lispworks 5
+    (let ((old-handler (when (and (boundp 'system::*signal-handler-functions*)
+                                  (typep system::*signal-handler-functions* 'array))
+                         (aref system::*signal-handler-functions* signum))))
+      (system:set-signal-handler signum handler)
+      old-handler)
+    #+sbcl (sb-sys:enable-interrupt signum handler)
+    #-(or allegro cmu (and lispworks unix) sbcl)
+    (declare (ignore sig handler))
+    #-(or allegro cmu (and lispworks unix) sbcl)
+    (warn "Signal setting not supported on this platform.")))
+
+(defun remove-signal-handler (sig &optional old-handler)
+  "Removes a handler from signal. Tries, when possible, to restore old-handler."
+  (let ((signum (etypecase sig
+                  (integer sig)
+                  (keyword (signal-key-to-number sig)))))
+    ;; allegro automatically restores old handler, because set-signal-handler above
+    ;; actually pushes the new handler onto a list of handlers
+    #+allegro (declare (ignore old-handler))
+    #+allegro (excl:remove-signal-handler signum)
+    #+cmu (system:enable-interrupt signum (or old-handler :default))
+    ;; lispworks removes handler if old-handler is nil
+    #+(and lispworks unix) (system:set-signal-handler signum old-handler)
+    #+sbcl (sb-sys:enable-interrupt signum (or old-handler :default))
+    #-(or allegro cmu (and lispworks unix) sbcl)
+    (declare (ignore sig handler))
+    #-(or allegro cmu (and lispworks unix) sbcl)
+    (warn "Signal setting not supported on this platform.")))
Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/sockets.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/kmrcl-1.97/sockets.lisp	2007-10-06 21:23:47 UTC (rev 2224)
+++ branches/trunk-reorg/thirdparty/kmrcl-1.97/sockets.lisp	2007-10-06 21:39:22 UTC (rev 2225)
@@ -0,0 +1,219 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: modlisp -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          sockets.lisp
+;;;; Purpose:       Socket functions
+;;;; Programmer:    Kevin M. Rosenberg with excerpts from portableaserve
+;;;; Date Started:  Jun 2003
+;;;;
+;;;; $Id$
+;;;; *************************************************************************
+
+(in-package #:kmrcl)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  #+sbcl (require :sb-bsd-sockets)
+  #+lispworks (require "comm")
+  #+allegro (require :socket))
+
+
+#+sbcl
+(defun listen-to-inet-port (&key (port 0) (kind :stream) (reuse nil))
+  "Create, bind and listen to an inet socket on *:PORT.
+setsockopt SO_REUSEADDR if :reuse is not nil"
+  (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
+                               :type :stream
+                               :protocol :tcp)))
+    (if reuse
+        (setf (sb-bsd-sockets:sockopt-reuse-address socket) t))
+    (sb-bsd-sockets:socket-bind
+     socket (sb-bsd-sockets:make-inet-address "0.0.0.0") port)
+    (sb-bsd-sockets:socket-listen socket 15)
+    socket))
+
+(defun create-inet-listener (port &key (format :text) (reuse-address t))
+  #+cmu (declare (ignore format reuse-address))
+  #+cmu (ext:create-inet-listener port)
+  #+allegro
+  (socket:make-socket :connect :passive :local-port port :format format
+                      :address-family
+                      (if (stringp port)
+                          :file
+                        (if (or (null port) (integerp port))
+                            :internet
+                          (error "illegal value for port: ~s" port)))
+                      :reuse-address reuse-address)
+  #+sbcl (declare (ignore format))
+  #+sbcl (listen-to-inet-port :port port :reuse reuse-address)
+  #+clisp (declare (ignore format reuse-address))
+  #+clisp (ext:socket-server port)
+  #+openmcl
+  (declare (ignore format))
+  #+openmcl
+  (ccl:make-socket :connect :passive :local-port port
+                   :reuse-address reuse-address)
+  #-(or allegro clisp cmu sbcl openmcl)
+  (warn "create-inet-listener not supported on this implementation")
+  )
+
+(defun make-fd-stream (socket &key input output element-type)
+  #+cmu
+  (sys:make-fd-stream socket :input input :output output
+                      :element-type element-type)
+  #+sbcl
+  (sb-bsd-sockets:socket-make-stream socket :input input :output output
+                                     :element-type element-type)
+  #-(or cmu sbcl) (declare (ignore input output element-type))
+  #-(or cmu sbcl) socket
+  )
+
+
+(defun accept-tcp-connection (listener)
+  "Returns (VALUES stream socket)"
+  #+allegro
+  (let ((sock (socket:accept-connection listener)))
+    (values sock sock))
+  #+clisp
+  (let ((sock (ext:socket-accept listener)))
+    (values sock sock))
+  #+cmu
+  (progn
+    (mp:process-wait-until-fd-usable listener :input)
+    (let ((sock (nth-value 0 (ext:accept-tcp-connection listener))))
+      (values (sys:make-fd-stream sock :input t :output t) sock)))
+  #+sbcl
+  (when (sb-sys:wait-until-fd-usable
+         (sb-bsd-sockets:socket-file-descriptor listener) :input)
+    (let ((sock (sb-bsd-sockets:socket-accept listener)))
+      (values
+       (sb-bsd-sockets:socket-make-stream
+        sock :element-type :default :input t :output t)
+       sock)))
+  #+openmcl
+  (let ((sock (ccl:accept-connection listener :wait t)))
+    (values sock sock))
+  #-(or allegro clisp cmu sbcl openmcl)
+  (warn "accept-tcp-connection not supported on this implementation")
+  )
+
+
+(defmacro errorset (form display)
+  `(handler-case
+    ,form
+    (error (e)
+     (declare (ignorable e))
+     (when ,display
+       (format t "~&Error: ~A~%" e)))))
+
+(defun close-passive-socket (socket)
+  #+allegro (close socket)
+  #+clisp (ext:socket-server-close socket)
+  #+cmu (unix:unix-close socket)
+  #+sbcl (sb-unix:unix-close
+          (sb-bsd-sockets:socket-file-descriptor socket))
+  #+openmcl (close socket)
+  #-(or allegro clisp cmu sbcl openmcl)
+  (warn "close-passive-socket not supported on this implementation")
+  )
+
+
+(defun close-active-socket (socket)
+  #+sbcl (sb-bsd-sockets:socket-close socket)
+  #-sbcl (close socket))
+
+(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 dotted-to-ipaddr (dotted &key (errorp t))
+  "Convert from dotted string to 32-bit integer."
+  (declare (string dotted))
+  (if errorp
+      (let ((ll (delimited-string-to-list dotted #.)))
+        (+ (ash (parse-integer (first ll)) 24)
+           (ash (parse-integer (second ll)) 16)
+           (ash (parse-integer (third ll)) 8)
+           (parse-integer (fourth ll))))
+    (ignore-errors
+      (let ((ll (delimited-string-to-list dotted #.)))
+        (+ (ash (parse-integer (first ll)) 24)
+           (ash (parse-integer (second ll)) 16)
+           (ash (parse-integer (third ll)) 8)
+           (parse-integer (fourth ll)))))))
+
+#+sbcl
+(defun ipaddr-to-hostname (ipaddr &key ignore-cache)
+  (when ignore-cache
+    (warn ":IGNORE-CACHE keyword in IPADDR-TO-HOSTNAME not supported."))
+  (sb-bsd-sockets:host-ent-name
+   (sb-bsd-sockets:get-host-by-address
+    (sb-bsd-sockets:make-inet-address ipaddr))))
+
+#+sbcl
+(defun lookup-hostname (host &key ignore-cache)
+  (when ignore-cache
+    (warn ":IGNORE-CACHE keyword in LOOKUP-HOSTNAME not supported."))
+  (if (stringp host)
+      (sb-bsd-sockets:host-ent-address
+       (sb-bsd-sockets:get-host-by-name host))
+      (dotted-to-ipaddr (ipaddr-to-dotted host))))
+
+
+(defun make-active-socket (server port)
+  "Returns (VALUES STREAM SOCKET)"
+  #+allegro
+  (let ((sock (socket:make-socket :remote-host server
+                                  :remote-port port)))
+    (values sock sock))
+  #+lispworks
+  (let ((sock (comm:open-tcp-stream server port)))
+    (values sock sock))
+  #+sbcl
+  (let ((sock (make-instance 'sb-bsd-sockets:inet-socket
+                             :type :stream
+                             :protocol :tcp)))
+    (sb-bsd-sockets:socket-connect sock (lookup-hostname server) port)
+    (values
+     (sb-bsd-sockets:socket-make-stream
+      sock :input t :output t :element-type :default)
+     sock))
+  #+cmu
+  (let ((sock (ext:connect-to-inet-socket server port)))
+    (values
+     (sys:make-fd-stream sock :input t :output t :element-type 'base-char)
+     sock))
+  #+clisp
+  (let ((sock (ext:socket-connect port server)))
+    (values sock sock))
+  #+openmcl
+  (let ((sock (ccl:make-socket :remote-host server :remote-port port )))
+    (values sock sock))
+  )
+
+(defun ipaddr-array-to-dotted (array)
+  (format nil "~{~D~^.~}" (coerce array 'list))
+  #+ignore
+  (format nil "~D.~D.~D.~D"
+          (aref 0 array) (aref 1 array) (aref 2 array) (array 3 array)))
+
+(defun remote-host (socket)
+  #+allegro (socket:ipaddr-to-dotted (socket:remote-host socket))
+  #+lispworks (nth-value 0 (comm:get-socket-peer-address socket))
+  #+sbcl (ipaddr-array-to-dotted
+          (nth-value 0 (sb-bsd-sockets:socket-peername socket)))
+  #+cmu (nth-value 0 (ext:get-peer-host-and-port socket))
+  #+clisp (let* ((peer (ext:socket-stream-peer socket t))
+                (stop (position #\Space peer)))
+           ;; 2.37-2.39 had do-not-resolve-p backwards
+           (if stop (subseq peer 0 stop) peer))
+  #+openmcl (ccl:remote-host socket)
+  )
+
Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/strings.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/kmrcl-1.97/strings.lisp	2007-10-06 21:23:47 UTC (rev 2224)
+++ branches/trunk-reorg/thirdparty/kmrcl-1.97/strings.lisp	2007-10-06 21:39:22 UTC (rev 2225)
@@ -0,0 +1,706 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          strings.lisp
+;;;; Purpose:       Strings utility functions for KMRCL package
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Apr 2000
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of KMRCL, is Copyright (c) 2002-2006 by Kevin M. Rosenberg
+;;;;
+;;;; KMRCL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+
+(in-package #:kmrcl)
+
+;;; Strings
+
+(defmacro string-append (outputstr &rest args)
+  `(setq ,outputstr (concatenate 'string ,outputstr ,@args)))
+
+(defun list-to-string (lst)
+  "Converts a list to a string, doesn't include any delimiters between elements"
+  (format nil "~{~A~}" lst))
+
+(defun count-string-words (str)
+  (declare (simple-string str)
+           (optimize (speed 3) (safety 0) (space 0)))
+  (let ((n-words 0)
+        (in-word nil))
+    (declare (fixnum n-words))
+    (do* ((len (length str))
+          (i 0 (1+ i)))
+        ((= i len) n-words)
+      (declare (fixnum i))
+      (if (alphanumericp (schar str i))
+          (unless in-word
+            (incf n-words)
+            (setq in-word t))
+        (setq in-word nil)))))
+
+;; From Larry Hunter with modifications
+(defun position-char (char string start max)
+  (declare (optimize (speed 3) (safety 0) (space 0))
+           (fixnum start max) (simple-string string))
+  (do* ((i start (1+ i)))
+       ((= i max) nil)
+    (declare (fixnum i))
+    (when (char= char (schar string i)) (return i))))
+
+(defun position-not-char (char string start max)
+  (declare (optimize (speed 3) (safety 0) (space 0))
+           (fixnum start max) (simple-string string))
+  (do* ((i start (1+ i)))
+       ((= i max) nil)
+    (declare (fixnum i))
+    (when (char/= char (schar string i)) (return i))))
+
+(defun delimited-string-to-list (string &optional (separator #\space)
+                                                  skip-terminal)
+  "split a string with delimiter"
+  (declare (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0))
+           (type string string)
+           (type character separator))
+  (do* ((len (length string))
+        (output '())
+        (pos 0)
+        (end (position-char separator string pos len)
+             (position-char separator string pos len)))
+       ((null end)
+        (if (< pos len)
+            (push (subseq string pos) output)
+            (when (or (not skip-terminal) (zerop len))
+              (push "" output)))
+        (nreverse output))
+    (declare (type fixnum pos len)
+             (type (or null fixnum) end))
+    (push (subseq string pos end) output)
+    (setq pos (1+ end))))
+
+
+(defun list-to-delimited-string (list &optional (separator " "))
+  (format nil (concatenate 'string "~{~A~^" (string separator) "~}") list))
+
+(defun string-invert (str)
+  "Invert case of a string"
+  (declare (optimize (speed 3) (compilation-speed 0) (debug 0) (safety 0))
+           (simple-string str))
+  (let ((up nil) (down nil))
+    (block skip
+      (loop for char of-type character across str do
+            (cond ((upper-case-p char)
+                   (if down (return-from skip str) (setf up t)))
+                  ((lower-case-p char)
+                   (if up   (return-from skip str) (setf down t)))))
+      (if up (string-downcase str) (string-upcase str)))))
+
+(defun add-sql-quotes (s)
+  (substitute-string-for-char s #' "''"))
+
+(defun escape-backslashes (s)
+  (substitute-string-for-char s #\ "\\"))
+
+(defun substitute-string-for-char (procstr match-char subst-str)
+  "Substitutes a string for a single matching character of a string"
+  (substitute-chars-strings procstr (list (cons match-char subst-str))))
+
+(defun string-substitute (string substring replacement-string)
+  "String substitute by Larry Hunter. Obtained from Google"
+  (let ((substring-length (length substring))
+        (last-end 0)
+        (new-string ""))
+    (do ((next-start
+          (search substring string)
+          (search substring string :start2 last-end)))
+        ((null next-start)
+         (concatenate 'string new-string (subseq string last-end)))
+      (setq new-string
+        (concatenate 'string
+          new-string
+          (subseq string last-end next-start)
+          replacement-string))
+      (setq last-end (+ next-start substring-length)))))
+
+(defun string-trim-last-character (s)
+  "Return the string less the last character"
+  (let ((len (length s)))
+    (if (plusp len)
+        (subseq s 0 (1- len))
+        s)))
+
+(defun nstring-trim-last-character (s)
+  "Return the string less the last character"
+  (let ((len (length s)))
+    (if (plusp len)
+        (nsubseq s 0 (1- len))
+        s)))
+
+(defun string-hash (str &optional (bitmask 65535))
+  (let ((hash 0))
+    (declare (fixnum hash)
+             (simple-string str))
+    (dotimes (i (length str))
+      (declare (fixnum i))
+      (setq hash (+ hash (char-code (char str i)))))
+    (logand hash bitmask)))
+
+(defun is-string-empty (str)
+  (zerop (length str)))
+
+(defvar *whitespace-chars* '(#\space #\tab #\return #\linefeed
+                             #+allegro #%space
+                             #+lispworks #\No-Break-Space))
+
+(defun is-char-whitespace (c)
+  (declare (character c) (optimize (speed 3) (safety 0)))
+  (or (char= c #\Space) (char= c #\Tab) (char= c #\Return)
+      (char= c #\Linefeed)
+      #+allegro (char= c #%space)
+      #+lispworks (char= c #\No-Break-Space)))
+
+(defun is-string-whitespace (str)
+  "Return t if string is all whitespace"
+  (every #'is-char-whitespace str))
+
+(defun string-right-trim-whitespace (str)
+  (string-right-trim *whitespace-chars* str))
+
+(defun string-left-trim-whitespace (str)
+  (string-left-trim *whitespace-chars* str))
+
+(defun string-trim-whitespace (str)
+  (string-trim *whitespace-chars* str))
+
+(defun replaced-string-length (str repl-alist)
+  (declare (simple-string str)
+           (optimize (speed 3) (safety 0) (space 0)))
+    (do* ((i 0 (1+ i))
+          (orig-len (length str))
+          (new-len orig-len))
+         ((= i orig-len) new-len)
+      (declare (fixnum i orig-len new-len))
+      (let* ((c (char str i))
+             (match (assoc c repl-alist :test #'char=)))
+        (declare (character c))
+        (when match
+          (incf new-len (1- (length
+                             (the simple-string (cdr match)))))))))
+
+(defun substitute-chars-strings (str repl-alist)
+  "Replace all instances of a chars with a string. repl-alist is an assoc
+list of characters and replacement strings."
+  (declare (simple-string str)
+           (optimize (speed 3) (safety 0) (space 0)))
+  (do* ((orig-len (length str))
+        (new-string (make-string (replaced-string-length str repl-alist)))
+        (spos 0 (1+ spos))
+        (dpos 0))
+      ((>= spos orig-len)
+       new-string)
+    (declare (fixnum spos dpos) (simple-string new-string))
+    (let* ((c (char str spos))
+           (match (assoc c repl-alist :test #'char=)))
+      (declare (character c))
+      (if match
+          (let* ((subst (cdr match))
+                 (len (length subst)))
+            (declare (fixnum len)
+                     (simple-string subst))
+            (dotimes (j len)
+              (declare (fixnum j))
+              (setf (char new-string dpos) (char subst j))
+              (incf dpos)))
+        (progn
+          (setf (char new-string dpos) c)
+          (incf dpos))))))
+
+(defun escape-xml-string (string)
+  "Escape invalid XML characters"
+  (substitute-chars-strings string '((#& . "&amp;") (#< . "&lt;"))))
+
+(defun make-usb8-array (len)
+  (make-array len :element-type '(unsigned-byte 8)))
+
+(defun usb8-array-to-string (vec &key (start 0) end)
+  (declare (type (simple-array (unsigned-byte 8) (*)) vec)
+           (fixnum start))
+  (unless end
+    (setq end (length vec)))
+  (let* ((len (- end start))
+         (str (make-string len)))
+    (declare (fixnum len)
+             (simple-string str)
+             (optimize (speed 3) (safety 0)))
+    (do ((i 0 (1+ i)))
+        ((= i len) str)
+      (declare (fixnum i))
+      (setf (schar str i) (code-char (aref vec (the fixnum (+ i start))))))))
+
+(defun string-to-usb8-array (str)
+  (declare (simple-string str))
+  (let* ((len (length str))
+         (vec (make-usb8-array len)))
+    (declare (fixnum len)
+             (type (simple-array (unsigned-byte 8) (*)) vec)
+             (optimize (speed 3)))
+    (do ((i 0 (1+ i)))
+        ((= i len) vec)
+      (declare (fixnum i))
+      (setf (aref vec i) (char-code (schar str i))))))
+
+(defun concat-separated-strings (separator &rest lists)
+  (format nil (concatenate 'string "~{~A~^" (string separator) "~}")
+          (append-sublists lists)))
+
+(defun only-null-list-elements-p (lst)
+  (or (null lst) (every #'null lst)))
+
+(defun print-separated-strings (strm separator &rest lists)
+  (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)
+                     (compilation-speed 0)))
+  (do* ((rest-lists lists (cdr rest-lists))
+        (list (car rest-lists) (car rest-lists))
+        (last-list (only-null-list-elements-p (cdr rest-lists))
+                   (only-null-list-elements-p (cdr rest-lists))))
+       ((null rest-lists) strm)
+    (do* ((lst list (cdr lst))
+          (elem (car lst) (car lst))
+          (last-elem (null (cdr lst)) (null (cdr lst))))
+         ((null lst))
+      (write-string elem strm)
+      (unless (and last-elem last-list)
+        (write-string separator strm)))))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defmacro def-prefixed-number-string (fn-name type &optional doc)
+    `(defun ,fn-name (num pchar len)
+       ,@(when (stringp doc) (list doc))
+       (declare (optimize (speed 3) (safety 0) (space 0))
+                (fixnum len)
+                (,type num))
+       (when pchar
+         (incf len))
+       (do* ((zero-code (char-code #\0))
+           (result (make-string len :initial-element #\0))
+           (minus? (minusp num))
+           (val (if minus? (- num) num)
+                (nth-value 0 (floor val 10)))
+           (pos (1- len) (1- pos))
+           (mod (mod val 10) (mod val 10)))
+         ((or (zerop val) (minusp pos))
+          (when pchar
+            (setf (schar result 0) pchar))
+          (when minus? (setf (schar result (if pchar 1 0)) #-))
+          result)
+       (declare (,type val)
+                (fixnum mod zero-code pos)
+                (boolean minus?)
+                (simple-string result))
+       (setf (schar result pos) (code-char (the fixnum (+ zero-code mod))))))))
+
+(def-prefixed-number-string prefixed-fixnum-string fixnum
+ "Outputs a string of LEN digit with an optional initial character PCHAR.
+Leading zeros are present. LEN must be a fixnum.")
+
+(def-prefixed-number-string prefixed-integer-string integer
+ "Outputs a string of LEN digit with an optional initial character PCHAR.
+Leading zeros are present. LEN must be an integer.")
+
+(defun integer-string (num len)
+  "Outputs a string of LEN digit with an optional initial character PCHAR.
+Leading zeros are present."
+  (declare (optimize (speed 3) (safety 0) (space 0))
+           (type fixnum len)
+           (type integer num))
+  (do* ((zero-code (char-code #\0))
+        (result (make-string len :initial-element #\0))
+        (minus? (minusp num))
+        (val (if minus? (- 0 num) num)
+             (nth-value 0 (floor val 10)))
+        (pos (1- len) (1- pos))
+        (mod (mod val 10) (mod val 10)))
+      ((or (zerop val) (minusp pos))
+       (when minus? (setf (schar result 0) #-))
+       result)
+    (declare (fixnum mod zero-code pos) (simple-string result) (integer val))
+    (setf (schar result pos) (code-char (+ zero-code mod)))))
+
+(defun fast-string-search (substr str substr-length startpos endpos)
+  "Optimized search for a substring in a simple-string"
+  (declare (simple-string substr str)
+           (fixnum substr-length startpos endpos)
+           (optimize (speed 3) (space 0) (safety 0)))
+  (do* ((pos startpos (1+ pos))
+        (lastpos (- endpos substr-length)))
+       ((> pos lastpos) nil)
+    (declare (fixnum pos lastpos))
+    (do ((i 0 (1+ i)))
+        ((= i substr-length)
+         (return-from fast-string-search pos))
+      (declare (fixnum i))
+      (unless (char= (schar str (+ i pos)) (schar substr i))
+        (return nil)))))
+
+(defun string-delimited-string-to-list (str substr)
+  "splits a string delimited by substr into a list of strings"
+  (declare (simple-string str substr)
+           (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)
+                     (debug 0)))
+  (do* ((substr-len (length substr))
+        (strlen (length str))
+        (output '())
+        (pos 0)
+        (end (fast-string-search substr str substr-len pos strlen)
+             (fast-string-search substr str substr-len pos strlen)))
+       ((null end)
+        (when (< pos strlen)
+          (push (subseq str pos) output))
+        (nreverse output))
+    (declare (fixnum strlen substr-len pos)
+             (type (or fixnum null) end))
+    (push (subseq str pos end) output)
+    (setq pos (+ end substr-len))))
+
+(defun string-to-list-skip-delimiter (str &optional (delim #\space))
+  "Return a list of strings, delimited by spaces, skipping spaces."
+  (declare (simple-string str)
+           (optimize (speed 0) (space 0) (safety 0)))
+  (do* ((results '())
+        (end (length str))
+        (i (position-not-char delim str 0 end)
+           (position-not-char delim str j end))
+        (j (when i (position-char delim str i end))
+           (when i (position-char delim str i end))))
+       ((or (null i) (null j))
+        (when (and i (< i end))
+          (push (subseq str i end) results))
+        (nreverse results))
+    (declare (fixnum end)
+             (type (or fixnum null) i j))
+    (push (subseq str i j) results)))
+
+(defun string-starts-with (start str)
+  (and (>= (length str) (length start))
+       (string-equal start str :end2 (length start))))
+
+(defun count-string-char (s c)
+  "Return a count of the number of times a character appears in a string"
+  (declare (simple-string s)
+           (character c)
+           (optimize (speed 3) (safety 0)))
+  (do ((len (length s))
+       (i 0 (1+ i))
+       (count 0))
+      ((= i len) count)
+    (declare (fixnum i len count))
+    (when (char= (schar s i) c)
+      (incf count))))
+
+(defun count-string-char-if (pred s)
+  "Return a count of the number of times a predicate is true
+for characters in a string"
+  (declare (simple-string s)
+           (type (or function symbol) pred)
+           (optimize (speed 3) (safety 0) (space 0)))
+  (do ((len (length s))
+       (i 0 (1+ i))
+       (count 0))
+      ((= i len) count)
+    (declare (fixnum i len count))
+    (when (funcall pred (schar s i))
+      (incf count))))
+
+
+;;; URL Encoding
+
+(defun non-alphanumericp (ch)
+  (not (alphanumericp ch)))
+
+(defvar +hex-chars+ "0123456789ABCDEF")
+(declaim (type simple-string +hex-chars+))
+
+(defun hexchar (n)
+  (declare (type (integer 0 15) n))
+  (schar +hex-chars+ n))
+
+(defconstant* +char-code-lower-a+ (char-code #\a))
+(defconstant* +char-code-upper-a+ (char-code #\A))
+(defconstant* +char-code-0+ (char-code #\0))
+(declaim (type fixnum +char-code-0+ +char-code-upper-a+
+               +char-code-0))
+
+(defun charhex (ch)
+  "convert hex character to decimal"
+  (let ((code (char-code (char-upcase ch))))
+    (declare (fixnum ch))
+    (if (>= code +char-code-upper-a+)
+        (+ 10 (- code +char-code-upper-a+))
+        (- code +char-code-0+))))
+
+(defun binary-sequence-to-hex-string (seq)
+  (let ((list (etypecase seq
+                (list seq)
+                (sequence (map 'list #'identity seq)))))
+    (string-downcase (format nil "~{~2,'0X~}" list))))
+
+(defun encode-uri-string (query)
+  "Escape non-alphanumeric characters for URI fields"
+  (declare (simple-string query)
+           (optimize (speed 3) (safety 0) (space 0)))
+  (do* ((count (count-string-char-if #'non-alphanumericp query))
+        (len (length query))
+        (new-len (+ len (* 2 count)))
+        (str (make-string new-len))
+        (spos 0 (1+ spos))
+        (dpos 0 (1+ dpos)))
+      ((= spos len) str)
+    (declare (fixnum count len new-len spos dpos)
+             (simple-string str))
+    (let ((ch (schar query spos)))
+      (if (non-alphanumericp ch)
+          (let ((c (char-code ch)))
+            (setf (schar str dpos) #%)
+            (incf dpos)
+            (setf (schar str dpos) (hexchar (logand (ash c -4) 15)))
+            (incf dpos)
+            (setf (schar str dpos) (hexchar (logand c 15))))
+        (setf (schar str dpos) ch)))))
+
+(defun decode-uri-string (query)
+  "Unescape non-alphanumeric characters for URI fields"
+  (declare (simple-string query)
+           (optimize (speed 3) (safety 0) (space 0)))
+  (do* ((count (count-string-char query #%))
+        (len (length query))
+        (new-len (- len (* 2 count)))
+        (str (make-string new-len))
+        (spos 0 (1+ spos))
+        (dpos 0 (1+ dpos)))
+      ((= spos len) str)
+    (declare (fixnum count len new-len spos dpos)
+             (simple-string str))
+    (let ((ch (schar query spos)))
+      (if (char= #% ch)
+          (let ((c1 (charhex (schar query (1+ spos))))
+                (c2 (charhex (schar query (+ spos 2)))))
+            (declare (fixnum c1 c2))
+            (setf (schar str dpos)
+                  (code-char (logior c2 (ash c1 4))))
+            (incf spos 2))
+        (setf (schar str dpos) ch)))))
+
+
+(defun uri-query-to-alist (query)
+  "Converts non-decoded URI query to an alist of settings"
+  (mapcar (lambda (set)
+            (let ((lst (kmrcl:delimited-string-to-list set #=)))
+              (cons (first lst) (second lst))))
+          (kmrcl:delimited-string-to-list
+           (kmrcl:decode-uri-string query) #&)))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defvar +unambiguous-charset+
+    "abcdefghjkmnpqrstuvwxyz123456789ABCDEFGHJKLMNPQSRTUVWXYZ")
+  (defconstant* +unambiguous-length+ (length +unambiguous-charset+)))
+
+(defun random-char (&optional (set :lower-alpha))
+  (ecase set
+    (:lower-alpha
+     (code-char (+ +char-code-lower-a+ (random 26))))
+    (:lower-alphanumeric
+     (let ((n (random 36)))
+       (if (>= n 26)
+           (code-char (+ +char-code-0+ (- n 26)))
+         (code-char (+ +char-code-lower-a+ n)))))
+    (:upper-alpha
+     (code-char (+ +char-code-upper-a+ (random 26))))
+    (:unambiguous
+     (schar +unambiguous-charset+ (random +unambiguous-length+)))
+    (:upper-lower-alpha
+     (let ((n (random 52)))
+       (if (>= n 26)
+           (code-char (+ +char-code-upper-a+ (- n 26)))
+         (code-char (+ +char-code-lower-a+ n)))))))
+
+
+(defun random-string (&key (length 10) (set :lower-alpha))
+  "Returns a random lower-case string."
+  (declare (optimize (speed 3)))
+  (let ((s (make-string length)))
+    (declare (simple-string s))
+    (dotimes (i length s)
+      (setf (schar s i) (random-char set)))))
+
+
+(defun first-char (s)
+  (declare (simple-string s))
+  (when (and (stringp s) (plusp (length s)))
+    (schar s 0)))
+
+(defun last-char (s)
+  (declare (simple-string s))
+  (when (stringp s)
+    (let ((len (length s)))
+      (when (plusp len))
+      (schar s (1- len)))))
+
+(defun ensure-string (v)
+  (typecase v
+    (string v)
+    (character (string v))
+    (symbol (symbol-name v))
+    (otherwise (write-to-string v))))
+
+(defun string-right-trim-one-char (char str)
+  (declare (simple-string str))
+  (let* ((len (length str))
+         (last (1- len)))
+    (declare (fixnum len last))
+    (if (char= char (schar str last))
+        (subseq str 0 last)
+      str)))
+
+
+(defun string-strip-ending (str endings)
+  (if (stringp endings)
+      (setq endings (list endings)))
+  (let ((len (length str)))
+    (dolist (ending endings str)
+      (when (and (>= len (length ending))
+                 (string-equal ending
+                               (subseq str (- len
+                                              (length ending)))))
+        (return-from string-strip-ending
+          (subseq str 0 (- len (length ending))))))))
+
+
+(defun string-maybe-shorten (str maxlen)
+  (string-elide str maxlen :end))
+
+(defun string-elide (str maxlen position)
+  (declare (fixnum maxlen))
+  (let ((len (length str)))
+    (declare (fixnum len))
+    (cond
+     ((<= len maxlen)
+      str)
+     ((<= maxlen 3)
+      "...")
+     ((eq position :middle)
+      (multiple-value-bind (mid remain) (truncate maxlen 2)
+        (let ((end1 (- mid 1))
+              (start2 (- len (- mid 2) remain)))
+          (concatenate 'string (subseq str 0 end1) "..." (subseq str start2)))))
+     ((or (eq position :end) t)
+      (concatenate 'string (subseq str 0 (- maxlen 3)) "...")))))
+
+(defun shrink-vector (str size)
+  #+allegro
+  (excl::.primcall 'sys::shrink-svector str size)
+  #+cmu
+  (lisp::shrink-vector str size)
+  #+lispworks
+  (system::shrink-vector$vector str size)
+  #+sbcl
+  (sb-kernel:shrink-vector str size)
+  #+scl
+  (common-lisp::shrink-vector str size)
+  #-(or allegro cmu lispworks sbcl scl)
+  (setq str (subseq str 0 size))
+  str)
+
+(defun lex-string (string &key (whitespace '(#\space #\newline)))
+  "Separates a string at whitespace and returns a list of strings"
+  (flet ((is-sep (char) (member char whitespace :test #'char=)))
+    (let ((tokens nil))
+      (do* ((token-start
+             (position-if-not #'is-sep string)
+             (when token-end
+               (position-if-not #'is-sep string :start (1+ token-end))))
+            (token-end
+             (when token-start
+               (position-if #'is-sep string :start token-start))
+             (when token-start
+               (position-if #'is-sep string :start token-start))))
+           ((null token-start) (nreverse tokens))
+        (push (subseq string token-start token-end) tokens)))))
+
+(defun split-alphanumeric-string (string)
+  "Separates a string at any non-alphanumeric chararacter"
+  (declare (simple-string string)
+           (optimize (speed 3) (safety 0)))
+  (flet ((is-sep (char)
+           (declare (character char))
+           (and (non-alphanumericp char)
+                (not (char= #_ char)))))
+    (let ((tokens nil))
+      (do* ((token-start
+             (position-if-not #'is-sep string)
+             (when token-end
+               (position-if-not #'is-sep string :start (1+ token-end))))
+            (token-end
+             (when token-start
+               (position-if #'is-sep string :start token-start))
+             (when token-start
+               (position-if #'is-sep string :start token-start))))
+           ((null token-start) (nreverse tokens))
+        (push (subseq string token-start token-end) tokens)))))
+
+
+(defun trim-non-alphanumeric (word)
+  "Strip non-alphanumeric characters from beginning and end of a word."
+  (declare (simple-string word)
+           (optimize (speed 3) (safety 0) (space 0)))
+  (let* ((start 0)
+         (len (length word))
+         (end len))
+    (declare (fixnum start end len))
+    (do ((done nil))
+        ((or done (= start end)))
+      (if (alphanumericp (schar word start))
+          (setq done t)
+        (incf start)))
+    (when (> end start)
+      (do ((done nil))
+          ((or done (= start end)))
+        (if (alphanumericp (schar word (1- end)))
+            (setq done t)
+          (decf end))))
+    (if (or (plusp start) (/= len end))
+        (subseq word start end)
+      word)))
+
+
+(defun collapse-whitespace (s)
+  "Convert multiple whitespace characters to a single space character."
+  (declare (simple-string s)
+           (optimize (speed 3) (safety 0)))
+  (with-output-to-string (stream)
+    (do ((pos 0 (1+ pos))
+         (in-white nil)
+         (len (length s)))
+        ((= pos len))
+      (declare (fixnum pos len))
+      (let ((c (schar s pos)))
+        (declare (character c))
+        (cond
+         ((kl:is-char-whitespace c)
+          (unless in-white
+            (write-char #\space stream))
+          (setq in-white t))
+         (t
+          (setq in-white nil)
+          (write-char c stream)))))))
+
+(defun string->list (string)
+  (let ((eof (list nil)))
+    (with-input-from-string (stream string)
+      (do ((x (read stream nil eof) (read stream nil eof))
+           (l nil (cons x l)))
+          ((eq x eof) (nreverse l))))))
Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/strmatch.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/kmrcl-1.97/strmatch.lisp	2007-10-06 21:23:47 UTC (rev 2224)
+++ branches/trunk-reorg/thirdparty/kmrcl-1.97/strmatch.lisp	2007-10-06 21:39:22 UTC (rev 2225)
@@ -0,0 +1,80 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; package: kmrcl -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          strings.lisp
+;;;; Purpose:       Strings utility functions for KMRCL package
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Apr 2000
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; KMRCL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(in-package #:kmrcl)
+
+
+(defun score-multiword-match (s1 s2)
+  "Score a match between two strings with s1 being reference string.
+S1 can be a string or a list or strings/conses"
+  (let* ((word-list-1 (if (stringp s1)
+                          (split-alphanumeric-string s1)
+                        s1))
+         (word-list-2 (split-alphanumeric-string s2))
+         (n1 (length word-list-1))
+         (n2 (length word-list-2))
+         (unmatched n1)
+         (score 0))
+    (declare (fixnum n1 n2 score unmatched))
+    (decf score (* 4 (abs (- n1 n2))))
+    (dotimes (iword n1)
+      (declare (fixnum iword))
+      (let ((w1 (nth iword word-list-1))
+            pos)
+        (cond
+         ((consp w1)
+          (let ((first t))
+            (dotimes (i-alt (length w1))
+              (setq pos
+                (position (nth i-alt w1) word-list-2
+                          :test #'string-equal))
+              (when pos
+                (incf score (- 30
+                               (if first 0 5)
+                               (abs (- iword pos))))
+                (decf unmatched)
+                (return))
+              (setq first nil))))
+         ((stringp w1)
+          (kmrcl:awhen (position w1 word-list-2
+                               :test #'string-equal)
+                       (incf score (- 30 (abs (- kmrcl::it iword))))
+                       (decf unmatched))))))
+    (decf score (* 4 unmatched))
+    score))
+
+
+(defun multiword-match (s1 s2)
+  "Matches two multiword strings, ignores case, word position, punctuation"
+  (let* ((word-list-1 (split-alphanumeric-string s1))
+         (word-list-2 (split-alphanumeric-string s2))
+         (n1 (length word-list-1))
+         (n2 (length word-list-2)))
+    (when (= n1 n2)
+      ;; remove each word from word-list-2 as walk word-list-1
+      (dolist (w word-list-1)
+        (let ((p (position w word-list-2 :test #'string-equal)))
+          (unless p
+            (return-from multiword-match nil))
+          (setf (nth p word-list-2) "")))
+      t)))
+
+
+
+
+
Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/symbols.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/kmrcl-1.97/symbols.lisp	2007-10-06 21:23:47 UTC (rev 2224)
+++ branches/trunk-reorg/thirdparty/kmrcl-1.97/symbols.lisp	2007-10-06 21:39:22 UTC (rev 2225)
@@ -0,0 +1,147 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          cl-symbols.lisp
+;;;; Purpose:       Returns all defined Common Lisp symbols
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Apr 2000
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; KMRCL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(in-package #:kmrcl)
+
+(defun cl-symbols ()
+  (append (cl-variables) (cl-functions)))
+
+(defun cl-variables ()
+  (let ((vars '()))
+    (do-symbols (s 'common-lisp)
+      (multiple-value-bind (sym status)
+          (find-symbol (symbol-name s) 'common-lisp)
+        (when (and (or (eq status :external)
+                       (eq status :internal))
+                   (boundp sym))
+          (push sym vars))))
+    (nreverse vars)))
+
+(defun cl-functions ()
+  (let ((funcs '()))
+    (do-symbols (s 'common-lisp)
+      (multiple-value-bind (sym status)
+        (find-symbol (symbol-name s) 'common-lisp)
+        (when (and (or (eq status :external)
+                       (eq status :internal))
+                   (fboundp sym))
+          (push sym funcs))))
+    (nreverse funcs)))
+
+;;; Symbol functions
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (when (char= #\a (schar (symbol-name '#:a) 0))
+    (pushnew :kmrcl-lowercase-reader *features*))
+  (when (not (string= (symbol-name '#:a)
+                      (symbol-name '#:A)))
+    (pushnew :kmrcl-case-sensitive *features*)))
+
+(defun string-default-case (str)
+  #+(and (not kmrcl-lowercase-reader)) (string-upcase str)
+  #+(and kmrcl-lowercase-reader) (string-downcase str))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (setq cl:*features* (delete :kmrcl-lowercase-reader *features*))
+  (setq cl:*features* (delete :kmrcl-case-sensitive *features*)))
+
+(defun concat-symbol-pkg (pkg &rest args)
+  (declare (dynamic-extent args))
+  (flet ((stringify (arg)
+           (etypecase arg
+             (string
+              (string-upcase arg))
+             (symbol
+              (symbol-name arg)))))
+    (let ((str (apply #'concatenate 'string (mapcar #'stringify args))))
+      (nth-value 0 (intern (string-default-case str)
+                           (if pkg pkg *package*))))))
+
+
+(defun concat-symbol (&rest args)
+  (apply #'concat-symbol-pkg nil args))
+
+(defun ensure-keyword (name)
+  "Returns keyword for a name"
+  (etypecase name
+    (keyword name)
+    (string (nth-value 0 (intern (string-default-case name) :keyword)))
+    (symbol (nth-value 0 (intern (symbol-name name) :keyword)))))
+
+(defun ensure-keyword-upcase (desig)
+  (nth-value 0 (intern (string-upcase
+                        (symbol-name (ensure-keyword desig))) :keyword)))
+
+(defun ensure-keyword-default-case (desig)
+  (nth-value 0 (intern (string-default-case
+                        (symbol-name (ensure-keyword desig))) :keyword)))
+
+(defun show (&optional (what :variables) (package *package*))
+  (ecase what
+    (:variables (show-variables package))
+    (:functions (show-functions package))))
+
+(defun show-variables (package)
+  (do-symbols (s package)
+    (multiple-value-bind (sym status)
+        (find-symbol (symbol-name s) package)
+      (when (and (or (eq status :external)
+                     (eq status :internal))
+                 (boundp sym))
+        (format t "~&Symbol ~S~T -> ~S~%"
+                sym
+                (symbol-value sym))))))
+
+(defun show-functions (package)
+  (do-symbols (s package)
+    (multiple-value-bind (sym status)
+        (find-symbol (symbol-name s) package)
+      (when (and (or (eq status :external)
+                     (eq status :internal))
+                 (fboundp sym))
+        (format t "~&Function ~S~T -> ~S~%"
+                sym
+                (symbol-function sym))))))
+
+(defun find-test-generic-functions (instance)
+  "Return a list of symbols for generic functions specialized on the
+class of an instance and whose name begins with the string 'test-'"
+  (let ((res)
+        (package (symbol-package (class-name (class-of instance)))))
+    (do-symbols (s package)
+      (multiple-value-bind (sym status)
+          (find-symbol (symbol-name s) package)
+        (when (and (or (eq status :external)
+                       (eq status :internal))
+                   (fboundp sym)
+                   (eq (symbol-package sym) package)
+                   (> (length (symbol-name sym)) 5)
+                   (string-equal "test-" (subseq (symbol-name sym) 0 5))
+                   (typep (symbol-function sym) 'generic-function)
+                   (plusp
+                    (length
+                     (compute-applicable-methods
+                      (ensure-generic-function sym)
+                      (list instance)))))
+          (push sym res))))
+    (nreverse res)))
+
+(defun run-tests-for-instance (instance)
+  (dolist (gf-name(find-test-generic-functions instance))
+    (funcall gf-name instance))
+  (values))
Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/tests.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/kmrcl-1.97/tests.lisp	2007-10-06 21:23:47 UTC (rev 2224)
+++ branches/trunk-reorg/thirdparty/kmrcl-1.97/tests.lisp	2007-10-06 21:39:22 UTC (rev 2225)
@@ -0,0 +1,493 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: kmrcl-tests -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          kmrcl-tests.lisp
+;;;; Purpose:       kmrcl tests file
+;;;; Author:        Kevin M. Rosenberg
+;;;; Date Started:  Apr 2003
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file is Copyright (c) 2000-2006 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package #:cl)
+(defpackage #:kmrcl-tests
+  (:use #:kmrcl #:cl #:rtest))
+(in-package #:kmrcl-tests)
+
+(rem-all-tests)
+
+
+(deftest :str.0 (substitute-chars-strings "" nil) "")
+(deftest :str.1 (substitute-chars-strings "abcd" nil) "abcd")
+(deftest :str.2 (substitute-chars-strings "abcd" nil) "abcd")
+(deftest :str.3 (substitute-chars-strings "abcd" '((#\j . "ef"))) "abcd")
+(deftest :str.4 (substitute-chars-strings "abcd" '((#\a . "ef"))) "efbcd")
+(deftest :str.5
+    (substitute-chars-strings "abcd" '((#\a . "ef") (#\j . "ghi")))
+  "efbcd")
+(deftest :str.6
+    (substitute-chars-strings "abcd" '((#\a . "ef") (#\d . "ghi")))
+  "efbcghi")
+
+(deftest :str.7 (escape-xml-string "") "")
+(deftest :str.8 (escape-xml-string "abcd") "abcd")
+(deftest :str.9 (escape-xml-string "ab&cd") "ab&amp;cd")
+(deftest :str.10 (escape-xml-string "ab&cd<") "ab&amp;cd&lt;")
+(deftest :str.12 (string-trim-last-character "") "")
+(deftest :str.13 (string-trim-last-character "a") "")
+(deftest :str.14 (string-trim-last-character "ab") "a")
+(deftest :str.15 (nstring-trim-last-character "") "")
+(deftest :str.16 (nstring-trim-last-character "a") "")
+(deftest :str.17 (nstring-trim-last-character "ab") "a")
+
+(deftest :str.18 (delimited-string-to-list "ab|cd|ef" #|)
+                                          ("ab" "cd" "ef"))
+(deftest :str.19 (delimited-string-to-list "ab|cd|ef" #| t)
+                                          ("ab" "cd" "ef"))
+(deftest :str.20 (delimited-string-to-list "") (""))
+(deftest :str.21 (delimited-string-to-list "" #\space t) (""))
+(deftest :str.22 (delimited-string-to-list "ab") ("ab"))
+(deftest :str.23 (delimited-string-to-list "ab" #\space t) ("ab"))
+(deftest :str.24 (delimited-string-to-list "ab|" #|) ("ab" ""))
+(deftest :str.25 (delimited-string-to-list "ab|" #| t) ("ab"))
+
+(deftest :sdstl.1 (string-delimited-string-to-list "ab|cd|ef" "|a")
+  ("ab|cd|ef"))
+(deftest :sdstl.2 (string-delimited-string-to-list "ab|cd|ef" "|")
+  ("ab" "cd" "ef"))
+(deftest :sdstl.3 (string-delimited-string-to-list "ab|cd|ef" "cd")
+  ("ab|" "|ef"))
+(deftest :sdstl.4 (string-delimited-string-to-list "ab|cd|ef" "ab")
+  ("" "|cd|ef"))
+
+(deftest :hexstr.1 (binary-sequence-to-hex-string ())
+  "")
+
+(deftest :hexstr.2 (binary-sequence-to-hex-string #())
+  "")
+
+(deftest :hexstr.3 (binary-sequence-to-hex-string #(165))
+  "a5"
+)
+
+(deftest :hexstr.4 (binary-sequence-to-hex-string (list 165))
+  "a5")
+
+(deftest :hexstr.5 (binary-sequence-to-hex-string #(165 86))
+  "a556")
+
+(deftest :apsl.1 (append-sublists '((a b) (c d))) (a b c d))
+(deftest :apsl.2 (append-sublists nil) nil)
+(deftest :apsl.3 (append-sublists '((a b))) (a b))
+(deftest :apsl.4 (append-sublists '((a))) (a))
+(deftest :apsl.5 (append-sublists '((a) (b) (c d (e f g)))) (a b c d (e f g)))
+
+(deftest :pss.0 (with-output-to-string (s) (print-separated-strings s "|" nil))
+  "")
+
+(deftest :pss.1
+    (with-output-to-string (s) (print-separated-strings s "|" '("ab")) )
+  "ab")
+
+(deftest :pss.2
+    (with-output-to-string (s) (print-separated-strings s "|" '("ab" "cd")))
+    "ab|cd")
+
+(deftest :pss.3
+    (with-output-to-string (s) (print-separated-strings s "|" '("ab" "cd") nil))
+    "ab|cd")
+
+(deftest :pss.4
+    (with-output-to-string (s)
+      (print-separated-strings s "|" '("ab" "cd") nil nil))
+    "ab|cd")
+
+(deftest :pss.5
+    (with-output-to-string (s)
+      (print-separated-strings s "|" '("ab" "cd") nil '("ef") nil))
+    "ab|cd|ef")
+
+(deftest :css.0 (concat-separated-strings "|" nil) "")
+(deftest :css.1 (concat-separated-strings "|" nil nil) "")
+(deftest :css.2 (concat-separated-strings "|" '("ab")) "ab")
+(deftest :css.3 (concat-separated-strings "|" '("ab" "cd")) "ab|cd")
+(deftest :css.4 (concat-separated-strings "|" '("ab" "cd") nil) "ab|cd")
+(deftest :css.5 (concat-separated-strings "|" '("ab" "cd") nil '("ef")) "ab|cd|ef")
+
+(deftest :f.1 (map-and-remove-nils #'(lambda (x) (when (oddp x) (* x x)))
+                     '(0 1 2 3 4 5 6 7 8 9)) (1 9 25 49 81))
+(deftest :f.2 (filter #'(lambda (x) (when (oddp x) (* x x)))
+                     '(0 1 2 3 4 5 6 7 8 9)) (1 3 5 7 9))
+(deftest :an.1 (appendnew '(a b c d) '(c c e f)) (a b c d e f))
+
+
+(deftest :pxml.1
+  (xml-tag-contents "tag1" "<tag>Test</tag>")
+  nil nil nil)
+
+(deftest :pxml.2
+  (xml-tag-contents "tag" "<tag>Test</tag>")
+  "Test" 15 nil)
+
+(deftest :pxml.3
+  (xml-tag-contents "tag" "<tag  >Test</tag>")
+  "Test" 17 nil)
+
+(deftest :pxml.4
+    (xml-tag-contents "tag" "<tag a="b"></tag>")
+  "" 17 ("a="b""))
+
+(deftest :pxml.5
+    (xml-tag-contents "tag" "<tag a="b" >Test</tag>")
+  "Test" 22 ("a="b""))
+
+(deftest :pxml.6
+    (xml-tag-contents "tag" "<tag a="b"  c="ab">Test</tag>")
+  "Test" 29 ("a="b"" "c="ab""))
+
+(deftest :pxml.7
+    (xml-tag-contents "tag" "<taga a="b"  c="ab">Test</taga>")
+  nil nil nil)
+
+(deftest :pxml.8
+    (xml-tag-contents "tag" "<taga a="b"  c="ab">Test<tag>ab</tag></taga>")
+  "ab" 37 nil)
+
+(deftest :pxml.9
+    (xml-tag-contents "tag" "<taga a="b"  c="ab">Test<tag>ab</ag></taga>")
+  nil nil nil)
+
+(deftest :fss.1 (fast-string-search "" "" 0 0 0) 0)
+(deftest :fss.2 (fast-string-search "" "abc" 0 0 2) 0)
+(deftest :fss.3 (fast-string-search "abc" "" 3 0 0) nil)
+(deftest :fss.4 (fast-string-search "abc" "abcde" 3 0 4) 0)
+(deftest :fss.5 (fast-string-search "abc" "012abcde" 3 0 7) 3)
+(deftest :fss.6 (fast-string-search "abc" "012abcde" 3 0 7) 3)
+(deftest :fss.7 (fast-string-search "abc" "012abcde" 3 3 7) 3)
+(deftest :fss.8 (fast-string-search "abc" "012abcde" 3 4 7) nil)
+(deftest :fss.9 (fast-string-search "abcde" "012abcde" 5 3 8) 3)
+(deftest :fss.9b (cl:search "abcde" "012abcde" :start2 3 :end2 8) 3)
+(deftest :fss.10 (fast-string-search "abcde" "012abcde" 5 3 7) nil)
+(deftest :fss.10b (cl:search "abcde" "012abcde" :start2 3 :end2 7) nil)
+
+(deftest :stlsd.1 (string-to-list-skip-delimiter "") ())
+(deftest :stlsd.2 (string-to-list-skip-delimiter "abc") ("abc"))
+(deftest :stlsd.3 (string-to-list-skip-delimiter "ab c") ("ab" "c"))
+(deftest :stlsd.4 (string-to-list-skip-delimiter "ab  c") ("ab" "c"))
+(deftest :stlsd.5 (string-to-list-skip-delimiter "ab   c") ("ab" "c"))
+(deftest :stlsd.6 (string-to-list-skip-delimiter "ab   c ") ("ab" "c"))
+(deftest :stlsd.7 (string-to-list-skip-delimiter "  ab   c  ") ("ab" "c"))
+(deftest :stlsd.8 (string-to-list-skip-delimiter "ab,,c" #,) ("ab" "c"))
+(deftest :stlsd.9 (string-to-list-skip-delimiter "ab,,c,," #,) ("ab" "c"))
+(deftest :stlsd.10 (string-to-list-skip-delimiter " ab") ("ab"))
+
+(deftest :csc.1 (count-string-char "" #\a) 0)
+(deftest :csc.2 (count-string-char "abc" #\d) 0)
+(deftest :csc.3 (count-string-char "abc" #\b) 1)
+(deftest :csc.4 (count-string-char "abcb" #\b) 2)
+
+(deftest :duqs.1 (decode-uri-query-string "") "")
+(deftest :duqs.2 (decode-uri-query-string "abc") "abc")
+(deftest :duqs.3 (decode-uri-query-string "abc+") "abc ")
+(deftest :duqs.4 (decode-uri-query-string "abc+d") "abc d")
+(deftest :duqs.5 (decode-uri-query-string "abc%20d") "abc d")
+
+(deftest :sse.1 (string-strip-ending "" nil) "")
+(deftest :sse.2 (string-strip-ending "abc" nil) "abc")
+(deftest :sse.3 (string-strip-ending "abc" "ab") "abc")
+(deftest :sse.4 (string-strip-ending "abc" '("ab")) "abc")
+(deftest :sse.5 (string-strip-ending "abcd" '("a" "cd")) "ab")
+
+
+(defun test-color-conversion ()
+  (dotimes (ih 11)
+    (dotimes (is 11)
+      (dotimes (iv 11)
+        (let ((h (* ih 30))
+              (s (/ is 10))
+              (v (/ iv 10)))
+          (multiple-value-bind (r g b) (hsv->rgb h s v)
+            (multiple-value-bind (h2 s2 v2) (rgb->hsv r g b)
+              (unless (hsv-equal h s v h2 s2 v2)
+                (warn "Colors not equal: ~4D ~4D ~4D | ~6D:~6D ~6D:~6D ~6D:~6D~%"
+                        (float r) (float g) (float b)
+                        (when (typep h 'number) (float h))
+                        (when (typep h2 'number) (float h2))
+                        (float s) (float s2) (float v) (float v2))
+                (return-from test-color-conversion nil))))))))
+  t)
+
+(defun test-color-conversion-float-255 ()
+  (dotimes (ih 11)
+    (dotimes (is 11)
+      (dotimes (iv 11)
+        (let ((h (* ih 30))
+              (s (/ is 10))
+              (v (/ iv 10)))
+          (multiple-value-bind (r g b) (hsv->rgb h s v)
+            (setf r (round (* 255 r))
+                  g (round (* 255 g))
+                  b (round (* 255 b)))
+            (multiple-value-bind (h2 s2 v2) (rgb255->hsv255 r g b)
+              (unless (hsv-similar h s v h2 (/ s2 255) (/ v2 255)
+                                   :hue-range 10 :saturation-range .1
+                                   :value-range 1 :black-limit 0 :gray-limit 0)
+                (warn "Colors not equal: ~4D ~4D ~4D | ~6D:~6D ~6D:~6D ~6D:~6D~%"
+                      r g b
+                      (when (typep h 'number) (float h))
+                      (when (typep h2 'number) (float h2))
+                      (float s) (float (/ s2 255)) (float v) (float (/ v2 255)))
+                (return-from test-color-conversion-float-255 nil))))))))
+  t)
+
+(defun test-color-conversion-255-float ()
+  (dotimes (ih 11)
+    (dotimes (is 11)
+      (dotimes (iv 11)
+        (let ((h (* ih 30))
+              (s (/ is 10))
+              (v (/ iv 10)))
+          (multiple-value-bind (r g b) (hsv255->rgb255 h (truncate (* 255 s))
+                                                       (truncate (* 255 v)))
+            (setf r (/ r 255)
+                  g (/ g 255)
+                  b (/ b 255))
+
+            (multiple-value-bind (h2 s2 v2) (rgb->hsv r g b)
+              (unless (hsv-similar h s v h2 s2 v2
+                                   :hue-range 10 :saturation-range .1
+                                   :value-range 1 :black-limit 0 :gray-limit 0)
+                (warn "Colors not equal: ~4D ~4D ~4D | ~6D:~6D ~6D:~6D ~6D:~6D~%"
+                      r g b
+                      (when (typep h 'number) (float h))
+                      (when (typep h2 'number) (float h2))
+                      (float s) (float (/ s2 255)) (float v) (float (/ v2 255)))
+                (return-from test-color-conversion-255-float nil))))))))
+  t)
+
+(defun test-color-conversion-255 ()
+  (dotimes (ih 11)
+    (dotimes (is 11)
+      (dotimes (iv 11)
+        (let ((h (* ih 30))
+              (s (truncate (* 255 (/ is 10))))
+              (v (truncate (* 255 (/ iv 10)))))
+          (multiple-value-bind (r g b) (hsv255->rgb255 h s v)
+            (multiple-value-bind (h2 s2 v2) (rgb255->hsv255 r g b)
+              (unless (hsv255-similar h s v h2 s2 v2 :hue-range 10 :saturation-range 5
+                                      :value-range 5 :black-limit 0 :gray-limit 0)
+                (warn "Colors not equal: ~D ~D ~D |~
+ ~3,'0D:~3,'0D ~3,'0D:~3,'0D ~3,'0D:~3,'0D~%"
+                      r g b
+                      h h2 s s2 v v2)
+                (return-from test-color-conversion-255 nil))))))))
+  t)
+
+(deftest :color.conv (test-color-conversion) t)
+(deftest :color.conv.float.255 (test-color-conversion-float-255) t)
+(deftest :color.conv.255.float (test-color-conversion-255-float) t)
+(deftest :color.conv.255 (test-color-conversion-255) t)
+
+(deftest :hue.diff.1 (hue-difference 10 10) 0)
+(deftest :hue.diff.2 (hue-difference 10 9) -1)
+(deftest :hue.diff.3 (hue-difference 9 10) 1)
+(deftest :hue.diff.4 (hue-difference 10 nil) 360)
+(deftest :hue.diff.5 (hue-difference nil 1) 360)
+(deftest :hue.diff.7 (hue-difference 10 190) 180)
+(deftest :hue.diff.8 (hue-difference 190 10) -180)
+(deftest :hue.diff.9 (hue-difference 1 359) -2)
+(deftest :hue.diff.10 (hue-difference 1 182) -179)
+(deftest :hue.diff.11 (hue-difference 1 270) -91)
+
+(deftest :hsv.sim.1 (hsv-similar 100 .5 .5 110 .5 .5 :hue-range 5
+                                :value-range 0 :saturation-range 0
+                                :black-limit 0 :gray-limit 0) nil)
+(deftest :hsv.sim.2 (hsv-similar 100 .5 .5 110 .5 .5 :hue-range 15
+                                :value-range 0 :saturation-range 0
+                                :black-limit 0 :gray-limit 0) t)
+(deftest :hsv.sim.3 (hsv-similar 100 .5 .5 110 .5 .6 :hue-range 15
+                                :value-range .2 :saturation-range 0
+                                :black-limit 0 :gray-limit 0) t)
+(deftest :hsv.sim.4 (hsv-similar 100 .5 .5 110 .5 .8 :hue-range 15
+                                :value-range 0.2 :saturation-range 0
+                                :black-limit 0 :gray-limit 0) nil)
+(deftest :hsv.sim.5 (hsv-similar 100 .5 .5 110 .6 .6 :hue-range 15
+                                :value-range 0.2 :saturation-range .2
+                                :black-limit 0 :gray-limit 0) t)
+(deftest :hsv.sim.6 (hsv-similar 100 .5 .5 110 .6 .8 :hue-range 15
+                                :value-range 0.2 :saturation-range .2
+                                :black-limit 0 :gray-limit 0) nil)
+(deftest :hsv.sim.7 (hsv-similar 100 .5 .05 110 .6 .01 :hue-range 0
+                                :value-range 0 :saturation-range 0
+                                :black-limit .1 :gray-limit 0) t)
+(deftest :hsv.sim.8 (hsv-similar 100 .01 .5 110 .09 .6 :hue-range 0
+                                :value-range 0.2 :saturation-range 0
+                                :black-limit 0 :gray-limit .1) t)
+(deftest :hsv.sim.9 (hsv-similar 100 .01 .5 110 .09 .6 :hue-range 0
+                                :value-range 0.05 :saturation-range 0
+                                :black-limit 0 :gray-limit .1) nil)
+
+#+ignore
+(progn
+(deftest :dst.1
+    (is-dst-change-usa-spring-utime
+     (encode-universal-time 0 0 0 2 4 2000)) t)
+(deftest :dst.2
+    (is-dst-change-usa-spring-utime
+     (encode-universal-time 0 0 0 1 4 2000)) nil)
+(deftest :dst.3
+    (is-dst-change-usa-spring-utime
+     (encode-universal-time 0 0 0 3 4 2000)) nil)
+(deftest :dst.4
+    (is-dst-change-usa-fall-utime
+     (encode-universal-time 0 0 0 31 10 2004)) t)
+(deftest :dst.5
+    (is-dst-change-usa-fall-utime
+     (encode-universal-time 0 0 0 30 10 2004)) nil)
+(deftest :dst.6
+    (is-dst-change-usa-fall-utime
+     (encode-universal-time 0 0 0 1 11 2000)) nil)
+)
+
+
+(deftest :ekdc.1
+    (ensure-keyword-default-case (read-from-string "TYPE")) :type)
+
+(deftest :ekdc.2
+    (ensure-keyword-default-case (read-from-string "type")) :type)
+
+
+(deftest :se.1
+    (string-elide "A Test string" 10 :end) "A Test ..." )
+
+(deftest :se.2
+    (string-elide "A Test string" 13 :end) "A Test string")
+
+(deftest :se.3
+    (string-elide "A Test string" 11 :end) "A Test s..." )
+
+(deftest :se.4
+    (string-elide "A Test string" 2 :middle) "...")
+
+(deftest :se.5
+    (string-elide "A Test string" 11 :middle) "A Te...ring")
+
+(deftest :se.6
+    (string-elide "A Test string" 12 :middle) "A Tes...ring")
+
+(deftest :url.1
+    (make-url "pg")
+  "pg")
+
+(deftest :url.2
+    (make-url "pg" :anchor "now")
+  "pg#now")
+
+(deftest :url.3
+    (make-url "pg" :vars '(("a" . "5")))
+  "pg?a=5")
+
+(deftest :url.4
+    (make-url "pg" :anchor "then" :vars '(("a" . "5") ("b" . "pi")))
+  "pg?a=5&b=pi#then")
+
+(defclass test-unique ()
+  ((a :initarg :a)
+   (b :initarg :b)))
+
+
+(deftest :unique.1
+    (let ((list (list (make-instance 'test-unique :a 1 :b 1)
+                      (make-instance 'test-unique :a 2 :b 2)
+                      (make-instance 'test-unique :a 3 :b 2))))
+      (values
+       (unique-slot-values list 'a)
+       (unique-slot-values list 'b)))
+  (1 2 3) (1 2))
+
+(deftest :unique.2
+    (unique-slot-values nil 'a)
+  nil)
+
+(deftest :nwp.1
+       (numbers-within-percentage 1. 1.1 9)
+  nil)
+
+(deftest :nwp.2
+       (numbers-within-percentage 1. 1.1 11)
+  t)
+
+(deftest :pfs.1 (prefixed-fixnum-string 0 #\A 5) "A00000")
+
+(deftest :pfs.2 (prefixed-fixnum-string 1 #\A 5) "A00001")
+
+(deftest :pfs.3 (prefixed-fixnum-string 21 #\B 3) "B021")
+
+(deftest :pis.4 (prefixed-integer-string 234134 #\C 7) "C0234134")
+
+ ;;; MOP Testing
+
+;; Disable attrib class until understand changes in sbcl/cmucl
+;; using COMPUTE-SLOT-ACCESSOR-INFO and defining method
+;; for slot access of ALL-ATTRIBUTES. Does this work on Allegro/LW?
+
+#+ignore
+(progn
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (when (find-package '#:kmr-mop)
+    (pushnew :kmrtest-mop cl:*features*)))
+
+#+kmrtest-mop
+(setf (find-class 'monitored-credit-rating) nil)
+#+kmrtest-mop
+(setf (find-class 'credit-rating) nil)
+
+#+kmrtest-mop
+(defclass credit-rating ()
+  ((level :attributes (date-set time-set))
+   (id :attributes (person-setting)))
+  #+lispworks (:optimize-slot-access nil)
+  (:metaclass attributes-class))
+
+
+#+kmrtest-mop
+(defclass monitored-credit-rating ()
+  ((level :attributes (last-checked interval date-set))
+   (cc :initarg :cc)
+   (id :attributes (verified)))
+  (:metaclass attributes-class))
+
+#+kmrtest-mop
+(deftest :attrib.mop.1
+         (let ((cr (make-instance 'credit-rating)))
+           (slot-attribute cr 'level 'date-set))
+         nil)
+
+#+kmrtest-mop
+(deftest :attrib.mop.2
+         (let ((cr (make-instance 'credit-rating)))
+           (setf (slot-attribute cr 'level 'date-set) "12/15/1990")
+           (let ((result (slot-attribute cr 'level 'date-set)))
+             (setf (slot-attribute cr 'level 'date-set) nil)
+             result))
+         "12/15/1990")
+
+#+kmrtest-mop
+(deftest :attrib.mop.3
+         (let ((mcr (make-instance 'monitored-credit-rating)))
+           (setf (slot-attribute mcr 'level 'date-set) "01/05/2002")
+           (let ((result (slot-attribute mcr 'level 'date-set)))
+             (setf (slot-attribute mcr 'level 'date-set) nil)
+             result))
+         "01/05/2002")
+
+
+#+kmrtest-mop
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (setq cl:*features* (delete :kmrtest-mop cl:*features*)))
+
+) ;; progn
Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/web-utils.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/kmrcl-1.97/web-utils.lisp	2007-10-06 21:23:47 UTC (rev 2224)
+++ branches/trunk-reorg/thirdparty/kmrcl-1.97/web-utils.lisp	2007-10-06 21:39:22 UTC (rev 2225)
@@ -0,0 +1,107 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          web-utils.lisp
+;;;; Purpose:       Basic web utility functions
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Apr 2000
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; KMRCL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(in-package #:kmrcl)
+
+
+;;; HTML/XML constants
+
+(defvar *standard-xml-header*
+  #.(format nil "<?xml version=\"1.0\" encoding=\"iso-8859-1\" standalone=\"yes\"?>~%"))
+
+(defvar *standard-html-header* "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML//EN\">")
+
+(defvar *standard-xhtml-header*
+  #.(format nil "<?xml version=\"1.0\" encoding=\"iso-8859-1\" standalone=\"yes\"?>~%<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\" \"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">"))
+
+
+;;; User agent functions
+
+(defun user-agent-ie-p (agent)
+  "Takes a user-agent string and returns T for Internet Explorer."
+  (or (string-starts-with "Microsoft" agent)
+      (string-starts-with "Internet Explore" agent)
+      (search "Safari" agent)
+      (search "MSIE" agent)))
+
+;;; URL Functions
+
+(defvar *base-url* "")
+(defun base-url! (url)
+  (setq *base-url* url))
+
+(defun make-url (page-name &key (base-dir *base-url*) (format :html) vars anchor)
+  (let ((amp (case format
+               (:html
+                "&")
+               ((:xml :ie-xml)
+                "&amp;"))))
+    (concatenate 'string
+      base-dir page-name
+      (if vars
+          (let ((first-var (first vars)))
+            (concatenate 'string
+              "?"  (car first-var) "=" (cdr first-var)
+              (mapcar-append-string
+               #'(lambda (var)
+                   (when (and (car var) (cdr var))
+                     (concatenate 'string
+                       amp (string-downcase (car var)) "=" (cdr var))))
+               (rest vars))))
+        "")
+      (if anchor
+          (concatenate 'string "#" anchor)
+        ""))))
+
+(defun decode-uri-query-string (s)
+  "Decode a URI query string field"
+  (declare (simple-string s)
+           (optimize (speed 3) (safety 0) (space 0)))
+  (do* ((old-len (length s))
+        (new-len (- old-len (* 2 (the fixnum (count-string-char s #%)))))
+        (new (make-string new-len))
+        (p-old 0)
+        (p-new 0 (1+ p-new)))
+       ((= p-new new-len) new)
+    (declare (simple-string new)
+             (fixnum p-old p-new old-len new-len))
+         (let ((c (schar s p-old)))
+           (when (char= c #+)
+             (setq c #\space))
+           (case c
+             (#%
+              (unless (>= old-len (+ p-old 3))
+                (error "#% not followed by enough characters"))
+              (setf (schar new p-new)
+                    (code-char
+                     (parse-integer (subseq s (1+ p-old) (+ p-old 3))
+                                    :radix 16)))
+              (incf p-old 3))
+             (t
+              (setf (schar new p-new) c)
+              (incf p-old))))))
+
+(defun split-uri-query-string (s)
+  (mapcar
+   (lambda (pair)
+     (let ((pos (position #= pair)))
+       (when pos
+         (cons (subseq pair 0 pos)
+               (when (> (length pair) pos)
+                 (decode-uri-query-string (subseq pair (1+ pos))))))))
+   (delimited-string-to-list s #&)))
Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/xml-utils.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/kmrcl-1.97/xml-utils.lisp	2007-10-06 21:23:47 UTC (rev 2224)
+++ branches/trunk-reorg/thirdparty/kmrcl-1.97/xml-utils.lisp	2007-10-06 21:39:22 UTC (rev 2225)
@@ -0,0 +1,176 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          xml-utils.lisp
+;;;; Purpose:       XML utilities
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Apr 2000
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; KMRCL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(in-package #:kmrcl)
+
+
+;;; XML Extraction Functions
+
+(defun find-start-tag (tag taglen xmlstr start end)
+  "Searches for the start of a tag in an xmlstring. Returns STARTPOS ATTRIBUTE-LIST)"
+  (declare (simple-string tag xmlstr)
+           (fixnum taglen start end)
+           (optimize (speed 3) (safety 0) (space 0)))
+  (do* ((search-str (concatenate 'string "<" tag))
+        (search-len (1+ taglen))
+        (bracketpos (fast-string-search search-str xmlstr search-len start end)
+                    (fast-string-search search-str xmlstr search-len start end)))
+       ((null bracketpos) nil)
+    (let* ((endtag (+ bracketpos 1 taglen))
+           (char-after-tag (schar xmlstr endtag)))
+      (when (or (char= #> char-after-tag)
+                (char= #\space char-after-tag))
+        (if (char= #> char-after-tag)
+            (return-from find-start-tag (values (1+ endtag) nil))
+            (let ((endbrack (position-char #> xmlstr (1+ endtag) end)))
+              (if endbrack
+                  (return-from find-start-tag
+                    (values (1+ endbrack)
+                            (string-to-list-skip-delimiter
+                             (subseq xmlstr endtag endbrack))))
+                  (values nil nil)))))
+      (setq start endtag))))
+
+
+(defun find-end-tag (tag taglen xmlstr start end)
+  (fast-string-search
+   (concatenate 'string "</" tag ">") xmlstr
+   (+ taglen 3) start end))
+
+(defun positions-xml-tag-contents (tag xmlstr &optional (start-xmlstr 0)
+                                       (end-xmlstr (length xmlstr)))
+  "Returns three values: the start and end positions of contents between
+ the xml tags and the position following the close of the end tag."
+  (let* ((taglen (length tag)))
+    (multiple-value-bind (start attributes)
+        (find-start-tag tag taglen xmlstr start-xmlstr end-xmlstr)
+      (unless start
+        (return-from positions-xml-tag-contents (values nil nil nil nil)))
+      (let ((end (find-end-tag tag taglen xmlstr start end-xmlstr)))
+        (unless end
+          (return-from positions-xml-tag-contents (values nil nil nil nil)))
+        (values start end (+ end taglen 3) attributes)))))
+
+
+(defun xml-tag-contents (tag xmlstr &optional (start-xmlstr 0)
+                         (end-xmlstr (length xmlstr)))
+  "Returns two values: the string between XML start and end tag
+and position of character following end tag."
+  (multiple-value-bind
+      (startpos endpos nextpos attributes)
+      (positions-xml-tag-contents tag xmlstr start-xmlstr end-xmlstr)
+    (if (and startpos endpos)
+        (values (subseq xmlstr startpos endpos) nextpos attributes)
+      (values nil nil nil))))
+
+(defun cdata-string (str)
+  (concatenate 'string "<![CDATA[" str "]]>"))
+
+(defun write-cdata (str s)
+  (declare (simple-string str) (optimize (speed 3) (safety 0) (space 0)))
+  (do ((len (length str))
+       (i 0 (1+ i)))
+      ((= i len) str)
+    (declare (fixnum i len))
+    (let ((c (schar str i)))
+      (case c
+        (#< (write-string "&lt;" s))
+        (#& (write-string "&amp;" s))
+        (t   (write-char c s))))))
+
+(defun xml-declaration-stream (stream &key (version "1.0") standalone encoding)
+  (format stream "<?xml version=\"~A\"~A~A ?>~%"
+          version
+          (if encoding
+              (format nil " encoding="~A"" encoding)
+              ""
+              )
+          (if standalone
+              (format nil " standalone="~A"" standalone)
+              "")))
+
+(defun doctype-stream (stream top-element availability registered organization type
+                       label language url entities)
+  (format stream "<!DOCTYPE ~A ~A \"~A//~A//~A ~A//~A\"" top-element
+          availability (if registered "+" "-") organization type label language)
+
+  (when url
+    (write-char #\space stream)
+    (write-char #\" stream)
+    (write-string url stream)
+    (write-char #\" stream))
+
+  (when entities
+    (format stream " [~%~A~%]" entities))
+
+  (write-char #\> stream)
+  (write-char #\newline stream))
+
+(defun doctype-format (stream format &key top-element (availability "PUBLIC")
+                       (registered nil) organization (type "DTD") label
+                       (language "EN") url entities)
+  (case format
+    ((:xhtml11 :xhtml)
+     (doctype-stream stream "html" availability registered "W3C" type "XHTML 1.1" language
+                     (if url url "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd")
+                     entities))
+    (:xhtml10-strict
+     (doctype-stream stream "html" availability registered "W3C" type "XHTML 1.0 Strict" language
+                     (if url url "http://www.w3.org/TR/xhtml10/DTD/xhtml10-strict.dtd")
+                     entities))
+    (:xhtml10-transitional
+     (doctype-stream stream "html" availability registered "W3C" type "XHTML 1.0 Transitional" language
+                     (if url url "http://www.w3.org/TR/xhtml10/DTD/xhtml10-transitional.dtd")
+                     entities))
+    (:xhtml-frameset
+     (doctype-stream stream "html" availability registered "W3C" type "XHTML 1.0 Frameset" language
+                     (if url url "http://www.w3.org/TR/xhtml10/DTD/xhtml10-frameset.dtd")
+                     entities))
+    (:html2
+     (doctype-stream stream "HTML" availability registered "IETF" type "HTML" language url entities))
+    (:html3
+     (doctype-stream stream "HTML" availability registered "IETF" type "HTML 3.0" language url entities))
+    (:html3.2
+     (doctype-stream stream "HTML" availability registered "W3C" type "HTML 3.2 Final" language url entities))
+    ((:html :html4)
+     (doctype-stream stream "HTML" availability registered "W3C" type "HTML 4.01 Final" language url entities))
+    ((:docbook :docbook42)
+     (doctype-stream stream (if top-element top-element "book")
+                     availability registered "OASIS" type "Docbook XML 4.2" language
+                     (if url url "http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd")
+                     entities))
+    (t
+     (unless top-element (warn "Missing top-element in doctype-format"))
+     (unless organization (warn "Missing organization in doctype-format"))
+     (unless label (warn "Missing label in doctype-format"))
+     (doctype-stream stream top-element availability registered organization type label language url
+                     entities))))
+
+
+(defun sgml-header-stream (format stream &key entities (encoding "iso-8859-1") standalone (version "1.0")
+                          top-element (availability "PUBLIC") registered organization (type "DTD")
+                           label (language "EN") url)
+  (when (in format :xhtml :xhtml11 :xhtml10-strict :xhtml10-transitional :xhtml10-frameset :xml :docbook)
+    (xml-declaration-stream stream :version version :encoding encoding :standalone standalone))
+  (unless (eq :xml format)
+    (doctype-format stream format :top-element top-element
+                    :availability availability :registered registered
+                    :organization organization :type type :label label :language language
+                    :url url :entities entities))
+  stream)
+

    

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

[bknr-cvs] r2225 - in branches/trunk-reorg/thirdparty: . kmrcl-1.97