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