[bknr-cvs] r2225 - in branches/trunk-reorg/thirdparty: . kmrcl-1.97
bknr at bknr.net
bknr at bknr.net
Sat Oct 6 21:39:24 UTC 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 at rosenberg.net>
+ * Version 1.97
+ * datetime.lisp: Improve output format for date-string
+
+10 Sep 2007 Kevin Rosenberg <kevin at rosenberg.net>
+ * Version 1.96
+ * byte-stream.lisp: Use without-package-locks as suggested
+ by Daniel Gackle.
+
+01 Jun 2007 Kevin Rosenberg <kevin at rosenberg.net>
+ * Version 1.95
+ * {datetime,package}.lisp: Add day-of-week and pretty-date-ut
+
+07 Jan 2007 Kevin Rosenberg <kevin at rosenberg.net>
+ * Version 1.94
+ * signals.lisp: Conditionalize Lispworks support to :unix *features*
+
+07 Jan 2007 Kevin Rosenberg <kevin at rosenberg.net>
+ * Version 1.93
+ * signals.lisp: Add new file for signal processing
+
+31 Dec 2006 Kevin Rosenberg <kevin at rosenberg.net>
+ * impl.lisp, sockets.lisp, equal.lisp, datetime.lisp: Declare ignored variables
+
+29 Nov 2006 Kevin Rosenberg <kevin at rosenberg.net>
+ * Version 1.92
+ * strings.lisp: Add uri-query-to-alist
+
+24 Oct 2006 Kevin Rosenberg <kevin at rosenberg.net>
+ * Version 1.91
+ * io.lisp: Fix output from read-file-to-string
+
+22 Sep 2006 Kevin Rosenberg <kevin at rosenberg.net>
+ * Version 1.90
+ * sockets.lisp: Commit patch from Joerg Hoehle for CLISP sockets
+
+04 Sep 2006 Kevin Rosenberg <kevin at 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 at rosenberg.net>
+ * Version 1.88
+ * strings.lisp, package.lisp: Add binary-sequence-to-hex-string
+
+26 Jul 2006 Kevin Rosenberg <kevin at 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 at 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 , at 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 , at totalcol))
+ (t (error "if*: illegal form ~s" args))))
+ (cond ((and (symbolp (car xx))
+ (member (symbol-name (car xx))
+ if*-keyword-list
+ :test #'string-equal))
+ (setq lookat (symbol-name (car xx)))))
+
+ (cond ((eq state :init)
+ (cond (lookat (cond ((string-equal lookat "thenret")
+ (setq col nil
+ state :then))
+ (t (error
+ "if*: bad keyword ~a" lookat))))
+ (t (setq state :col
+ col nil)
+ (push (car xx) col))))
+ ((eq state :col)
+ (cond (lookat
+ (cond ((string-equal lookat "else")
+ (cond (elseseen
+ (error
+ "if*: multiples elses")))
+ (setq elseseen t)
+ (setq state :init)
+ (push `(t , at col) totalcol))
+ ((string-equal lookat "then")
+ (setq state :then))
+ (t (error "if*: bad keyword ~s"
+ lookat))))
+ (t (push (car xx) col))))
+ ((eq state :then)
+ (cond (lookat
+ (error
+ "if*: keyword ~s at the wrong place " (car xx)))
+ (t (setq state :compl)
+ (push `(,(car xx) , at col) totalcol))))
+ ((eq state :compl)
+ (cond ((not (string-equal lookat "elseif"))
+ (error "if*: missing elseif clause ")))
+ (setq state :init)))))
+
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 " " (+ 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))
+ , at 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)
+ , at body)
+ (with-utime-decoding (,utime)
+ , at 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 at rosenberg.net>"
+ :maintainer "Kevin M. Rosenberg <kmr at 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 , at 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 , at body)))
+
+(defmacro awhile (expr &body body)
+ `(do ((it ,expr ,expr))
+ ((not it))
+ , at 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 , at 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 , at body)))
+
+(defmacro awhile2 (test &body body)
+ (let ((flag (gensym)))
+ `(let ((,flag t))
+ (while ,flag
+ (aif2 ,test
+ (progn , at 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)
+ , at body))
+
+(defmacro while (test &body body)
+ `(do ()
+ ((not ,test))
+ , at body))
+
+(defmacro for ((var start stop) &body body)
+ (let ((gstop (gensym)))
+ `(do ((,var ,start (1+ ,var))
+ (,gstop ,stop))
+ ((> ,var ,gstop))
+ , at 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))
+ , at 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)
+ , at body))))
+
+
+(defmacro in (obj &rest choices)
+ (let ((insym (gensym)))
+ `(let ((,insym ,obj))
+ (or ,@(mapcar #'(lambda (c) `(eql ,insym ,c))
+ choices)))))
+
+(defmacro mean (&rest args)
+ `(/ (+ , at args) ,(length args)))
+
+(defmacro with-gensyms (syms &body body)
+ `(let ,(mapcar #'(lambda (s) `(,s (gensym)))
+ syms)
+ , at body))
+
+
+(defmacro time-seconds (&body body)
+ (let ((t1 (gensym)))
+ `(let ((,t1 (get-internal-real-time)))
+ (values
+ (progn , at 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)
+ , at 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
+ , at 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) , at body)
+ #+cmu
+ `(mp:with-lock-held (,lock) , at body)
+ #+lispworks
+ `(mp:with-lock (,lock) , at body)
+ #+sb-thread
+ `(sb-thread:with-recursive-lock (,lock) , at body)
+ #+openmcl
+ `(ccl:with-lock-grabbed (,lock) , at body)
+ #-(or allegro cmu lispworks sb-thread openmcl)
+ `(progn , at body)
+ )
+
+
+(defmacro with-timeout ((seconds) &body body)
+ #+allegro
+ `(mp:with-timeout (,seconds) , at body)
+ #+cmu
+ `(mp:with-timeout (,seconds) , at body)
+ #+sb-thread
+ `(sb-ext:with-timeout ,seconds , at body)
+ #+openmcl
+ `(ccl:process-wait-with-timeout "waiting"
+ (* ,seconds ccl:*ticks-per-second*)
+ #'(lambda ()
+ , at body) nil)
+ #-(or allegro cmu sb-thread openmcl)
+ `(progn , at 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 , at 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 '((#\& . "&") (#\< . "<"))))
+
+(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&cd")
+(deftest :str.10 (escape-xml-string "ab&cd<") "ab&cd<")
+(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)
+ "&"))))
+ (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 "<" s))
+ (#\& (write-string "&" 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)
+
More information about the Bknr-cvs
mailing list