[bknr-cvs] r2469 - in branches/trunk-reorg/thirdparty/arnesi: . docs src src/call-cc t
ksprotte at common-lisp.net
ksprotte at common-lisp.net
Mon Feb 11 13:38:50 UTC 2008
Author: ksprotte
Date: Mon Feb 11 08:38:43 2008
New Revision: 2469
Added:
branches/trunk-reorg/thirdparty/arnesi/
branches/trunk-reorg/thirdparty/arnesi/COPYING
branches/trunk-reorg/thirdparty/arnesi/arnesi.asd
branches/trunk-reorg/thirdparty/arnesi/docs/
branches/trunk-reorg/thirdparty/arnesi/docs/Makefile
branches/trunk-reorg/thirdparty/arnesi/docs/print.css
branches/trunk-reorg/thirdparty/arnesi/docs/style.css
branches/trunk-reorg/thirdparty/arnesi/src/
branches/trunk-reorg/thirdparty/arnesi/src/accumulation.lisp
branches/trunk-reorg/thirdparty/arnesi/src/asdf.lisp
branches/trunk-reorg/thirdparty/arnesi/src/bracket-reader.lisp
branches/trunk-reorg/thirdparty/arnesi/src/call-cc/
branches/trunk-reorg/thirdparty/arnesi/src/call-cc/apply.lisp
branches/trunk-reorg/thirdparty/arnesi/src/call-cc/common-lisp-cc.lisp
branches/trunk-reorg/thirdparty/arnesi/src/call-cc/generic-functions.lisp
branches/trunk-reorg/thirdparty/arnesi/src/call-cc/handlers.lisp
branches/trunk-reorg/thirdparty/arnesi/src/call-cc/interpreter.lisp
branches/trunk-reorg/thirdparty/arnesi/src/cl-ppcre-extras.lisp
branches/trunk-reorg/thirdparty/arnesi/src/compat.lisp
branches/trunk-reorg/thirdparty/arnesi/src/csv.lisp
branches/trunk-reorg/thirdparty/arnesi/src/debug.lisp
branches/trunk-reorg/thirdparty/arnesi/src/decimal-arithmetic.lisp
branches/trunk-reorg/thirdparty/arnesi/src/defclass-struct.lisp
branches/trunk-reorg/thirdparty/arnesi/src/flow-control.lisp
branches/trunk-reorg/thirdparty/arnesi/src/hash.lisp
branches/trunk-reorg/thirdparty/arnesi/src/http.lisp
branches/trunk-reorg/thirdparty/arnesi/src/io.lisp
branches/trunk-reorg/thirdparty/arnesi/src/lambda-list.lisp
branches/trunk-reorg/thirdparty/arnesi/src/lambda.lisp
branches/trunk-reorg/thirdparty/arnesi/src/lexenv.lisp
branches/trunk-reorg/thirdparty/arnesi/src/lisp1.lisp
branches/trunk-reorg/thirdparty/arnesi/src/list.lisp
branches/trunk-reorg/thirdparty/arnesi/src/log.lisp
branches/trunk-reorg/thirdparty/arnesi/src/matcher.lisp
branches/trunk-reorg/thirdparty/arnesi/src/mop.lisp
branches/trunk-reorg/thirdparty/arnesi/src/mopp.lisp
branches/trunk-reorg/thirdparty/arnesi/src/numbers.lisp
branches/trunk-reorg/thirdparty/arnesi/src/one-liners.lisp
branches/trunk-reorg/thirdparty/arnesi/src/packages.lisp
branches/trunk-reorg/thirdparty/arnesi/src/pf-reader.lisp
branches/trunk-reorg/thirdparty/arnesi/src/posixenv.lisp
branches/trunk-reorg/thirdparty/arnesi/src/queue.lisp
branches/trunk-reorg/thirdparty/arnesi/src/sequence.lisp
branches/trunk-reorg/thirdparty/arnesi/src/sharpl-reader.lisp
branches/trunk-reorg/thirdparty/arnesi/src/specials.lisp
branches/trunk-reorg/thirdparty/arnesi/src/string.lisp
branches/trunk-reorg/thirdparty/arnesi/src/time.lisp
branches/trunk-reorg/thirdparty/arnesi/src/unwalk.lisp
branches/trunk-reorg/thirdparty/arnesi/src/vector.lisp
branches/trunk-reorg/thirdparty/arnesi/src/walk.lisp
branches/trunk-reorg/thirdparty/arnesi/t/
branches/trunk-reorg/thirdparty/arnesi/t/accumulation.lisp
branches/trunk-reorg/thirdparty/arnesi/t/call-cc.lisp
branches/trunk-reorg/thirdparty/arnesi/t/csv.lisp
branches/trunk-reorg/thirdparty/arnesi/t/flow-control.lisp
branches/trunk-reorg/thirdparty/arnesi/t/http.lisp
branches/trunk-reorg/thirdparty/arnesi/t/list.lisp
branches/trunk-reorg/thirdparty/arnesi/t/log.lisp
branches/trunk-reorg/thirdparty/arnesi/t/matcher.lisp
branches/trunk-reorg/thirdparty/arnesi/t/numbers.lisp
branches/trunk-reorg/thirdparty/arnesi/t/queue.lisp
branches/trunk-reorg/thirdparty/arnesi/t/read-macros.lisp
branches/trunk-reorg/thirdparty/arnesi/t/sequence.lisp
branches/trunk-reorg/thirdparty/arnesi/t/sharpl.lisp
branches/trunk-reorg/thirdparty/arnesi/t/string.lisp
branches/trunk-reorg/thirdparty/arnesi/t/suite.lisp
branches/trunk-reorg/thirdparty/arnesi/t/walk.lisp
Log:
added arnesi to thirdparty
Added: branches/trunk-reorg/thirdparty/arnesi/COPYING
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/COPYING Mon Feb 11 08:38:43 2008
@@ -0,0 +1,30 @@
+Copyright (c) 2002-2006, Edward Marco Baringer
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+- Redistributions of source code must retain the above copyright
+notice, this list of conditions and the following disclaimer.
+
+- Redistributions in binary form must reproduce the above copyright
+notice, this list of conditions and the following disclaimer in the
+documentation and/or other materials provided with the distribution.
+
+- Neither the name of Edward Marco Baringer, nor BESE, nor the names
+of its contributors may be used to endorse or promote products derived
+from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
Added: branches/trunk-reorg/thirdparty/arnesi/arnesi.asd
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/arnesi.asd Mon Feb 11 08:38:43 2008
@@ -0,0 +1,131 @@
+;;; -*- lisp -*-
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (unless (find-package :it.bese.arnesi.system)
+ (defpackage :it.bese.arnesi.system
+ (:documentation "ASDF System package for ARNESI.")
+ (:use :common-lisp :asdf))))
+
+(in-package :it.bese.arnesi.system)
+
+(defsystem :arnesi
+ :components ((:static-file "arnesi.asd")
+ (:module :src
+ :components ((:file "accumulation" :depends-on ("packages" "one-liners"))
+ (:file "asdf" :depends-on ("packages" "io"))
+ (:file "csv" :depends-on ("packages" "string"))
+ (:file "compat" :depends-on ("packages"))
+ (:module :call-cc
+ :components ((:file "interpreter")
+ (:file "handlers")
+ (:file "apply")
+ (:file "generic-functions")
+ (:file "common-lisp-cc"))
+ :serial t
+ :depends-on ("packages" "walk" "flow-control" "lambda-list" "list" "string" "defclass-struct"))
+ (:file "debug" :depends-on ("accumulation"))
+ (:file "decimal-arithmetic" :depends-on ("packages"))
+ (:file "defclass-struct" :depends-on ("packages" "list"))
+ (:file "flow-control" :depends-on ("packages" "one-liners"))
+ (:file "hash" :depends-on ("packages" "list" "one-liners" "string"))
+ (:file "http" :depends-on ("packages" "vector" "string"))
+ (:file "io" :depends-on ("packages" "flow-control" "string"))
+ (:file "lambda" :depends-on ("packages"))
+ (:file "lambda-list" :depends-on ("packages" "walk"))
+ (:file "lisp1" :depends-on ("packages" "lambda-list" "one-liners" "walk" "unwalk"))
+ (:file "lexenv" :depends-on ("packages" "one-liners"))
+ (:file "list" :depends-on ("packages" "one-liners" "accumulation" "flow-control"))
+ (:file "log" :depends-on ("packages" "numbers" "hash" "io"))
+ (:file "matcher" :depends-on ("packages" "hash" "list" "flow-control" "one-liners"))
+ (:file "mop" :depends-on ("packages" "mopp"))
+ (:file "mopp" :depends-on ("packages" "list" "flow-control"))
+ (:file "numbers" :depends-on ("packages"))
+ (:file "one-liners" :depends-on ("packages"))
+ (:file "packages")
+ (:file "pf-reader" :depends-on ("packages"))
+ (:file "posixenv" :depends-on ("packages"))
+ (:file "queue" :depends-on ("packages"))
+ (:file "sequence" :depends-on ("packages"))
+ (:file "bracket-reader" :depends-on ("list"))
+ (:file "sharpl-reader" :depends-on ("packages" "flow-control" "mopp"))
+ (:file "specials" :depends-on ("packages" "hash"))
+ (:file "string" :depends-on ("packages" "list"))
+ (:file "time" :depends-on ("packages"))
+ (:file "unwalk" :depends-on ("packages" "walk"))
+ (:file "vector" :depends-on ("packages" "flow-control"))
+ (:file "walk" :depends-on ("packages" "list" "mopp" "lexenv" "one-liners")))))
+ :properties ((:features "v1.4.0" "v1.4.1" "v1.4.2" "cc-interpreter"
+ "join-strings-return-value" "getenv"))
+ :depends-on (:swank))
+
+(defsystem :arnesi.test
+ :components ((:module :t
+ :components ((:file "accumulation" :depends-on ("suite"))
+ (:file "call-cc" :depends-on ("suite"))
+ (:file "http" :depends-on ("suite"))
+ (:file "log" :depends-on ("suite"))
+ (:file "matcher" :depends-on ("suite"))
+ (:file "numbers" :depends-on ("suite"))
+ (:file "queue" :depends-on ("suite"))
+ (:file "read-macros" :depends-on ("suite"))
+ (:file "string" :depends-on ("suite"))
+ (:file "sequence" :depends-on ("suite"))
+ (:file "sharpl" :depends-on ("suite"))
+ (:file "flow-control" :depends-on ("suite"))
+ (:file "walk" :depends-on ("suite"))
+ (:file "csv" :depends-on ("suite"))
+ (:file "suite"))))
+ :depends-on (:arnesi :FiveAM)
+ :in-order-to ((compile-op (load-op :arnesi))))
+
+(defsystem :arnesi.cl-ppcre-extras
+ :components ((:module :src
+ :components ((:file "cl-ppcre-extras"))))
+ :depends-on (:cl-ppcre :arnesi))
+
+(defmethod perform ((op asdf:test-op) (system (eql (find-system :arnesi))))
+ (asdf:oos 'asdf:load-op :arnesi.test)
+ (funcall (intern (string :run!) (string :it.bese.FiveAM))
+ :it.bese.arnesi))
+
+(defmethod operation-done-p ((op test-op) (system (eql (find-system :arnesi))))
+ nil)
+
+;;;; * Introduction
+
+;;;; A collection of various common lisp utilites.
+
+;;;;@include "src/packages.lisp"
+
+
+;; Copyright (c) 2002-2006 Edward Marco Baringer
+;; Copyright (c) 2006 Luca Capello http://luca.pca.it <luca at pca.it>
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;; - Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;;
+;; - Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;;
+;; - Neither the name of Edward Marco Baringer, Luca Capello, nor
+;; BESE, nor the names of its contributors may be used to endorse
+;; or promote products derived from this software without specific
+;; prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Added: branches/trunk-reorg/thirdparty/arnesi/docs/Makefile
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/docs/Makefile Mon Feb 11 08:38:43 2008
@@ -0,0 +1,30 @@
+# Change this to whatever lisp you'r using
+LISP=sbcl
+EVAL=--eval
+QUIT=(sb-ext:quit)
+SYSTEM=ARNESI
+
+docs: pdf html
+
+html:
+ mkdir -p html/
+ ${LISP} ${EVAL} "(asdf:oos 'asdf:load-op :qbook)" \
+ ${EVAL} "(asdf:oos 'asdf:load-op :${SYSTEM})" \
+ ${EVAL} "(asdf:oos 'qbook:publish-op :${SYSTEM} \
+ :generator (make-instance 'qbook:html-generator \
+ :output-directory \"./html/\" \
+ :title \"${SYSTEM}\"))" \
+ ${EVAL} "${QUIT}"
+
+pdf:
+ mkdir -p pdf/
+ ${LISP} ${EVAL} "(asdf:oos 'asdf:load-op :qbook)" \
+ ${EVAL} "(asdf:oos 'asdf:load-op :${SYSTEM})" \
+ ${EVAL} "(asdf:oos 'qbook:publish-op :${SYSTEM} \
+ :generator (make-instance 'qbook:latex-generator \
+ :output-file \"./pdf/${SYSTEM}.tex\" \
+ :title \"${SYSTEM}\"))" \
+ ${EVAL} "${QUIT}"
+ (cd pdf && pdflatex ${SYSTEM}.tex)
+ (cd pdf && pdflatex ${SYSTEM}.tex)
+ rm pdf/${SYSTEM}.aux pdf/${SYSTEM}.log pdf/${SYSTEM}.toc pdf/${SYSTEM}.tex
Added: branches/trunk-reorg/thirdparty/arnesi/docs/print.css
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/docs/print.css Mon Feb 11 08:38:43 2008
@@ -0,0 +1,94 @@
+body {
+ background-color: #FFFFFF;
+ padding: 0px; margin: 0px;
+}
+
+.qbook {
+ width: 600px;
+ background-color: #FFFFFF;
+ padding: 0em;
+ margin: 0px;
+}
+
+h1, h2, h3, h4, h5, h6 {
+ font-family: verdana;
+}
+
+h1 {
+ text-align: center;
+ padding: 0px;
+ margin: 0px;
+}
+
+h2 {
+ text-align: center;
+ border-top: 1px solid #000000;
+ border-bottom: 1px solid #000000;
+}
+
+h3, h4, h5, h6 {
+ border-bottom: 1px solid #000000;
+ padding-left: 1em;
+}
+
+h3 { border-top: 1px solid #000000; }
+
+p { padding-left: 1em; }
+
+pre.code {
+ border: solid 1px #FFFFFF;
+ padding: 2px;
+ overflow: visible;
+}
+
+pre .first-line-more-link { display: none; }
+
+pre.code * .paren { color: #666666; }
+
+pre.code a:active { color: #000000; }
+pre.code a:link { color: #000000; }
+pre.code a:visited { color: #000000; }
+
+pre.code .first-line { font-weight: bold; }
+
+pre.code .body, pre.code * .body { display: inline; }
+
+div.contents {
+ font-family: verdana;
+ border-bottom: 1em solid #333333;
+ margin-left: -0.5em;
+}
+
+div.contents a:active { color: #000000; }
+div.contents a:link { color: #000000; }
+div.contents a:visited { color: #000000; }
+
+div.contents div.contents-heading-1 { padding-left: 0.5em; font-weight: bold; }
+div.contents div.contents-heading-1 a:active { color: #333333; }
+div.contents div.contents-heading-1 a:link { color: #333333; }
+div.contents div.contents-heading-1 a:visited { color: #333333; }
+
+div.contents div.contents-heading-2 { padding-left: 1.0em; }
+div.contents div.contents-heading-2 a:active { color: #333333; }
+div.contents div.contents-heading-2 a:link { color: #333333; }
+div.contents div.contents-heading-2 a:visited { color: #333333; }
+
+div.contents div.contents-heading-3 { padding-left: 1.5em; }
+div.contents div.contents-heading-3 a:active { color: #333333; }
+div.contents div.contents-heading-3 a:link { color: #333333; }
+div.contents div.contents-heading-3 a:visited { color: #333333; }
+
+div.contents div.contents-heading-4 { padding-left: 2em; }
+div.contents div.contents-heading-4 a:active { color: #333333; }
+div.contents div.contents-heading-4 a:link { color: #333333; }
+div.contents div.contents-heading-4 a:visited { color: #333333; }
+
+div.contents div.contents-heading-5 { padding-left: 2.5em; }
+div.contents div.contents-heading-5 a:active { color: #333333; }
+div.contents div.contents-heading-5 a:link { color: #333333; }
+div.contents div.contents-heading-5 a:visited { color: #333333; }
+
+.footer { float: bottom-right; color: #000000; font-family: arial; font-size: small; }
+.footer a:active { color: #000000; }
+.footer a:link { color: #000000; }
+.footer a:visited { color: #000000; }
Added: branches/trunk-reorg/thirdparty/arnesi/docs/style.css
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/docs/style.css Mon Feb 11 08:38:43 2008
@@ -0,0 +1,107 @@
+body {
+ background-color: #FFFFFF;
+ padding: 0px;
+ margin: 0px;
+}
+
+.qbook {
+ margin: auto;
+ background-color: #FFFFFF;
+ width: 40em;
+}
+
+h1, h2, h3, h4, h5, h6 {
+ font-family: verdana;
+}
+
+h1 {
+ text-align: center;
+ color: #000000;
+ padding: 0px;
+ margin: 0px;
+}
+
+h2 {
+ text-align: center;
+ border-top: 1px solid #000000;
+ border-bottom: 1px solid #000000;
+ margin-top: 2em;
+}
+
+h3, h4, h5, h6 {
+ padding-left: 1em;
+ margin-top: 2em;
+}
+
+h3 {
+ border-top: 1px solid #000000;
+ border-bottom: 1px solid #000000;
+}
+
+h4 {
+ border-bottom: 1px solid #000000;
+}
+
+h5 {
+ border-bottom: 1px solid #000000;
+}
+
+h6 {
+ border-bottom: 1px solid #000000;
+}
+
+pre.code {
+ background-color: #eeeeee;
+ border: solid 1px #d0d0d0;
+ overflow: auto;
+}
+
+pre.code * .paren { color: #666666; }
+
+pre.code a:active { color: #000000; }
+pre.code a:link { color: #000000; }
+pre.code a:visited { color: #000000; }
+
+pre.code .first-line { font-weight: bold; }
+
+pre.code .body, pre.code * .body { display: none; }
+
+div.contents {
+ font-family: verdana;
+}
+
+div.contents a:active { color: #000000; }
+div.contents a:link { color: #000000; }
+div.contents a:visited { color: #000000; }
+
+div.contents div.contents-heading-1 { padding-left: 0.5em; font-weight: bold; }
+div.contents div.contents-heading-1 a:active { color: #333333; }
+div.contents div.contents-heading-1 a:link { color: #333333; }
+div.contents div.contents-heading-1 a:visited { color: #333333; }
+
+div.contents div.contents-heading-2 { padding-left: 1.0em; }
+div.contents div.contents-heading-2 a:active { color: #333333; }
+div.contents div.contents-heading-2 a:link { color: #333333; }
+div.contents div.contents-heading-2 a:visited { color: #333333; }
+
+div.contents div.contents-heading-3 { padding-left: 1.5em; }
+div.contents div.contents-heading-3 a:active { color: #333333; }
+div.contents div.contents-heading-3 a:link { color: #333333; }
+div.contents div.contents-heading-3 a:visited { color: #333333; }
+
+div.contents div.contents-heading-4 { padding-left: 2em; }
+div.contents div.contents-heading-4 a:active { color: #333333; }
+div.contents div.contents-heading-4 a:link { color: #333333; }
+div.contents div.contents-heading-4 a:visited { color: #333333; }
+
+div.contents div.contents-heading-5 { padding-left: 2.5em; }
+div.contents div.contents-heading-5 a:active { color: #333333; }
+div.contents div.contents-heading-5 a:link { color: #333333; }
+div.contents div.contents-heading-5 a:visited { color: #333333; }
+
+.footer { color: #000000; font-family: arial; font-size: small; }
+.footer a:active { color: #000000; }
+.footer a:link { color: #000000; }
+.footer a:visited { color: #000000; }
+
+.nav-links { font-size: x-small; float: right; margin-top: -2em; }
\ No newline at end of file
Added: branches/trunk-reorg/thirdparty/arnesi/src/accumulation.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/accumulation.lisp Mon Feb 11 08:38:43 2008
@@ -0,0 +1,150 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * Reducing and Collecting
+
+;;;; ** Reducing
+
+;;;; reducing is the act of taking values, two at a time, and
+;;;; combining them, with the aid of a reducing function, into a
+;;;; single final value.
+
+(defun make-reducer (function &optional (initial-value nil initial-value-p))
+ "Create a function which, starting with INITIAL-VALUE, reduces
+any other values into a single final value.
+
+FUNCTION will be called with two values: the current value and
+the new value, in that order. FUNCTION should return exactly one
+value.
+
+The reducing function can be called with n arguments which will
+be applied to FUNCTION one after the other (left to right) and
+will return the new value.
+
+If the reducing function is called with no arguments it will
+return the current value.
+
+Example:
+
+ (setf r (make-reducer #'+ 5))
+ (funcall r 0) => 5
+ (funcall r 1 2) => 8
+ (funcall r) => 8"
+ (let ((value initial-value))
+ (lambda (&rest next)
+ (when next
+ ;; supplied a value, reduce
+ (if initial-value-p
+ ;; have a value to test against
+ (dolist (n next)
+ (setf value (funcall function value n)))
+ ;; nothing to test againts yet
+ (setf initial-value-p t
+ value next)))
+ ;; didn't supply a value, return the current value
+ value)))
+
+(defmacro with-reducer ((name function &optional (initial-value nil))
+ &body body)
+ "Locally bind NAME to a reducing function. The arguments
+FUNCTION and INITIAL-VALUE are passed directly to MAKE-REDUCER."
+ (with-unique-names (reducer)
+ `(let ((,reducer (make-reducer ,function ,@(list initial-value))))
+ (flet ((,name (&rest items)
+ (if items
+ (dolist (i items)
+ (funcall ,reducer i))
+ (funcall ,reducer))))
+ , at body))))
+
+;;;; ** Collecting
+;;;;
+;;;; Building up a list from multiple values.
+
+(defun make-collector (&optional initial-value)
+ "Create a collector function.
+
+A Collector function will collect, into a list, all the values
+passed to it in the order in which they were passed. If the
+callector function is called without arguments it returns the
+current list of values."
+ (let ((value initial-value)
+ (cdr (last initial-value)))
+ (lambda (&rest items)
+ (if items
+ (progn
+ (if value
+ (if cdr
+ (setf (cdr cdr) items
+ cdr (last items))
+ (setf cdr (last items)))
+ (setf value items
+ cdr (last items)))
+ items)
+ value))))
+
+(defun make-pusher (&optional initial-value)
+ "Create a function which collects values as by PUSH."
+ (let ((value initial-value))
+ (lambda (&rest items)
+ (if items
+ (progn
+ (dolist (i items)
+ (push i value))
+ items)
+ value))))
+
+(defmacro with-collector ((name &optional initial-value from-end) &body body)
+ "Bind NAME to a collector function and execute BODY. If
+ FROM-END is true the collector will actually be a pusher, (see
+ MAKE-PUSHER), otherwise NAME will be bound to a collector,
+ (see MAKE-COLLECTOR)."
+ (with-unique-names (collector)
+ `(let ((,collector ,(if from-end
+ `(make-pusher ,initial-value)
+ `(make-collector ,initial-value))))
+ (flet ((,name (&rest items)
+ (if items
+ (dolist (i items)
+ (funcall ,collector i))
+ (funcall ,collector))))
+ , at body))))
+
+(defmacro with-collectors (names &body body)
+ "Bind multiple collectors. Each element of NAMES should be a
+ list as per WITH-COLLECTOR's first orgument."
+ (if names
+ `(with-collector ,(ensure-list (car names))
+ (with-collectors ,(cdr names) , at body))
+ `(progn , at body)))
+
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;; - Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;;
+;; - Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;;
+;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;; of its contributors may be used to endorse or promote products
+;; derived from this software without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Added: branches/trunk-reorg/thirdparty/arnesi/src/asdf.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/asdf.lisp Mon Feb 11 08:38:43 2008
@@ -0,0 +1,100 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * ASDF extras
+
+;;;; ** CLEAN-OP - An intelligent make clean for ASDF
+
+(defclass clean-op (asdf:operation)
+ ((for-op :accessor for-op :initarg :for-op :initform 'asdf:compile-op))
+ (:documentation "Removes any files generated by an asdf component."))
+
+(defmethod asdf:perform ((op clean-op) (c asdf:component))
+ "Delete all the output files generated by the component C."
+ (dolist (f (asdf:output-files (make-instance (for-op op)) c))
+ (when (probe-file f)
+ (delete-file f))))
+
+(defmethod asdf:operation-done-p ((op clean-op) (c asdf:component))
+ "Returns T when the output-files of (for-op OP) C don't exist."
+ (dolist (f (asdf:output-files (make-instance (for-op op)) c))
+ (when (probe-file f) (return-from asdf:operation-done-p nil)))
+ t)
+
+;;;; ** Creating a single .fas or .fasl file
+
+;;;; Instead of creating images another way to distribute systems is
+;;;; to create a single compiled file containing all the code. This is
+;;;; only possible on some lisps, sbcl and clisp are the only ones
+;;;; supported for now.
+
+;;;; NB: Unlike the CLEAN-OP this is experimental (its now to have
+;;;; problems on multiple systems with non-trivial dependencies).
+
+(defun make-single-fasl (system-name
+ &key (op (make-instance 'asdf:load-op))
+ output-file)
+ (let* ((system (asdf:find-system system-name))
+ (steps (asdf::traverse op system))
+ (output-file (or output-file
+ (compile-file-pathname
+ (make-pathname
+ :name (asdf:component-name system)
+ :defaults (asdf:component-pathname system)))))
+ (*buffer* (make-array 4096 :element-type '(unsigned-byte 8)
+ :adjustable t)))
+ (declare (special *buffer*))
+ (with-output-to-file (*fasl* output-file
+ :if-exists :error
+ :element-type '(unsigned-byte 8))
+ (declare (special *fasl*))
+ (dolist (s steps)
+ (process-step (car s) (cdr s) output-file)))))
+
+(defgeneric process-step (op comp output-file))
+
+(defmethod process-step
+ ((op asdf:load-op) (file asdf:cl-source-file) output-file)
+ (declare (ignore output-file)
+ (special *buffer* *fasl*))
+ (dolist (fasl (asdf:output-files (make-instance 'asdf:compile-op) file))
+ (with-input-from-file (input (truename fasl)
+ :element-type '(unsigned-byte 8))
+ (setf *buffer* (adjust-array *buffer* (file-length input)))
+ (read-sequence *buffer* input)
+ (write-sequence *buffer* *fasl*))))
+
+(defmethod process-step ((op asdf:operation) (comp asdf:component) output-file)
+ (declare (ignore output-file))
+ (format t "Ignoring step ~S on ~S.~%" op comp))
+
+;; Copyright (c) 2002-2003, Edward Marco Baringer
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;; - Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;;
+;; - Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;;
+;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;; of its contributors may be used to endorse or promote products
+;; derived from this software without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Added: branches/trunk-reorg/thirdparty/arnesi/src/bracket-reader.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/bracket-reader.lisp Mon Feb 11 08:38:43 2008
@@ -0,0 +1,88 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * {} syntax for local readtable modifications
+
+(defun |{-reader| (stream char)
+ (declare (ignore char))
+ "A utility read macro for modifying the read table.
+
+The syntax is:
+
+ {SPECIFIER ...}
+
+SPECIFIER is either a symbol naming a function (available at read
+time) or a list (SPECIFIER &rest ARGUMENTS). SPECIFIER is applied
+to ARGUMENTS to produce a function, this is then called and
+passed another function which reads until the #\}
+character. During the executen of the function *readtable* is
+bound to a copy of the current read table.
+
+See WITH-PACKAGE for an example of a specifier function."
+ (let ((*readtable* (copy-readtable *readtable* nil)))
+ (destructuring-bind (specifier &rest arguments)
+ (ensure-list (read stream t nil t))
+ (funcall (apply specifier arguments)
+ (lambda ()
+ (read-delimited-list #\} stream t))))))
+
+(defmacro enable-bracket-syntax ()
+ "Enable bracket reader for the rest of the file (being loaded or compiled).
+Be careful when using in different situations, because it modifies *readtable*."
+ ;; The standard sais that *readtable* is restored after loading/compiling a file,
+ ;; so we make a copy and alter that. The effect is that it will be enabled
+ ;; for the rest of the file being processed.
+ `(eval-when (:compile-toplevel :execute)
+ (setf *readtable* (copy-readtable *readtable*))
+ (set-macro-character #\{ #'|{-reader| t *readtable*)
+ (set-syntax-from-char #\} #\) *readtable*)))
+
+(defmacro enable-bracket-reader ()
+ "TODO Obsolete, use the enable-bracket-syntax macro."
+ ;; (warn "Use the enable-bracket-syntax macro instead of enable-bracket-reader")
+ `(enable-bracket-syntax))
+
+(defun with-package (package-name)
+ "When used as a specifier for the #\{ reader locally rebinds,
+at read time, the current package to PACKAGE-NAME.
+
+For example, this:
+
+ {(with-package :cl-user) t}
+
+Will always read cl:t, no matter what the current package
+actually is."
+ (lambda (reader)
+ (let ((*package* (find-package package-name)))
+ `(progn ,@(funcall reader)))))
+
+;; Copyright (c) 2006, Edward Marco Baringer
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;; - Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;;
+;; - Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;;
+;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;; of its contributors may be used to endorse or promote products
+;; derived from this software without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Added: branches/trunk-reorg/thirdparty/arnesi/src/call-cc/apply.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/call-cc/apply.lisp Mon Feb 11 08:38:43 2008
@@ -0,0 +1,354 @@
+;; -*- lisp -*-
+
+(in-package :arnesi)
+
+;;;; FUNCTION
+
+(defmethod evaluate/cc ((func free-function-object-form) lex-env dyn-env k)
+ (declare (ignore lex-env dyn-env))
+ (multiple-value-bind (definition cc-boundp)
+ (fdefinition/cc (name func))
+ (if cc-boundp
+ (kontinue k definition)
+ (if (fboundp (name func))
+ (kontinue k (fdefinition (name func)))
+ (error "Unbound function ~S." (name func))))))
+
+(defmethod evaluate/cc ((func local-function-object-form) lex-env dyn-env k)
+ (declare (ignore dyn-env))
+ (kontinue k (lookup lex-env :flet (name func) :error-p t)))
+
+(defclass closure/cc ()
+ ((code :accessor code :initarg :code)
+ (env :accessor env :initarg :env))
+ #+sbcl (:metaclass mopp:funcallable-standard-class))
+
+#+sbcl
+(defmethod initialize-instance :after ((fun closure/cc) &rest initargs)
+ (declare (ignore initargs))
+ (mopp:set-funcallable-instance-function
+ fun
+ #'(lambda (&rest args)
+ (drive-interpreter/cc
+ (apply-lambda/cc fun
+ args
+ '()
+ *toplevel-k*)))))
+
+;;;; LAMBDA
+
+(defmethod evaluate/cc ((lambda lambda-function-form) lex-env dyn-env k)
+ (declare (ignore dyn-env))
+ (kontinue k (make-instance 'closure/cc :code lambda :env lex-env)))
+
+;;;; APPLY and FUNCALL
+
+(defk k-for-call/cc (k)
+ (value)
+ (if *call/cc-returns*
+ (kontinue k value)
+ (throw 'done value)))
+
+;;;; apply'ing a free (global) function
+
+(defmethod evaluate/cc ((func free-application-form) lex-env dyn-env k)
+ (cond
+ ((eql 'call/cc (operator func))
+ (evaluate/cc (make-instance 'free-application-form
+ :operator 'funcall
+ :arguments (list (first (arguments func))
+ (make-instance 'constant-form :value k :source k))
+ :source (source func))
+ lex-env dyn-env `(k-for-call/cc ,k)))
+
+ ((eql 'kall (operator func))
+ (evaluate-arguments-then-apply
+ (lambda (arguments)
+ (trace-statement "KALL'ing ~S on ~S" (first arguments) (rest arguments))
+ (apply #'kontinue (first arguments) (cdr arguments)))
+ (arguments func) '()
+ lex-env dyn-env))
+
+ ((and (eql 'call-next-method (operator func))
+ (second (multiple-value-list (lookup lex-env :next-method t))))
+ (aif (lookup lex-env :next-method t)
+ (evaluate-arguments-then-apply
+ (lambda (arguments)
+ (apply-lambda/cc it arguments dyn-env k))
+ (arguments func) '() lex-env dyn-env)
+ (error "no next method")))
+
+ ((and (eql 'next-method-p (operator func))
+ (second (multiple-value-list (lookup lex-env :next-method t))))
+ (kontinue k (lookup lex-env :next-method t)))
+
+ ((eql 'funcall (operator func))
+ (evaluate-funcall/cc (arguments func) lex-env dyn-env k))
+
+ ((eql 'apply (operator func))
+ (evaluate-apply/cc (arguments func) '() lex-env dyn-env k))
+
+ ((and (symbolp (operator func))
+ (eql 'defun/cc (nth-value 1 (fdefinition/cc (operator func)))))
+ (evaluate-arguments-then-apply
+ (lambda (arguments)
+ (trace-statement "Calling cc function ~S with arguments ~S" (operator func) arguments)
+ (apply-lambda/cc (fdefinition/cc (operator func)) arguments dyn-env k))
+ (arguments func) '()
+ lex-env dyn-env))
+
+ ((and (symbolp (operator func))
+ (eql 'defmethod/cc (nth-value 1 (fdefinition/cc (operator func)))))
+ (evaluate-arguments-then-apply
+ (lambda (arguments)
+ (trace-statement "Calling cc method ~S with arguments ~S" (operator func) arguments)
+ (apply-lambda/cc (apply (operator func) arguments) arguments dyn-env k))
+ (arguments func) '()
+ lex-env dyn-env))
+
+ (t
+ (evaluate-arguments-then-apply
+ (lambda (arguments)
+ (multiple-value-bind (vars vals)
+ (export-specials dyn-env)
+ (progv vars vals
+ (trace-statement "Calling function ~S with arguments ~S"
+ (operator func) arguments)
+ (apply #'kontinue k (multiple-value-list
+ (apply (fdefinition (operator func)) arguments))))))
+ (arguments func) '()
+ lex-env dyn-env))))
+
+;; returns a list of variables and values from the dynamic environment that should be exported
+;; these variables will be visible in normal lisp code that is called from cc code
+(defun export-specials (dyn-env)
+ ;; TODO: here we could check each special whether it has to be exported or not
+ ;; this could be based on something like (declare (export var)) in the cc code
+ (let ((dyn-env (remove-duplicates dyn-env
+ :test (lambda (x y) (eq (second x) (second y)))
+ :from-end t)))
+ (values (mapcar 'second dyn-env)
+ (mapcar 'cddr dyn-env))))
+
+;;;; apply'ing a local function
+
+(defmethod evaluate/cc ((func local-application-form) lex-env dyn-env k)
+ (evaluate-arguments-then-apply
+ (lambda (arguments)
+ (apply-lambda/cc (lookup lex-env :flet (operator func) :error-p t) arguments dyn-env k))
+ (arguments func) '()
+ lex-env dyn-env))
+
+;;;; apply'ing a lambda
+
+(defmethod evaluate/cc ((lambda lambda-application-form) lex-env dyn-env k)
+ (evaluate-funcall/cc (cons (operator lambda) (arguments lambda)) lex-env dyn-env k))
+
+;;;; Utility methods which do the actual argument evaluation, parsing
+;;;; and control transfer.
+
+(defun evaluate-funcall/cc (arguments lex-env dyn-env k)
+ (evaluate-apply/cc (append (butlast arguments)
+ (list (make-instance 'free-application-form
+ :operator 'list
+ :source `(list ,(source (car (last arguments))))
+ :arguments (last arguments))))
+ '()
+ lex-env dyn-env k))
+
+(defk k-for-apply/cc (remaining-arguments evaluated-arguments lex-env dyn-env k)
+ (value)
+ (evaluate-apply/cc (cdr remaining-arguments) (cons value evaluated-arguments)
+ lex-env dyn-env k))
+
+(defun evaluate-apply/cc (remaining-arguments evaluated-arguments lex-env dyn-env k)
+ (if remaining-arguments
+ (evaluate/cc (car remaining-arguments) lex-env dyn-env
+ `(k-for-apply/cc ,remaining-arguments ,evaluated-arguments ,lex-env ,dyn-env ,k))
+ (let ((arg-list (apply #'list* (reverse evaluated-arguments))))
+ (apply-lambda/cc (first arg-list) (rest arg-list) dyn-env k))))
+
+;;;; Finally this is the function which, given a closure/cc object and
+;;;; a list of (evaluated) arguments parses them, setup the
+;;;; environment and transfers control.
+
+(defmethod apply-lambda/cc ((operator closure/cc) effective-arguments dyn-env k)
+ (trace-statement "Applying cc closure ~S to ~S" (source (code operator)) effective-arguments)
+ (let ((lex-env (env operator))
+ (remaining-arguments effective-arguments)
+ (remaining-parameters (arguments (code operator))))
+ ;; in this code ARGUMENT refers to the values passed to the
+ ;; function. PARAMETER refers to the lambda of the closure
+ ;; object. we walk down the parameters and put the arguments in
+ ;; the environment under the proper names.
+
+ ;; first the required arguments
+ (loop
+ for parameter = (first remaining-parameters)
+ while remaining-parameters
+ do (typecase parameter
+ (required-function-argument-form
+ (if remaining-arguments
+ (setf lex-env (register lex-env :let (name parameter) (pop remaining-arguments)))
+ (error "Missing required arguments, expected ~S, got ~S."
+ (arguments (code operator)) effective-arguments))
+ (pop remaining-parameters))
+ (t (return))))
+
+ ;; handle special variables
+ (setf dyn-env (import-specials (code operator) dyn-env))
+
+ ;; now we start the chain optional->keyword->evaluate-body. We do
+ ;; this because optional and keyword parameters may have default
+ ;; values which may use call/cc.
+ (apply-lambda/cc/optional operator
+ remaining-parameters remaining-arguments
+ lex-env dyn-env k)))
+
+(defun apply-lambda/cc/optional (operator remaining-parameters remaining-arguments lex-env dyn-env k)
+ (flet ((done (remaining-parameters)
+ (return-from apply-lambda/cc/optional
+ (apply-lambda/cc/keyword
+ operator remaining-parameters remaining-arguments lex-env dyn-env k))))
+ (loop
+ for head on remaining-parameters
+ for parameter = (first head)
+ do
+ (etypecase parameter
+ (rest-function-argument-form
+ (setf lex-env (register lex-env :let (name parameter) remaining-arguments)))
+ (optional-function-argument-form
+ (if remaining-arguments
+ (progn
+ (setf lex-env (register lex-env :let (name parameter) (pop remaining-arguments)))
+ (when (supplied-p-parameter parameter)
+ (setf lex-env (register lex-env :let (supplied-p-parameter parameter) t))))
+ (return-from apply-lambda/cc/optional
+ ;; we need to evaluate a default-value, since this may
+ ;; contain call/cc we need to setup the continuation
+ ;; and let things go from there (hence the return-from)
+ (evaluate/cc (default-value parameter) lex-env dyn-env
+ `(k-for-apply/cc/optional-argument-default-value
+ ;; remaining-arguments is, by
+ ;; definition, NIL so we needn't pass
+ ;; it here.
+ ,operator ,head ,lex-env ,dyn-env ,k)))))
+ ((or keyword-function-argument-form allow-other-keys-function-argument-form)
+ ;; done with the optional args
+ (done head)))
+ finally (done head))))
+
+(defk k-for-apply/cc/optional-argument-default-value
+ (operator remaining-parameters lex-env dyn-env k)
+ (value)
+ (apply-lambda/cc/optional
+ operator (cdr remaining-parameters)
+ ;; nb: if we're evaluating the default value of an optional
+ ;; arguments then we can't have anything left in the arguments
+ ;; list.
+ nil
+ (register lex-env :let (name (first remaining-parameters)) value)
+ dyn-env
+ k))
+
+(defun apply-lambda/cc/keyword (operator remaining-parameters remaining-arguments lex-env dyn-env k)
+ ;; now any keyword parameters
+ (loop
+ for head on remaining-parameters
+ for parameter = (first head)
+ do (typecase parameter
+ (keyword-function-argument-form
+ (assert (evenp (length remaining-arguments))
+ (remaining-arguments)
+ "Odd number of arguments in ~S being applied to ~S."
+ remaining-arguments
+ (source (code operator)))
+ (let ((value (getf remaining-arguments
+ (effective-keyword-name parameter)
+ parameter)))
+ (if (eql parameter value)
+ ;; no such keyword. need to evaluate the default value
+ (return-from apply-lambda/cc/keyword
+ (evaluate/cc (default-value parameter) lex-env dyn-env
+ `(k-for-apply-lambda/cc/keyword-default-value
+ ,operator ,head ,remaining-arguments
+ ,lex-env ,dyn-env ,k)))
+ ;; keyword passed in explicitly.
+ (progn
+ (let ((value (getf remaining-arguments (effective-keyword-name parameter))))
+ (remf remaining-arguments (effective-keyword-name parameter))
+ (setf lex-env (register lex-env :let (name parameter) value))
+ (when (supplied-p-parameter parameter)
+ (setf lex-env (register lex-env :let (supplied-p-parameter parameter) t))))))))
+ (allow-other-keys-function-argument-form
+ (when (cdr remaining-parameters)
+ (error "Bad lambda list: ~S" (arguments (code operator))))
+ (return))
+ (t (unless (null remaining-parameters)
+ (error "Bad lambda list: ~S" (arguments (code operator)))))))
+ (evaluate-progn/cc (body (code operator)) lex-env dyn-env k))
+
+(defk k-for-apply-lambda/cc/keyword-default-value
+ (operator remaining-parameters remaining-arguments lex-env dyn-env k)
+ (value)
+ (apply-lambda/cc/keyword operator
+ (cdr remaining-parameters) remaining-arguments
+ (register lex-env :let (name (first remaining-parameters)) value)
+ dyn-env
+ k))
+
+(defmethod apply-lambda/cc ((operator function) effective-arguments dyn-env k)
+ "Method used when we're applying a regular, non cc, function object."
+ (declare (ignore dyn-env))
+ (trace-statement "Applying function ~S to ~S" operator effective-arguments)
+ (apply #'kontinue k (multiple-value-list (apply operator effective-arguments))))
+
+(defmethod apply-lambda/cc ((operator symbol) effective-arguments dyn-env k)
+ "Method used when we're applying a regular, non cc, function object."
+ (apply-lambda/cc (symbol-function operator) effective-arguments dyn-env k))
+
+;;;; Small helper function
+
+(defk k-for-evaluate-arguments-then-apply (handler remaining-arguments evaluated-arguments lex-env dyn-env)
+ (value)
+ (evaluate-arguments-then-apply
+ handler
+ remaining-arguments (cons value evaluated-arguments)
+ lex-env dyn-env))
+
+(defun evaluate-arguments-then-apply (handler remaining-arguments evaluated-arguments lex-env dyn-env)
+ (if remaining-arguments
+ (evaluate/cc (car remaining-arguments) lex-env dyn-env
+ `(k-for-evaluate-arguments-then-apply ,handler ,(cdr remaining-arguments)
+ ,evaluated-arguments ,lex-env ,dyn-env))
+ (funcall handler (reverse evaluated-arguments))))
+
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;; - Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;;
+;; - Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;;
+;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;; of its contributors may be used to endorse or promote products
+;; derived from this software without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Added: branches/trunk-reorg/thirdparty/arnesi/src/call-cc/common-lisp-cc.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/call-cc/common-lisp-cc.lisp Mon Feb 11 08:38:43 2008
@@ -0,0 +1,456 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; ** CC Version of some common lisp functions.
+
+(defmacro redefun/cc (name args &body body)
+ `(progn
+ (setf (fdefinition/cc ',name)
+ (make-instance 'closure/cc
+ :code (walk-form '(lambda ,args , at body) nil '())
+ :env '()))
+ ',name))
+
+(defmacro apply-key (key element)
+ `(if ,key
+ (funcall ,key ,element)
+ ,element))
+
+(redefun/cc assoc (item alist &key key (test #'eql) test-not)
+ "Return the cons in ALIST whose car is equal (by TEST) to ITEM."
+ (when test-not
+ (setq test (complement test-not)))
+ (dolist (pair alist nil)
+ (when (and pair (funcall test item (apply-key key (car pair))))
+ (return pair))))
+
+(redefun/cc assoc-if (predicate alist &key key)
+ "Return the cons in ALIST whose car satisfies PREDICATE."
+ (dolist (pair alist nil)
+ (when (and pair (funcall predicate (apply-key key (car pair))))
+ (return pair))))
+
+(redefun/cc assoc-if-not (predicate alist &key key)
+ "Return the cons in ALIST whose car does not satisfy PREDICATE."
+ (assoc-if (complement predicate) alist :key key))
+
+(redefun/cc rassoc (item alist &key key (test #'eql) test-not)
+ "Return the cons in ALIST whose cdr is equal (by TEST) to ITEM."
+ (when test-not
+ (setq test (complement test-not)))
+ (dolist (pair alist nil)
+ (when (and pair (funcall test item (apply-key key (cdr pair))))
+ (return pair))))
+
+(redefun/cc rassoc-if (predicate alist &key key)
+ "Return the cons in ALIST whose cdr satisfies PREDICATE."
+ (dolist (pair alist nil)
+ (when (and pair (funcall predicate (apply-key key (cdr pair))))
+ (return pair))))
+
+(redefun/cc rassoc-if-not (predicate alist &key key)
+ "Return the cons in ALIST whose cdr does not satisfy PREDICATE."
+ (rassoc-if (complement predicate) alist :key key))
+
+(redefun/cc sublis (alist tree &key key (test #'eql) test-not)
+ "Substitute data of ALIST for subtrees matching keys of ALIST."
+ (when test-not
+ (setq test (complement test-not)))
+ (labels ((sub (subtree)
+ (let ((assoc (assoc (apply-key key subtree) alist :test test)))
+ (cond
+ (assoc (cdr assoc))
+ ((atom subtree) subtree)
+ (t (let ((car (sub (car subtree)))
+ (cdr (sub (cdr subtree))))
+ (if (and (eq car (car subtree)) (eq cdr (cdr subtree)))
+ subtree
+ (cons car cdr))))))))
+ (sub tree)))
+
+(redefun/cc nsublis (alist tree &key key (test #'eql) test-not)
+ "Substitute data of ALIST for subtrees matching keys of ALIST destructively."
+ (when test-not
+ (setq test (complement test-not)))
+ (labels ((sub (subtree)
+ (let ((assoc (assoc (apply-key key subtree) alist :test test)))
+ (cond
+ (assoc (cdr assoc))
+ ((atom subtree) subtree)
+ (t
+ (rplaca subtree (sub (car subtree)))
+ (rplacd subtree (sub (cdr subtree)))
+ subtree)))))
+ (sub tree)))
+
+(redefun/cc subst (new old tree &key key (test #'eql) test-not)
+ "Substitute NEW for subtrees matching OLD."
+ (when test-not
+ (setq test (complement test-not)))
+ (labels ((sub (subtree)
+ (cond
+ ((funcall test old (apply-key key subtree)) new)
+ ((atom subtree) subtree)
+ (t (let ((car (sub (car subtree)))
+ (cdr (sub (cdr subtree))))
+ (if (and (eq car (car subtree)) (eq cdr (cdr subtree)))
+ subtree
+ (cons car cdr)))))))
+ (sub tree)))
+
+(redefun/cc nsubst (new old tree &key key (test #'eql) test-not)
+ "Substitute NEW for subtrees matching OLD destructively."
+ (when test-not
+ (setq test (complement test-not)))
+ (labels ((sub (subtree)
+ (cond
+ ((funcall test old (apply-key key subtree)) new)
+ ((atom subtree) subtree)
+ (t (rplaca subtree (sub (car subtree)))
+ (rplacd subtree (sub (cdr subtree)))
+ subtree))))
+ (sub tree)))
+
+(redefun/cc subst-if (new predicate tree &key key)
+ "Substitute NEW for subtrees for which PREDICATE is true."
+ (labels ((sub (subtree)
+ (cond
+ ((funcall predicate (apply-key key subtree)) new)
+ ((atom subtree) subtree)
+ (t (let ((car (sub (car subtree)))
+ (cdr (sub (cdr subtree))))
+ (if (and (eq car (car subtree)) (eq cdr (cdr subtree)))
+ subtree
+ (cons car cdr)))))))
+ (sub tree)))
+
+(redefun/cc subst-if-not (new predicate tree &key key)
+ "Substitute NEW for subtrees for which PREDICATE is false."
+ (subst-if new (complement predicate) tree :key key))
+
+(redefun/cc nsubst-if (new predicate tree &key key)
+ "Substitute NEW for subtrees for which PREDICATE is true destructively."
+ (labels ((sub (subtree)
+ (cond
+ ((funcall predicate (apply-key key subtree)) new)
+ ((atom subtree) subtree)
+ (t (rplaca subtree (sub (car subtree)))
+ (rplacd subtree (sub (cdr subtree)))
+ subtree))))
+ (sub tree)))
+
+(redefun/cc nsubst-if-not (new predicate tree &key key)
+ "Substitute NEW for subtrees for which PREDICATE is false destructively."
+ (nsubst-if new (complement predicate) tree :key key))
+
+(redefun/cc tree-equal (a b &key (test #'eql) test-not)
+ "Test whether two trees are of the same shape and have the same leaves."
+ (when test-not
+ (setq test (complement test-not)))
+ (labels ((teq (a b)
+ (if (atom a)
+ (and (atom b) (funcall test a b))
+ (and (consp b)
+ (teq (car a) (car b))
+ (teq (cdr a) (cdr b))))))
+ (teq a b)))
+
+(redefun/cc member (item list &key key (test #'eql) test-not)
+ "Return the tail of LIST beginning with an element equal to ITEM."
+ (when test-not
+ (setq test (complement test-not)))
+ (do ((here list (cdr here)))
+ ((or (null here) (funcall test item (apply-key key (car here)))) here)))
+
+(redefun/cc member-if (predicate list &key key)
+ "Return the tail of LIST beginning with an element satisfying PREDICATE."
+ (do ((here list (cdr here)))
+ ((or (endp here) (funcall predicate (apply-key key (car here)))) here)))
+
+(redefun/cc member-if-not (predicate list &key key)
+ "Return the tail of LIST beginning with an element not satisfying PREDICATE."
+ (member-if (complement predicate) list :key key))
+
+(redefun/cc adjoin (item list &key key (test #'eql) test-not)
+ "Add ITEM to LIST unless it is already a member."
+ (when test-not
+ (setq test (complement test-not)))
+ (if (member (apply-key key item) list :key key :test test)
+ list
+ (cons item list)))
+
+(redefun/cc intersection (list-1 list-2 &key key (test #'eql) test-not)
+ "Return the intersection of LIST-1 and LIST-2."
+ (when test-not
+ (setq test (complement test-not)))
+ (let (result)
+ (dolist (element list-1)
+ (when (member (apply-key key element) list-2 :key key :test test)
+ (push element result)))
+ result))
+
+(redefun/cc nintersection (list-1 list-2 &key key (test #'eql) test-not)
+ "Return the intersection of LIST-1 and LIST-2 destructively modifying LIST-1."
+ (when test-not
+ (setq test (complement test-not)))
+ (let* ((result (list nil))
+ (splice result))
+ (do ((list list-1 (cdr list)))
+ ((endp list) (rplacd splice nil) (cdr result))
+ (when (member (apply-key key (car list)) list-2 :key key :test test)
+ (setq splice (cdr (rplacd splice list)))))))
+
+(redefun/cc union (list-1 list-2 &key key (test #'eql) test-not)
+ "Return the union of LIST-1 and LIST-2."
+ (when test-not
+ (setq test (complement test-not)))
+ (let ((result list-2))
+ (dolist (element list-1)
+ (unless (member (apply-key key element) list-2 :key key :test test)
+ (push element result)))
+ result))
+
+(redefun/cc nunion (list-1 list-2 &key key (test #'eql) test-not)
+ "Return the union of LIST-1 and LIST-2 destructively modifying them."
+ (when test-not
+ (setq test (complement test-not)))
+ (do* ((result list-2)
+ (list-1 list-1)
+ tmp)
+ ((endp list-1) result)
+ (if (member (apply-key key (car list-1)) list-2 :key key :test test)
+ (setq list-1 (cdr list-1))
+ (setq tmp (cdr list-1)
+ result (rplacd list-1 result)
+ list-1 tmp))))
+
+(redefun/cc subsetp (list-1 list-2 &key key (test #'eql) test-not)
+ "Return T if every element in LIST-1 is also in LIST-2."
+ (when test-not
+ (setq test (complement test-not)))
+ (dolist (element list-1 t)
+ (unless (member (apply-key key element) list-2 :key key :test test)
+ (return nil))))
+
+(redefun/cc set-difference (list-1 list-2 &key key (test #'eql) test-not)
+ "Return the elements of LIST-1 which are not in LIST-2."
+ (when test-not
+ (setq test (complement test-not)))
+ (let ((result nil))
+ (dolist (element list-1)
+ (unless (member (apply-key key element) list-2 :key key :test test)
+ (push element result)))
+ result))
+
+(redefun/cc nset-difference (list-1 list-2 &key key (test #'eql) test-not)
+ "Return the elements of LIST-1 which are not in LIST-2, modifying LIST-1."
+ (when test-not
+ (setq test (complement test-not)))
+ (do* ((result nil)
+ (list-1 list-1)
+ tmp)
+ ((endp list-1) result)
+ (if (member (apply-key key (car list-1)) list-2 :key key :test test)
+ (setq list-1 (cdr list-1))
+ (setq tmp (cdr list-1)
+ result (rplacd list-1 result)
+ list-1 tmp))))
+
+(redefun/cc set-exclusive-or (list-1 list-2 &key key (test #'eql) test-not)
+ "Return a list of elements that appear in exactly one of LIST-1 and LIST-2."
+ (when test-not
+ (setq test (complement test-not)))
+ (let ((result nil))
+ (dolist (element list-1)
+ (unless (member (apply-key key element) list-2 :key key :test test)
+ (push element result)))
+ (dolist (element list-2)
+ (unless (member (apply-key key element) list-1 :key key :test test)
+ (push element result)))
+ result))
+
+(redefun/cc nset-exclusive-or (list-1 list-2 &key key (test #'eql) test-not)
+ "The destructive version of set-exclusive-or."
+ (when test-not
+ (setq test (complement test-not)))
+ (do* ((head-1 (cons nil list-1))
+ (head-2 (cons nil list-2))
+ (p-1 head-1))
+ ((or (endp (cdr p-1)) (endp (cdr head-2)))
+ (progn (rplacd (last p-1) (cdr head-2))
+ (cdr head-1)))
+ (do ((p-2 head-2 (cdr p-2)))
+ ((endp (cdr p-2)) (setq p-1 (cdr p-1)))
+ (when (funcall test (apply-key key (cadr p-1)) (apply-key key (cadr p-2)))
+ (rplacd p-1 (cddr p-1))
+ (rplacd p-2 (cddr p-2))
+ (return)))))
+
+(redefun/cc mapc (function list &rest more-lists)
+ "Apply FUNCTION to successive elements of lists, return LIST."
+ (do* ((lists (cons list more-lists))
+ (args (make-list (length lists))))
+ ((do ((l lists (cdr l))
+ (a args (cdr a)))
+ ((or (null l) (endp (car l))) l)
+ (rplaca a (caar l))
+ (rplaca l (cdar l)))
+ list)
+ (apply function args)))
+
+(redefun/cc mapcar (function list &rest more-lists)
+ "Apply FUNCTION to successive elements of lists, return list of results."
+ (do* ((lists (cons list more-lists))
+ (len (length lists))
+ (args (make-list len) (make-list len))
+ (result (list nil))
+ (splice result))
+ ((do ((l lists (cdr l))
+ (a args (cdr a)))
+ ((or (null l) (endp (car l))) l)
+ (rplaca a (caar l))
+ (rplaca l (cdar l)))
+ (cdr result))
+ (setq splice (cdr (rplacd splice (list (apply function args)))))))
+
+(redefun/cc mapcan (function list &rest more-lists)
+ "Apply FUNCTION to successive elements of lists, return nconc of results."
+ (apply #'nconc (apply #'mapcar function list more-lists)))
+
+(redefun/cc mapl (function list &rest more-lists)
+ "Apply FUNCTION to successive sublists of list, return LIST."
+ (do* ((lists (cons list more-lists)))
+ ((member nil lists) list)
+ (apply function lists)
+ (do ((l lists (cdr l)))
+ ((endp l))
+ (rplaca l (cdar l)))))
+
+(redefun/cc maplist (function list &rest more-lists)
+ "Apply FUNCTION to successive sublists of list, return list of results."
+ (do* ((lists (cons list more-lists))
+ (result (list nil))
+ (splice result))
+ ((member nil lists) (cdr result))
+ (setq splice (cdr (rplacd splice (list (apply function lists)))))
+ (do ((l lists (cdr l)))
+ ((endp l))
+ (rplaca l (cdar l)))))
+
+(redefun/cc mapcon (function list &rest more-lists)
+ "Apply FUNCTION to successive sublists of lists, return nconc of results."
+ (apply #'nconc (apply #'maplist function list more-lists)))
+
+(redefun/cc complement (function)
+ (lambda (&rest arguments)
+ (not (apply function arguments))))
+
+(redefun/cc list-delete-if (test list start end count key)
+ (let* ((head (cons nil list))
+ (splice head))
+ (do ((i 0 (1+ i))
+ (x list (cdr x)))
+ ((endp x) (rplacd splice nil) (cdr head))
+ (when (and count (<= count 0))
+ (rplacd splice x)
+ (return (cdr head)))
+ (if (and (<= start i) (or (null end) (< i end))
+ (funcall test (apply-key key (car x))))
+ (when count (decf count))
+ (setq splice (cdr (rplacd splice x)))))))
+
+(redefun/cc vector-delete-if (test vector start end count key)
+ (let* ((length (length vector))
+ (end (or end length))
+ (count (or count length))
+ (i 0))
+ (do* ((j 0 (1+ j))
+ element)
+ ((>= j length))
+ (setq element (aref vector j))
+ (if (and (<= start j) (< j end)
+ (plusp count)
+ (funcall test (apply-key key element)))
+ (when count (decf count))
+ (progn
+ (setf (aref vector i) element)
+ (incf i))))
+ (cond
+ ((array-has-fill-pointer-p vector)
+ (setf (fill-pointer vector) i)
+ vector)
+ ((adjustable-array-p vector) (adjust-array vector i))
+ (t (subseq vector 0 i)))))
+
+(redefun/cc delete-if (predicate sequence &key from-end (start 0) end count key)
+ "Modify SEQUENCE by deleting elements satisfying PREDICATE."
+ (if from-end
+ (let ((length (length sequence)))
+ (nreverse (delete-if predicate (nreverse sequence)
+ :start (- length (or end length))
+ :end (- length start)
+ :count count :key key)))
+ (etypecase sequence
+ (null nil)
+ (cons (list-delete-if predicate sequence start end count key))
+ (vector (vector-delete-if predicate sequence start end count key)))))
+
+(redefun/cc delete (item sequence &key from-end (test #'eql) test-not (start 0) end
+ count key)
+ "Modify SEQUENCE by deleting elements equal to ITEM."
+ (when test-not (setq test (complement test-not)))
+ (delete-if #'(lambda (arg) (funcall test item arg)) sequence
+ :from-end from-end :start start :end end :count count :key key))
+
+(redefun/cc delete-if-not (predicate sequence &key from-end (start 0) end count key)
+ "Modify SEQUENCE by deleting elements not satisfying PREDICATE."
+ (delete-if (complement predicate) sequence :from-end from-end
+ :start start :end end :count count :key key))
+
+(redefun/cc remove-if (predicate sequence &key from-end (start 0) end count key)
+ "Return a copy of SEQUENCE with elements satisfying PREDICATE removed."
+ (delete-if predicate (copy-seq sequence) :from-end from-end :start start :end end
+ :count count :key key))
+
+(redefun/cc remove (item sequence &key from-end (test #'eql) test-not (start 0)
+ end count key)
+ "Return a copy of SEQUENCE with elements equal to ITEM removed."
+ (when test-not (setq test (complement test-not)))
+ (remove-if #'(lambda (arg) (funcall test item arg)) sequence
+ :from-end from-end :start start :end end :count count :key key))
+
+(redefun/cc remove-if-not (predicate sequence &key from-end (start 0) end count key)
+ "Return a copy of SEQUENCE with elements not satisfying PREDICATE removed."
+ (remove-if (complement predicate) sequence :from-end from-end
+ :start start :end end :count count :key key))
+
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;; - Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;;
+;; - Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;;
+;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;; of its contributors may be used to endorse or promote products
+;; derived from this software without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Added: branches/trunk-reorg/thirdparty/arnesi/src/call-cc/generic-functions.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/call-cc/generic-functions.lisp Mon Feb 11 08:38:43 2008
@@ -0,0 +1,154 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; ** Functions, Generic Functions, Methods and standard-combination
+
+;;;; DEFUN/CC
+
+(defmacro defun/cc (name arguments &body body)
+ `(progn
+ (setf (fdefinition/cc ',name 'defun/cc)
+ (make-instance 'closure/cc
+ :code (walk-form '(lambda ,arguments
+ (block ,name , at body))
+ nil nil)
+ :env nil))
+ (defun ,name ,arguments
+ (declare (ignore ,@(extract-argument-names arguments)))
+ (error "Sorry, /CC function are not callable outside of with-call/cc."))))
+
+;;;; DEFGENERIC/CC
+
+(defmacro defgeneric/cc (name args &rest options)
+ "Trivial wrapper around defgeneric designed to alert readers that these methods are cc methods."
+ (assert (not (find :method options :key #'first)) () "TODO: defgeneric/cc does not walk the :method entries yet, use standalone defmethod/cc's")
+ `(progn
+ (defgeneric ,name ,args
+ , at options
+ (:method-combination cc-standard))
+ (setf (fdefinition/cc ',name 'defmethod/cc) t)))
+
+;;;; DEFMETHOD/CC
+
+; for emacs: (setf (get 'defmethod/cc 'common-lisp-indent-function) 'lisp-indent-defmethod)
+
+(defmacro defmethod/cc (name &rest args)
+ (let ((qlist (list (if (and (symbolp (car args))
+ (not (null (car args))))
+ (pop args)
+ :primary))))
+ (let ((arguments (car args))
+ (body (cdr args)))
+ `(progn
+ (unless (eq 'defmethod/cc (second (multiple-value-list (fdefinition/cc ',name))))
+ (setf (fdefinition/cc ',name 'defmethod/cc) t)
+ (defgeneric/cc ,name ,(if arguments
+ (convert-to-generic-lambda-list arguments)
+ '())))
+ (defmethod ,name , at qlist ,arguments
+ ,(when arguments
+ `(declare (ignorable ,@(extract-argument-names arguments :allow-specializers t))))
+ ,@(when (stringp (first body))
+ (list (pop body)))
+ (make-instance 'closure/cc
+ :code (walk-form '(lambda ,(clean-argument-list arguments)
+ (block ,name , at body))
+ nil nil)
+ :env nil))))))
+
+;;;; CC-STANDARD (standard-combination for cc methods)
+
+(defun closure-with-nextmethod (closure next)
+ (make-instance 'closure/cc
+ :code (code closure)
+ :env (register (env closure) :next-method t next)))
+
+(defun closure-with-befores (closure befores)
+ (make-instance 'closure/cc
+ :code (walk-form `(lambda (&rest args)
+ ,@(loop
+ for before in befores
+ collect `(apply ,before args))
+ (apply ,closure args)))
+ :env nil))
+
+(defun closure-with-afters (closure afters)
+ (make-instance 'closure/cc
+ :code (walk-form `(lambda (&rest args)
+ (prog1
+ (apply ,closure args)
+ ,@(loop
+ for after in afters
+ collect `(apply ,after args)))))
+ :env nil))
+
+(define-method-combination cc-standard
+ (&key (around-order :most-specific-first)
+ (before-order :most-specific-first)
+ (primary-order :most-specific-first)
+ (after-order :most-specific-last))
+ ((around (:around))
+ (before (:before))
+ (primary (:primary) :required t)
+ (after (:after)))
+
+ (labels ((effective-order (methods order)
+ (ecase order
+ (:most-specific-first methods)
+ (:most-specific-last (reverse methods))))
+ (primary-wrap (methods &optional nextmethod)
+ (case (length methods)
+ (1 `(closure-with-nextmethod
+ (call-method ,(first methods))
+ ,nextmethod))
+ (t `(closure-with-nextmethod
+ (call-method ,(first methods))
+ ,(primary-wrap (cdr methods) nextmethod)))))
+ (call-methods (methods)
+ `(list ,@(loop
+ for m in methods
+ collect `(call-method ,m)))))
+ (let* (;; reorder the methods based on the -order arguments
+ (around (effective-order around around-order))
+ (before (effective-order before before-order))
+ (primary (effective-order primary primary-order))
+ (after (effective-order after after-order))
+ (form (primary-wrap primary)))
+ (when after
+ (setf form `(closure-with-afters ,form ,(call-methods after))))
+ (when before
+ (setf form `(closure-with-befores ,form ,(call-methods before))))
+ (when around
+ (setf form (primary-wrap around form)))
+ form)))
+
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;; - Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;;
+;; - Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;;
+;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;; of its contributors may be used to endorse or promote products
+;; derived from this software without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Added: branches/trunk-reorg/thirdparty/arnesi/src/call-cc/handlers.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/call-cc/handlers.lisp Mon Feb 11 08:38:43 2008
@@ -0,0 +1,334 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; ** Handlres for common-lisp special operators
+
+;;;; Variable References
+
+(defmethod evaluate/cc ((var local-variable-reference) lex-env dyn-env k)
+ (declare (ignore dyn-env))
+ (kontinue k (lookup lex-env :let (name var) :error-p t)))
+
+(defmethod evaluate/cc ((var local-lexical-variable-reference) lex-env dyn-env k)
+ (declare (ignore dyn-env))
+ (kontinue k (funcall (first (lookup lex-env :lexical-let (name var) :error-p t)))))
+
+(defmethod evaluate/cc ((var free-variable-reference) lex-env dyn-env k)
+ (declare (ignore lex-env))
+ (multiple-value-bind (value foundp)
+ (lookup dyn-env :let (name var))
+ (if foundp
+ (kontinue k value)
+ (kontinue k (symbol-value (name var))))))
+
+;;;; Constants
+
+(defmethod evaluate/cc ((c constant-form) lex-env dyn-env k)
+ (declare (ignore lex-env dyn-env))
+ (kontinue k (value c)))
+
+;;;; BLOCK/RETURN-FROM
+
+(defmethod evaluate/cc ((block block-form) lex-env dyn-env k)
+ (evaluate-progn/cc (body block)
+ (register lex-env :block (name block) k)
+ dyn-env k))
+
+(defmethod evaluate/cc ((return return-from-form) lex-env dyn-env k)
+ (declare (ignore k))
+ (evaluate/cc (result return)
+ lex-env dyn-env
+ (lookup lex-env :block (name (target-block return)) :error-p t)))
+
+;;;; CATCH/THROW
+
+(defmethod evaluate/cc ((catch catch-form) lex-env dyn-env k)
+ (evaluate/cc (tag catch) lex-env dyn-env
+ `(catch-tag-k ,catch ,lex-env ,dyn-env ,k)))
+
+(defk catch-tag-k (catch lex-env dyn-env k)
+ (tag)
+ (evaluate-progn/cc (body catch) lex-env (register dyn-env :catch tag k) k))
+
+(defmethod evaluate/cc ((throw throw-form) lex-env dyn-env k)
+ (evaluate/cc (tag throw) lex-env dyn-env
+ `(throw-tag-k ,throw ,lex-env ,dyn-env ,k)))
+
+(defk throw-tag-k (throw lex-env dyn-env k)
+ (tag)
+ (evaluate/cc (value throw) lex-env dyn-env
+ (lookup dyn-env :catch tag :error-p t)))
+
+;;;; FLET/LABELS
+
+(defmethod evaluate/cc ((flet flet-form) lex-env dyn-env k)
+ (let ((new-env lex-env))
+ (dolist* ((name . form) (binds flet))
+ (setf new-env (register new-env :flet name (make-instance 'closure/cc
+ :code form
+ :env lex-env))))
+ (evaluate-progn/cc (body flet) new-env dyn-env k)))
+
+(defmethod evaluate/cc ((labels labels-form) lex-env dyn-env k)
+ (let ((closures '()))
+ (dolist* ((name . form) (binds labels))
+ (let ((closure (make-instance 'closure/cc :code form)))
+ (setf lex-env (register lex-env :flet name closure))
+ (push closure closures)))
+ (dolist (closure closures)
+ (setf (env closure) lex-env))
+ (evaluate-progn/cc (body labels) lex-env dyn-env k)))
+
+;;;; LET/LET*
+
+;; returns a dynamic environment that holds the special variables imported for let
+;; these variables are captured from the caller normal lisp code and stored within
+;; the continuation. The mixin might be a binding-form-mixin and implicit-progn-with-declare-mixin.
+(defun import-specials (mixin dyn-env)
+ (dolist (declaration (declares mixin))
+ (let ((name (name declaration)))
+ (if (and (typep declaration 'special-declaration-form)
+ (or (not (typep mixin 'binding-form-mixin))
+ (not (find name (binds mixin) :key 'first)))
+ (not (lookup dyn-env :let name)))
+ (setf dyn-env (register dyn-env :let name (symbol-value name))))))
+ dyn-env)
+
+(defmethod evaluate/cc ((let let-form) lex-env dyn-env k)
+ (evaluate-let/cc (binds let) nil (body let) lex-env (import-specials let dyn-env) k))
+
+(defk k-for-evaluate-let/cc (var remaining-bindings evaluated-bindings body lex-env dyn-env k)
+ (value)
+ (evaluate-let/cc remaining-bindings
+ (cons (cons var value) evaluated-bindings)
+ body lex-env dyn-env k))
+
+(defun evaluate-let/cc (remaining-bindings evaluated-bindings body lex-env dyn-env k)
+ (if remaining-bindings
+ (destructuring-bind (var . initial-value)
+ (car remaining-bindings)
+ (evaluate/cc
+ initial-value
+ lex-env dyn-env
+ `(k-for-evaluate-let/cc
+ ,var
+ ,(cdr remaining-bindings)
+ ,evaluated-bindings
+ ,body
+ ,lex-env ,dyn-env ,k)))
+ (dolist* ((var . value) evaluated-bindings
+ (evaluate-progn/cc body lex-env dyn-env k))
+ (if (special-var-p var (parent (first body)))
+ (setf dyn-env (register dyn-env :let var value))
+ (setf lex-env (register lex-env :let var value))))))
+
+(defun special-var-p (var declares-mixin)
+ (or (find-if (lambda (declaration)
+ (and (typep declaration 'special-declaration-form)
+ (eq (name declaration) var)))
+ (declares declares-mixin))
+ (boundp var)
+ ;; This is the only portable way to check if a symbol is
+ ;; declared special, without being boundp, i.e. (defvar 'foo).
+ ;; Maybe we should make it optional with a compile-time flag?
+ #+nil(eval `((lambda ()
+ (flet ((func ()
+ (symbol-value ',var)))
+ (let ((,var t))
+ (declare (ignorable ,var))
+ (ignore-errors (func)))))))))
+
+(defmethod evaluate/cc ((let* let*-form) lex-env dyn-env k)
+ (evaluate-let*/cc (binds let*) (body let*) lex-env (import-specials let* dyn-env) k))
+
+(defk k-for-evaluate-let*/cc (var bindings body lex-env dyn-env k)
+ (value)
+ (if (special-var-p var (parent (first body)))
+ (evaluate-let*/cc bindings body
+ lex-env
+ (register dyn-env :let var value)
+ k)
+ (evaluate-let*/cc bindings body
+ (register lex-env :let var value)
+ dyn-env
+ k)))
+
+(defun evaluate-let*/cc (bindings body lex-env dyn-env k)
+ (if bindings
+ (destructuring-bind (var . initial-value)
+ (car bindings)
+ (evaluate/cc initial-value lex-env dyn-env
+ `(k-for-evaluate-let*/cc ,var ,(cdr bindings) ,body ,lex-env ,dyn-env ,k)))
+ (evaluate-progn/cc body lex-env dyn-env k)))
+
+;;;; IF
+
+(defk k-for-evaluate-if/cc (then else lex-env dyn-env k)
+ (value)
+ (if value
+ (evaluate/cc then lex-env dyn-env k)
+ (evaluate/cc else lex-env dyn-env k)))
+
+(defmethod evaluate/cc ((if if-form) lex-env dyn-env k)
+ (evaluate/cc (consequent if) lex-env dyn-env
+ `(k-for-evaluate-if/cc ,(then if) ,(else if) ,lex-env ,dyn-env ,k)))
+
+;;;; LOCALLY
+
+(defmethod evaluate/cc ((locally locally-form) lex-env dyn-env k)
+ (evaluate-progn/cc (body locally) lex-env dyn-env k))
+
+;;;; MACROLET
+
+(defmethod evaluate/cc ((macrolet macrolet-form) lex-env dyn-env k)
+ ;; since the walker already performs macroexpansion there's nothing
+ ;; left to do here.
+ (evaluate-progn/cc (body macrolet) lex-env dyn-env k))
+
+;;;; multiple-value-call
+
+(defk k-for-m-v-c (remaining-arguments evaluated-arguments lex-env dyn-env k)
+ (value other-values)
+ (evaluate-m-v-c
+ remaining-arguments (append evaluated-arguments (list value) other-values)
+ lex-env dyn-env k))
+
+(defun evaluate-m-v-c (remaining-arguments evaluated-arguments lex-env dyn-env k)
+ (if remaining-arguments
+ (evaluate/cc (car remaining-arguments) lex-env dyn-env
+ `(k-for-m-v-c ,(cdr remaining-arguments) ,evaluated-arguments ,lex-env ,dyn-env ,k))
+ (destructuring-bind (function &rest arguments)
+ evaluated-arguments
+ (etypecase function
+ (closure/cc (apply-lambda/cc function arguments dyn-env k))
+ (function (apply #'kontinue k (multiple-value-list
+ (multiple-value-call function (values-list arguments)))))))))
+
+(defmethod evaluate/cc ((m-v-c multiple-value-call-form) lex-env dyn-env k)
+ (evaluate-m-v-c (list* (func m-v-c) (arguments m-v-c)) '() lex-env dyn-env k))
+
+;;;; PROGN
+
+(defmethod evaluate/cc ((progn progn-form) lex-env dyn-env k)
+ (evaluate-progn/cc (body progn) lex-env dyn-env k))
+
+(defk k-for-evaluate-progn/cc (rest-of-body lex-env dyn-env k)
+ ()
+ (evaluate-progn/cc rest-of-body lex-env dyn-env k))
+
+(defun evaluate-progn/cc (body lex-env dyn-env k)
+ (cond
+ ((cdr body)
+ (evaluate/cc (first body) lex-env dyn-env
+ `(k-for-evaluate-progn/cc ,(cdr body) ,lex-env ,dyn-env ,k)))
+ (body
+ (evaluate/cc (first body) lex-env dyn-env k))
+ (t
+ (kontinue k nil))))
+
+;;;; SETQ
+
+(defk k-for-local-setq (var lex-env dyn-env k)
+ (value)
+ (setf (lookup lex-env :let var :error-p t) value)
+ (kontinue k value))
+
+(defk k-for-free-setq (var lex-env dyn-env k)
+ (value)
+ (setf (symbol-value var) value)
+ (kontinue k value))
+
+(defk k-for-local-lexical-setq (var lex-env dyn-env k)
+ (value)
+ (funcall (second (lookup lex-env :lexical-let var :error-p t)) value)
+ (kontinue k value))
+
+(defmethod evaluate/cc ((setq setq-form) lex-env dyn-env k)
+ (macrolet ((if-found (&key in-env of-type kontinue-with)
+ `(multiple-value-bind (value foundp)
+ (lookup ,in-env ,of-type (var setq))
+ (declare (ignore value))
+ (when foundp
+ (return-from evaluate/cc
+ (evaluate/cc (value setq) lex-env dyn-env
+ `(,',kontinue-with ,(var setq) ,lex-env ,dyn-env ,k)))))))
+ (if-found :in-env lex-env
+ :of-type :let
+ :kontinue-with k-for-local-setq)
+ (if-found :in-env dyn-env
+ :of-type :let
+ :kontinue-with k-for-special-setq)
+ (if-found :in-env lex-env
+ :of-type :lexical-let
+ :kontinue-with k-for-local-lexical-setq)
+ (evaluate/cc (value setq)
+ lex-env dyn-env
+ `(k-for-free-setq ,(var setq) ,lex-env ,dyn-env ,k))))
+
+;;;; SYMBOL-MACROLET
+
+(defmethod evaluate/cc ((symbol-macrolet symbol-macrolet-form) lex-env dyn-env k)
+ ;; like macrolet the walker has already done all the work needed for this.
+ (evaluate-progn/cc (body symbol-macrolet) lex-env dyn-env k))
+
+;;;; TAGBODY/GO
+
+(defk tagbody-k (k)
+ ()
+ (kontinue k nil))
+
+(defmethod evaluate/cc ((tagbody tagbody-form) lex-env dyn-env k)
+ (evaluate-progn/cc (body tagbody)
+ (register lex-env :tag tagbody k) dyn-env
+ `(tagbody-k ,k)))
+
+(defmethod evaluate/cc ((go-tag go-tag-form) lex-env dyn-env k)
+ (declare (ignore go-tag lex-env dyn-env))
+ (kontinue k nil))
+
+(defmethod evaluate/cc ((go go-form) lex-env dyn-env k)
+ (declare (ignore k))
+ (evaluate-progn/cc (target-progn go) lex-env dyn-env
+ (lookup lex-env :tag (enclosing-tagbody go) :error-p t)))
+
+;;;; THE
+
+(defmethod evaluate/cc ((the the-form) lex-env dyn-env k)
+ (evaluate/cc (value the) lex-env dyn-env k))
+
+;;;; LOAD-TIME-VALUE
+
+(defmethod evaluate/cc ((c load-time-value-form) lex-env dyn-env k)
+ (declare (ignore lex-env dyn-env))
+ (kontinue k (value c)))
+
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;; - Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;;
+;; - Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;;
+;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;; of its contributors may be used to endorse or promote products
+;; derived from this software without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Added: branches/trunk-reorg/thirdparty/arnesi/src/call-cc/interpreter.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/call-cc/interpreter.lisp Mon Feb 11 08:38:43 2008
@@ -0,0 +1,206 @@
+;;;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * A Common Lisp interpreter with support for continuations.
+
+;;;; Notes:
+
+;;;; This interpreter is dependent on the object tree built up by the
+;;;; code walker in walk.lisp.
+
+;;;; One of the, final, goals of this interpeter was to allow
+;;;; continuations to be serializable. Due to this constraint we
+;;;; represent continuations as regular lists which, when the cdr
+;;;; (which must be clos objects or literals) is applied to the car
+;;;; (which must be a symbol) the actual contiunation (a regular
+;;;; common lisp function) is returned.
+
+(defvar *call/cc-returns* nil)
+
+(defmacro with-call/cc (&environment e &body body)
+ "Execute BODY with delimited partial continuations.
+
+ Within the code of BODY almost all common lisp forms maintain
+ their normal semantics. The following special forms are
+ allowed:
+
+ (call/cc LAMBDA) - LAMBDA, a one argument function, will be
+ passed a continuation. This object may then be passed to the
+ function KALL which will cause execution to resume around the
+ call/cc form. "
+ (let ((walk-env (make-walk-env e))
+ (evaluate-env nil))
+ (dolist* ((type name &rest data) (car walk-env))
+ (declare (ignore data))
+ (when (eql :lexical-let type)
+ (push (list 'list
+ :lexical-let
+ `(quote ,name)
+ ;; NB: this makes the environment, and therefore
+ ;; continuations, unserializable. we would need to
+ ;; change this to a regular :let and not allow the
+ ;; setting of lexical variables.
+ `(lambda () ,name)
+ (with-unique-names (v)
+ `(lambda (,v) (setf ,name ,v))))
+ evaluate-env)))
+ (setf evaluate-env `(list ,@(nreverse evaluate-env)))
+ `(drive-interpreter/cc
+ (evaluate/cc ,(walk-form (if (rest body)
+ `(progn , at body)
+ (first body))
+ nil walk-env)
+ ,evaluate-env nil
+ *toplevel-k*))))
+
+(defun kall (k &optional (primary-value nil primary-value-p)
+ &rest other-values)
+ "Continue the continuation K.
+
+This function can be used within the lexical scope of
+with-call/cc and outside, though it has slightly different
+semantics."
+ (drive-interpreter/cc
+ (lambda ()
+ (let ((k (apply (car k) (cdr k))))
+ (cond
+ (other-values (apply k primary-value other-values))
+ (primary-value-p (funcall k primary-value))
+ (t (funcall k nil)))))))
+
+(defvar *cc-functions* (make-hash-table :test 'eql))
+
+(defun fmkunbound/cc (function-name)
+ (remhash function-name *cc-functions*))
+
+(defun fdefinition/cc (function-name)
+ (values-list (gethash function-name *cc-functions*)))
+
+(defun (setf fdefinition/cc) (closure-object function-name &optional (type 'defun/cc))
+ (setf (gethash function-name *cc-functions*) (list closure-object type)))
+
+(defvar *debug-evaluate/cc* nil
+ "When non NIL the evaluator will print, at each evaluation
+ step, what it's evaluating and the value passed in from the
+ previous step.
+
+If set to :FULL then at each step we print the form, the
+environment and the continuation. If set to T we just print the
+form being evaluated.")
+
+;;;; Implementation
+
+(defun drive-interpreter/cc (code)
+ (catch 'done
+ (loop for thunk = code then (funcall thunk))))
+
+(defmacro let/cc (k &body body)
+ `(call/cc (lambda (,k) , at body)))
+
+(defmacro retk ()
+ `(let/cc k k))
+
+(defmacro klambda ((&optional (value (gensym) valuep) (other-values (gensym) other-values-p))
+ &body body)
+ (cond
+ (other-values-p `(lambda (&optional ,value &rest ,other-values)
+ (lambda ()
+ , at body)))
+ (valuep `(lambda (&optional ,value &rest ,other-values)
+ (declare (ignore ,other-values))
+ (lambda ()
+ , at body)))
+ (t `(lambda (&optional ,value &rest ,other-values)
+ (declare (ignore ,value ,other-values))
+ (lambda ()
+ , at body)))))
+
+(defvar *trace-cc* nil
+ "Variable which controls the tracing of WITH-CALL/CC code.
+
+When not NIL the interepreter will report what code it is
+evaluating and what it returns.")
+
+(defmacro trace-statement (format-control &rest format-args)
+ `(when *trace-cc*
+ (format *trace-output* ,(strcat "~&" format-control "~%") , at format-args)))
+
+(defun kontinue (k &optional (primary-value nil primary-value-p) &rest other-values)
+ (trace-statement "Got ~S~{; ~S~}" primary-value other-values)
+ (let ((k (apply (car k) (cdr k))))
+ (cond
+ (other-values (apply k primary-value other-values))
+ (primary-value-p (funcall k primary-value))
+ (t (funcall k)))))
+
+(defmacro defk (name args k-args &body body)
+ `(defun ,name ,args
+ (declare (ignorable , at args))
+ (klambda ,k-args
+ (when *debug-evaluate/cc*
+ (format *debug-io* "~&(~S~{~^ ~S~}) Got (values~{~^ ~S~}).~%" ',name (list , at args) (list , at k-args)))
+ , at body)))
+
+(defgeneric evaluate/cc (form lexical-environment dynamic-environment k))
+
+(defmethod evaluate/cc ((form t) lex-env dyn-env k)
+ (declare (ignore lex-env dyn-env k))
+ (error "No EVALUATE/CC method defined for ~S." form))
+
+(defmethod evaluate/cc :around ((form form) lex-env dyn-env k)
+ (declare (ignore lex-env dyn-env k))
+ (trace-statement "Evaluating ~S." (source form))
+ (call-next-method))
+
+(defun print-debug-step (form lex-env dyn-env k)
+ (let ((*print-pretty* nil))
+ (ecase *debug-evaluate/cc*
+ (:full
+ (format *debug-io*
+ "~&Evaluating: ~S~%~3TLex Env: ~S~%~3TDyn Env: ~S~%~3TK: ~S~%"
+ form lex-env dyn-env k))
+ ((t)
+ (format *debug-io* "~&Evaluating: ~S~%" form))
+ ((nil) ;; do nothing
+ nil))))
+
+(defmethod evaluate/cc :before (form lex-env dyn-env k)
+ (when *debug-evaluate/cc*
+ (print-debug-step form lex-env dyn-env k)))
+
+(defun toplevel-k ()
+ (klambda (value other-values)
+ (throw 'done (values-list (cons value other-values)))))
+
+(defparameter *toplevel-k* '(toplevel-k))
+
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;; - Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;;
+;; - Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;;
+;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;; of its contributors may be used to endorse or promote products
+;; derived from this software without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Added: branches/trunk-reorg/thirdparty/arnesi/src/cl-ppcre-extras.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/cl-ppcre-extras.lisp Mon Feb 11 08:38:43 2008
@@ -0,0 +1,107 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+(defpackage :it.bese.arnesi.cl-ppcre-extras
+ (:use)
+ (:nicknames :rx)
+ (:export
+ #:=~
+ #:!~
+ #:$1
+ #:$2
+ #:$3
+ #:$4
+ #:$5
+ #:$6
+ #:$7
+ #:$8
+ #:$9))
+
+(defparameter rx::$_ nil
+ "The current default target for regexp matching.")
+(defparameter rx::$1 nil "The string matched by the first group in the last regexp match.")
+(defparameter rx::$2 nil "The string matched by the second group in the last regexp match.")
+(defparameter rx::$3 nil "The string matched by the third group in the last regexp match.")
+(defparameter rx::$4 nil "The string matched by the fourth group in the last regexp match.")
+(defparameter rx::$5 nil "The string matched by the fifth group in the last regexp match.")
+(defparameter rx::$6 nil "The string matched by the sixth group in the last regexp match.")
+(defparameter rx::$7 nil "The string matched by the seventh group in the last regexp match.")
+(defparameter rx::$8 nil "The string matched by the eight group in the last regexp match.")
+(defparameter rx::$9 nil "The string matched by the ninth group in the last regexp match.")
+
+(defmacro rx::=~ (regexp &optional (target 'rx::$_) (then t) (else nil))
+ "Equivalent to perl's if (TARGET =~ REGEXP) { THEN } else { ELSE }.
+
+Attempt to match REGEXP agains TARGET, if the match succedes THEN
+is evaluated with $1, .. $9 bound to the groups in
+REGEXP. Otherwise ELSE is executed."
+ (destructuring-bind (regexp &rest create-scanner-args) (if (listp regexp)
+ regexp
+ (list regexp))
+ (destructuring-bind (trgt &key start end) (if (listp target)
+ target
+ (list target))
+ (let ((match-start (gensym))
+ (match-end (gensym))
+ (register-starts (gensym))
+ (register-ends (gensym))
+ (num-registers (gensym))
+ (target (gensym)))
+ (flet ((gen-$-var (index)
+ `(if (< ,num-registers ,index)
+ nil
+ (let ((start (aref ,register-starts (1- ,index)))
+ (end (aref ,register-ends (1- ,index))))
+ (if (null start)
+ nil
+ (make-array (- end start) :displaced-to ,target :displaced-index-offset start))))))
+ `(let ((,target ,trgt))
+ (multiple-value-bind (,match-start ,match-end ,register-starts ,register-ends)
+ (cl-ppcre:scan (cl-ppcre:create-scanner ,regexp , at create-scanner-args)
+ ,trgt ,@(when start `(:start ,start))
+ ,@(when end `(:end ,end)))
+ (declare (ignore ,match-end))
+ (if (not (null ,match-start))
+ (let* ((,num-registers (length ,register-starts)))
+ (setf rx::$1 ,(gen-$-var 1)
+ rx::$2 ,(gen-$-var 2)
+ rx::$3 ,(gen-$-var 3)
+ rx::$4 ,(gen-$-var 4)
+ rx::$5 ,(gen-$-var 5)
+ rx::$6 ,(gen-$-var 6)
+ rx::$7 ,(gen-$-var 7)
+ rx::$8 ,(gen-$-var 8)
+ rx::$9 ,(gen-$-var 9))
+ ,then)
+ ,else))))))))
+
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;; - Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;;
+;; - Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;;
+;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;; of its contributors may be used to endorse or promote products
+;; derived from this software without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Added: branches/trunk-reorg/thirdparty/arnesi/src/compat.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/compat.lisp Mon Feb 11 08:38:43 2008
@@ -0,0 +1,47 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * A Trivial Compatibility Layer
+
+;;;; Here we only have the QUIT function, see mopp.lisp for a MOP
+;;;; compatibility layer.
+
+(defun quit (&optional (exit-code 0))
+ #+openmcl (ccl:quit exit-code)
+ #+sbcl (sb-ext:quit :unix-status exit-code)
+ #+clisp (ext:quit exit-code)
+ #+(or cmu allegro) (declare (ignore exit-code))
+ #+cmu (ext:quit)
+ #+lispworks (lispworks:quit :status exit-code)
+ #+allegro (excl:exit))
+
+;; Copyright (c) 2002-2003, Edward Marco Baringer
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;; - Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;;
+;; - Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;;
+;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;; of its contributors may be used to endorse or promote products
+;; derived from this software without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Added: branches/trunk-reorg/thirdparty/arnesi/src/csv.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/csv.lisp Mon Feb 11 08:38:43 2008
@@ -0,0 +1,117 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * Reading and Writing files in Comma-Seperated-Values format
+
+;;;; Generating CSV files from lisp data
+
+(defun princ-csv (items csv-stream
+ &key (quote #\")
+ (separator #\,)
+ (ignore-nulls t)
+ (newline +CR-LF+)
+ (princ #'princ-to-string))
+ "Write the list ITEMS to csv-stream."
+ (flet ((write-word (word)
+ (write-char quote csv-stream)
+ (loop
+ for char across (funcall princ word)
+ if (char= quote char) do
+ (progn
+ (write-char quote csv-stream)
+ (write-char quote csv-stream))
+ else do
+ (write-char char csv-stream))
+ (write-char quote csv-stream)))
+ (when items
+ (write-word (car items))
+ (dolist (i (cdr items))
+ (write-char separator csv-stream)
+ (if ignore-nulls
+ (when (not (null i))
+ (write-word i))
+ (write-word i)))
+ (write-sequence newline csv-stream))))
+
+(defun princ-csv-to-string (items)
+ (with-output-to-string (csv)
+ (princ-csv items csv)))
+
+;;;; Reading in CSV files
+
+(defun parse-csv-string (line &key (separator #\,) (quote #\"))
+ "Parse a csv line into a list of strings using seperator as the
+ column seperator and quote as the string quoting character."
+ (let ((items '())
+ (offset 0)
+ (current-word (make-array 20
+ :element-type 'character
+ :adjustable t
+ :fill-pointer 0))
+ (state :read-word))
+ (loop
+ (when (= offset (length line))
+ ;; all done
+ (ecase state
+ (:in-string
+ (error "Unterminated string."))
+ (:read-word
+ (return-from parse-csv-string
+ (nreverse (cons current-word items))))))
+ (cond
+ ((char= separator (aref line offset))
+ (ecase state
+ (:in-string
+ (vector-push-extend (aref line offset) current-word))
+ (:read-word
+ (push current-word items)
+ (setf current-word (make-array 20
+ :element-type 'character
+ :adjustable t
+ :fill-pointer 0)))))
+ ((char= quote (aref line offset))
+ (ecase state
+ (:in-string
+ (let ((offset+1 (1+ offset)))
+ (cond
+ ((and (/= offset+1 (length line))
+ (char= quote (aref line offset+1)))
+ (vector-push-extend quote current-word)
+ (incf offset))
+ (t (setf state :read-word)))))
+ (:read-word
+ (setf state :in-string))))
+ (t
+ (vector-push-extend (aref line offset) current-word)))
+ (incf offset))))
+
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;; - Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;;
+;; - Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;;
+;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;; of its contributors may be used to endorse or promote products
+;; derived from this software without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Added: branches/trunk-reorg/thirdparty/arnesi/src/debug.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/debug.lisp Mon Feb 11 08:38:43 2008
@@ -0,0 +1,108 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * Debugging Utilties
+
+;;;; (These were far more useful in the pre-slime days.)
+
+(defmacro ppm1 (form)
+ "(pprint (macroexpand-1 ',form)).
+
+NB: C-RET is even shorter."
+ `(pprint (macroexpand-1 ',form)))
+
+(defmacro ppm (form)
+ `(pprint (macroexpand ',form)))
+
+;;;; A portable flexible APROPOS implementation
+
+(defun apropos-list* (string &key (fbound nil fbound-supplied-p)
+ (bound nil bound-supplied-p)
+ (package nil package-supplied-p)
+ (distance 0 distance-supplied-p))
+ (let ((symbols '()))
+ (do-all-symbols (sym)
+ (block collect-symbol
+ (when fbound-supplied-p
+ (when (xor fbound (fboundp sym))
+ (return-from collect-symbol)))
+ (when bound-supplied-p
+ (when (xor bound (boundp sym))
+ (return-from collect-symbol)))
+ (when package-supplied-p
+ (unless (eql package (symbol-package sym))
+ (return-from collect-symbol)))
+ (when distance-supplied-p
+ (unless (and
+ (<= (abs (- (length (symbol-name sym))
+ (length string)))
+ distance)
+ (<= (levenshtein-distance string (symbol-name sym))
+ distance))
+ (return-from collect-symbol)))
+ (when (not distance-supplied-p)
+ ;; regular string= test
+ (unless (search string (symbol-name sym) :test #'char-equal)
+ (return-from collect-symbol)))
+ ;; all the checks we wanted to perform passed.
+ (push sym symbols)))
+ symbols))
+
+(defun apropos* (&rest apropos-args)
+ (flet ((princ-length (sym)
+ (if (keywordp sym)
+ (+ 1 (length (symbol-name sym)))
+ (+ (length (package-name (symbol-package sym)))
+ 1
+ (length (symbol-name sym))))))
+ (let* ((syms (apply #'apropos-list* apropos-args))
+ (longest (apply #'max (mapcar #'princ-length syms))))
+ (dolist (sym syms)
+ (if (keywordp sym)
+ (progn
+ (princ ":" *debug-io*)
+ (princ (symbol-name sym) *debug-io*))
+ (progn
+ (princ (package-name (symbol-package sym)) *debug-io*)
+ (princ ":" *debug-io*)
+ (princ (symbol-name sym) *debug-io*)))
+ (princ (make-string (- longest (princ-length sym))
+ :initial-element #\Space)
+ *debug-io*)
+ (when (fboundp sym)
+ (princ " [FUNC] " *debug-io*))
+ (when (boundp sym)
+ (princ " [VAR] " *debug-io*))
+ (terpri *debug-io*))))
+ (values))
+
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;; - Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;;
+;; - Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;;
+;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;; of its contributors may be used to endorse or promote products
+;; derived from this software without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Added: branches/trunk-reorg/thirdparty/arnesi/src/decimal-arithmetic.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/decimal-arithmetic.lisp Mon Feb 11 08:38:43 2008
@@ -0,0 +1,120 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * Decimal Arithmetic
+
+;;;; Converting to and from external representations
+
+(defvar *precision* 2
+ "Default precision.")
+
+(defmacro with-precision (prec &body body)
+ "Evalute BODY with *precision* bound to PREC."
+ (let ((precision (gensym)))
+ `(let ((,precision ,prec))
+ (assert (integerp ,precision)
+ (,precision)
+ "Precision must be an integer, not ~S" ,precision)
+ (let ((*precision* (10^ ,precision)))
+ (declare (special *precision*))
+ , at body))))
+
+(defun decimal-from-float (float
+ &optional (precision *precision*)
+ (rounding-method #'round-half-up))
+ "Convert FLOAT to an exact value with precision PRECISION using
+ ROUNDING-METHOD to do any neccessary rounding."
+ (funcall rounding-method float precision))
+
+(defun float-from-decimal (decimal)
+ "Convert the exact decimal value DECIMAL to a (not neccassily
+ equal) floating point value."
+ (float decimal))
+
+;;;; Rounding functions
+
+(defun round-down (number &optional (precision *precision*))
+ "Round towards 0."
+ (if (minusp number)
+ (round-ceiling number precision)
+ (round-floor number precision)))
+
+(defun round-half-up (number &optional (precision *precision*))
+ "Round towards the nearest value allowed with the current
+precision. If the current value is exactly halfway between two logal
+values round away from 0."
+ (multiple-value-bind (value discarded)
+ (floor (* number precision))
+ (if (<= 1/2 discarded)
+ (/ (1+ value) precision)
+ (/ value precision))))
+
+(defun round-half-even (number &optional (precision *precision*))
+ "Round towards the nearest value allowed with the current
+precision. If the current value is exactly halfway between two legal
+values round towards the nearest even value."
+ (multiple-value-bind (value discarded)
+ (floor (* number precision))
+ (cond
+ ((< discarded 1/2) ;; down
+ (/ value precision))
+ ((= discarded 1/2) ;; goto even
+ (if (evenp value)
+ (/ value precision)
+ (/ (1+ value) precision)))
+ (t ;; (>= discarded 1/2)
+ (/ (1+ value) precision)))))
+
+(defun round-ceiling (number &optional (precision *precision*))
+ "Round towards positive infintity"
+ (/ (ceiling (* number precision)) precision))
+
+(defun round-floor (number &optional (precision *precision*))
+ "Round towards negative infinity."
+ (/ (floor (* number precision)) precision))
+
+(defun round-half-down (number &optional (precision *precision*))
+ "Round towards the nearest legal value. If the current value is
+exactly half way between two legal values round towards 0."
+ (multiple-value-bind (value discarded)
+ (floor number)
+ (if (< 1/2 discarded)
+ (/ (1+ value) precision)
+ (/ value precision))))
+
+(defun round-up (number &optional (precision *precision*))
+ "Round away from 0."
+ (if (minusp number)
+ (round-floor number precision)
+ (round-ceiling number precision)))
+
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;; - Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;;
+;; - Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;;
+;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;; of its contributors may be used to endorse or promote products
+;; derived from this software without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Added: branches/trunk-reorg/thirdparty/arnesi/src/defclass-struct.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/defclass-struct.lisp Mon Feb 11 08:38:43 2008
@@ -0,0 +1,100 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * Defining classes with DEFSTRUCT's syntax
+
+(defmacro defclass-struct (name-and-options supers &rest slots)
+ "DEFCLASS with a DEFSTRUCT api.
+
+NAME-AND-OPTIONS:
+
+ name-symbol |
+ ( name-symbol [ (:conc-name conc-name ) ]
+ [ (:predicate predicate-name ) ]
+ class-option* )
+
+SUPERS - a list of super classes passed directly to DEFCLASS.
+
+SLOTS - a list of slot forms:
+
+ name |
+ ( name [ init-arg ] [ slot-options* ] )"
+ (generate-defclass (first (ensure-list name-and-options))
+ (cdr (ensure-list name-and-options))
+ supers slots))
+
+(defun generate-defclass (class-name options supers slots)
+ (let ((conc-name nil)
+ (predicate nil)
+ (predicate-forms nil)
+ (class-options '()))
+ (loop
+ for (option-name . args) in options
+ do (case option-name
+ (:conc-name
+ (when conc-name
+ (error "Can't specify the :CONC-NAME argument more than once."))
+ (setf conc-name (first args)))
+ (:predicate
+ (when predicate
+ (error "Can't specify the :PREDICATE argument more than once."))
+ (setf predicate (if (eql t (first args))
+ (intern (strcat class-name :-p) *package*)
+ (first args))))
+ (t
+ (push (cons option-name args) class-options))))
+ (setf slots
+ (mapcar
+ (lambda (slot-spec)
+ (destructuring-bind (name
+ &optional initform
+ &rest options)
+ (ensure-list slot-spec)
+ `(,name
+ :initform ,initform
+ ,@(when conc-name
+ `(:accessor ,(intern (strcat conc-name name)
+ (symbol-package conc-name))))
+ :initarg ,(intern (symbol-name name) :keyword)
+ , at options)))
+ slots)
+ predicate-forms
+ (if predicate
+ (with-unique-names (obj)
+ `((defmethod ,predicate ((,obj ,class-name)) t)
+ (defmethod ,predicate ((,obj t)) nil)))
+ nil))
+ `(prog1
+ (defclass ,class-name ,supers ,slots ,@(nreverse class-options))
+ , at predicate-forms)))
+
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;; - Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;;
+;; - Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;;
+;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;; of its contributors may be used to endorse or promote products
+;; derived from this software without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Added: branches/trunk-reorg/thirdparty/arnesi/src/flow-control.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/flow-control.lisp Mon Feb 11 08:38:43 2008
@@ -0,0 +1,235 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * Various flow control operators
+
+;;;; ** Anaphoric conditionals
+
+(defmacro if-bind (var test &body then/else)
+ "Anaphoric IF control structure.
+
+VAR (a symbol) will be bound to the primary value of TEST. If
+TEST returns a true value then THEN will be executed, otherwise
+ELSE will be executed."
+ (assert (first then/else)
+ (then/else)
+ "IF-BIND missing THEN clause.")
+ (destructuring-bind (then &optional else)
+ then/else
+ `(let ((,var ,test))
+ (if ,var ,then ,else))))
+
+(defmacro aif (test then &optional else)
+ "Just like IF-BIND but the var is always IT."
+ `(if-bind it ,test ,then ,else))
+
+(defmacro when-bind (var test &body body)
+ "Just like when except VAR will be bound to the
+ result of TEST in BODY."
+ `(if-bind ,var ,test (progn , at body)))
+
+(defmacro awhen (test &body body)
+ "Just like when expect the symbol IT will be
+ bound to the result of TEST in BODY."
+ `(when-bind it ,test , at body))
+
+(defmacro cond-bind (var &body clauses)
+ "Just like COND but VAR will be bound to the result of the
+ condition in the clause when executing the body of the clause."
+ (if clauses
+ (destructuring-bind ((test &rest body) &rest others)
+ clauses
+ `(if-bind ,var ,test
+ (progn ,@(if body body (list var)))
+ (cond-bind ,var , at others)))
+ nil))
+
+(defmacro acond (&rest clauses)
+ "Just like cond-bind except the var is automatically IT."
+ `(cond-bind it , at clauses))
+
+(defmacro aand (&rest forms)
+ `(and-bind it , at forms))
+
+(defmacro and-bind (var &rest forms)
+ (cond
+ ((cdr forms)
+ `(when-bind ,var ,(first forms)
+ (and-bind ,var ,@(cdr forms))))
+ (forms (first forms))
+ (t 't)))
+
+;;;; ** Multiple value anaphoric conditionals
+
+(defmacro if2-bind (var test &body then/else)
+ "Anaphoric IF control structure for multiple values.
+
+VAR (a symbol) will be bound to the primary value of TEST. If
+TEST's second value is true then THEN will be executed, otherwise
+ELSE will be executed."
+ (assert (first then/else)
+ (then/else)
+ "IF-BIND missing THEN clause.")
+ (destructuring-bind (then &optional else)
+ then/else
+ (with-unique-names (bool)
+ `(multiple-value-bind (,var ,bool) ,test
+ (if ,bool ,then ,else)))))
+
+(defmacro aif2 (test then &optional else)
+ "Just like IF-BIND but the var is always IT.
+
+Very useful with functions like GETHASH."
+ `(if2-bind it ,test ,then ,else))
+
+;;;; ** Looping
+
+(defmacro while (test &body body)
+ "Repeat BODY while TEST is true.
+
+You may exit the loop with (RETURN-FROM WHILE)."
+ `(block while
+ (loop
+ (if ,test
+ (progn , at body)
+ (return-from while)))))
+
+(defmacro awhile (test &body body)
+ "Just like WHILE, but the result of TEST is bound to IT.
+
+You may exit the loop with (RETURN-FROM AWHILE)."
+ `(block awhile
+ (loop
+ (aif ,test
+ (progn , at body)
+ (return-from awhile)))))
+
+(defmacro until (test &body body)
+ "Repeat BODY until TEST is false.
+
+You may exit the loop with (RETURN-FROM UNTIL)."
+ `(block until
+ (loop
+ (if (not ,test)
+ (progn , at body)
+ (return-from until)))))
+
+;;;; ** Whichever
+
+(defmacro whichever (&rest possibilities)
+ "Evaluates one (and only one) of its args, which one is chosen at random"
+ `(ecase (random ,(length possibilities))
+ ,@(loop for poss in possibilities
+ for x from 0
+ collect (list x poss))))
+
+;;;; ** XOR - The missing conditional
+
+(defmacro xor (&rest datums)
+ "Evaluates the args one at a time. If more than one arg returns true
+ evaluation stops and NIL is returned. If exactly one arg returns
+ true that value is returned."
+ (let ((state (gensym "XOR-state-"))
+ (block-name (gensym "XOR-block-"))
+ (arg-temp (gensym "XOR-arg-temp-")))
+ `(let ((,state nil)
+ (,arg-temp nil))
+ (block ,block-name
+ ,@(loop
+ for arg in datums
+ collect `(setf ,arg-temp ,arg)
+ collect `(if ,arg-temp
+ ;; arg is T, this can change the state
+ (if ,state
+ ;; a second T value, return NIL
+ (return-from ,block-name nil)
+ ;; a first T, swap the state
+ (setf ,state ,arg-temp))))
+ (return-from ,block-name ,state)))))
+
+;;;; ** Switch
+
+(defmacro switch ((obj &key (test #'eql)) &body clauses)
+ "Evaluate the first clause whose car satisfies (funcall test
+ car obj)."
+ ;; NB: There is no need to do the find-if and the remove here, we
+ ;; can just as well do them with in the expansion
+ (let ((default-clause (find-if (lambda (c) (eq t (car c))) clauses)))
+ (when default-clause
+ (setf clauses (remove default-clause clauses :test #'equalp)))
+ (let ((obj-sym (gensym))
+ (test-sym (gensym)))
+ `(let ((,obj-sym ,obj)
+ (,test-sym ,test))
+ (cond
+ ,@(mapcar (lambda (clause)
+ (let ((keys (ensure-list (car clause)))
+ (form (cdr clause)))
+ `((or ,@(mapcar (lambda (key)
+ `(funcall ,test-sym ',key ,obj-sym))
+ keys))
+ , at form)))
+ clauses)
+ ,@(when default-clause
+ `((t ,@(cdr default-clause)))))))))
+
+(defmacro eswitch ((obj &key (test #'eql)) &body body)
+ "Like switch but signals an error if no clause succeeds."
+ (rebinding (obj test)
+ `(switch (,obj :test ,test)
+ , at body
+ (t
+ (error "Unmatched SWITCH. Testing against ~S with ~S."
+ ,obj ,test)))))
+
+(defmacro cswitch ((obj &key (test #'eql)) &body body)
+ "Like SWITCH but signals a continuable error if no clause
+ matches."
+ (rebinding (obj test)
+ `(switch (,obj :test ,test)
+ , at body
+ (t
+ (cerror "Unmatched SWITCH. Testing against ~S with ~S."
+ ,obj ,test)))))
+
+;;;; ** Eliminating Nesting
+
+(defmacro with* (&body body)
+ (cond
+ ((cddr body)
+ (append (first body) `((with* ,@(cdr body)))))
+ ((cdr body)
+ `(,@(first body) ,(second body)))
+ (body (first body))
+ (t nil)))
+
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;; - Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;;
+;; - Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;;
+;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;; of its contributors may be used to endorse or promote products
+;; derived from this software without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Added: branches/trunk-reorg/thirdparty/arnesi/src/hash.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/hash.lisp Mon Feb 11 08:38:43 2008
@@ -0,0 +1,105 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * Convience functions for working with hash tables.
+
+(defun build-hash-table (hash-spec inital-contents)
+ "Create a hash table containing ``INITAL-CONTENTS``."
+ (let ((ht (apply #'make-hash-table hash-spec)))
+ (dolist* ((key value) inital-contents)
+ (setf (gethash key ht) value))
+ ht))
+
+(defmacro deflookup-table
+ (name &key (var (make-lookup-name name "*" name "*"))
+ (reader (make-lookup-name name "GET-" name))
+ (writer (make-lookup-name name "GET-" name))
+ (rem-er (make-lookup-name name "REM-" name))
+ (at-redefinition :warn)
+ (documentation
+ (format nil "Global var for the ~S lookup table" name))
+ (test 'eql)
+ (initial-contents nil))
+ "Creates a hash table and the associated accessors."
+ ;; if they explicitly pass in NIL we make the name a gensym
+ (unless var
+ (setf var (gensym (strcat "var for " name " lookup table "))))
+ (unless reader
+ (setf reader (gensym (strcat "reader for " name " lookup table "))))
+ (unless writer
+ (setf writer (gensym (strcat "writer for " name " lookup table "))))
+ (assert (symbolp name) (name)
+ "The name of the lookup table must be a symbol.")
+ (assert (symbolp var) (var)
+ "The name of the underlying var must be a symbol.")
+ (assert (symbolp reader) (reader)
+ "The name of the reader for a lookup table must be a symbol.")
+ (assert (symbolp writer) (writer)
+ "The name of the writer for a lookup table must be a symbol.")
+ `(progn
+ (defvar ,var
+ (build-hash-table '(:test ,test) ,initial-contents)
+ ,documentation)
+ (defun ,reader (key &optional default)
+ (gethash key ,var default))
+ (defun (setf ,writer) (value key)
+ ,(when at-redefinition
+ `(when (gethash key ,var)
+ ,(case at-redefinition
+ (:warn `(warn "Redefining ~A in deflookup-table named ~S"
+ (let ((*package* (find-package "KEYWORD")))
+ (format nil "~S" key))
+ ',name))
+ (t at-redefinition))))
+ (setf (gethash key ,var) value))
+ (defun ,rem-er (key)
+ (remhash key ,var))
+ (list ',name ',var ',reader '(setf ,writer) ',rem-er)))
+
+(defun make-lookup-name (name &rest parts)
+ (funcall #'intern-concat parts (symbol-package name)))
+
+(defun hash-to-alist (hash-table)
+ (loop for k being the hash-keys of hash-table
+ collect (cons k (gethash k hash-table))))
+
+(defun hash-table-keys (hash-table)
+ (loop
+ for k being the hash-keys of hash-table
+ collect k))
+
+(defun hash-table-values (hash-table)
+ (loop
+ for v being the hash-values of hash-table
+ collect v))
+
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;; - Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;;
+;; - Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;;
+;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;; of its contributors may be used to endorse or promote products
+;; derived from this software without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Added: branches/trunk-reorg/thirdparty/arnesi/src/http.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/http.lisp Mon Feb 11 08:38:43 2008
@@ -0,0 +1,255 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * HTTP/HTML utilities
+
+;;;; ** URIs/URLs
+;;;; http://www.faqs.org/rfcs/rfc2396.html
+
+(eval-always
+ (defvar *uri-escaping-ok-table* (make-array 256
+ :element-type 'boolean
+ :initial-element nil))
+ (loop
+ ;; The list of characters which don't need to be escaped when writing URIs.
+ ;; This list is inherently a heuristic, because different uri components may have
+ ;; different escaping needs, but it should work fine for http.
+ for ok-char across "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789.,/" do
+ (setf (aref *uri-escaping-ok-table* (char-code ok-char)) t))
+ (setf *uri-escaping-ok-table* (coerce *uri-escaping-ok-table* '(simple-array boolean (256)))))
+
+(defun escape-as-uri (string)
+ "Escapes all non alphanumeric characters in STRING following
+ the URI convention. Returns a fresh string."
+ (with-output-to-string (escaped)
+ (write-as-uri string escaped)))
+
+(defun write-as-uri (string stream)
+ (declare (type vector string)
+ (type stream stream)
+ (optimize (speed 3) (debug 0)))
+ (loop
+ for char-code :of-type (unsigned-byte 8) :across (the (vector (unsigned-byte 8))
+ (string-to-octets string :utf-8)) do
+ (if (aref (the (simple-array boolean (256)) (load-time-value *uri-escaping-ok-table* t)) char-code)
+ (write-char (code-char char-code) stream)
+ (format stream "%~2,'0X" char-code))))
+
+(define-condition uri-parse-error (error)
+ ((what :initarg :what :reader uri-parse-error.what)))
+
+(define-condition expected-digit-uri-parse-error (uri-parse-error) ())
+
+(defun continue-as-is (c)
+ (declare (ignore c))
+ (awhen (find-restart 'continue-as-is)
+ (invoke-restart it)))
+
+(defun try-other-encoding (c encoding)
+ (declare (ignore c))
+ (awhen (find-restart 'try-other-encoding)
+ (invoke-restart it encoding)))
+
+(defun unescape-as-uri-non-strict (string)
+ (handler-bind ((uri-parse-error #'continue-as-is)
+ (serious-condition #'(lambda (c)
+ (try-other-encoding c :iso-8859-1)) ))
+ (%unescape-as-uri string)))
+
+(defun %unescape-as-uri (input)
+ "URI unescape based on http://www.ietf.org/rfc/rfc2396.txt"
+ (declare (type string input)
+ (optimize (speed 3) (debug 0)))
+ (let ((input-length (length input)))
+ (when (zerop input-length)
+ (return-from %unescape-as-uri ""))
+ (let* ((input-index 0)
+ (output (make-array input-length :element-type '(unsigned-byte 8) :adjustable t :fill-pointer 0)))
+ (declare (type fixnum input-length input-index))
+ (labels ((read-next-char (must-exists-p)
+ (when (>= input-index input-length)
+ (if must-exists-p
+ (error 'uri-parse-error :what input)
+ (return-from %unescape-as-uri
+ (restart-case
+ (octets-to-string output :utf-8)
+ (try-other-encoding (encoding)
+ :report "Try converting uri using other encoding"
+ (octets-to-string output encoding))))))
+ (prog1 (aref input input-index)
+ (incf input-index)))
+ (write-next-byte (byte)
+ (vector-push-extend byte output)
+ (values))
+ (char-to-int (char)
+ (let ((result (digit-char-p char 16)))
+ (unless result
+ (error 'expected-digit-uri-parse-error :what char))
+ result))
+ (parse ()
+ (let ((next-char (read-next-char nil)))
+ (case next-char
+ (#\% (char%))
+ (#\+ (char+))
+ (t (write-next-byte (char-code next-char))))
+ (parse)))
+ (char% ()
+ (let ((restart-input-index input-index))
+ (restart-case
+ (write-next-byte (+ (ash (char-to-int (read-next-char t)) 4)
+ (char-to-int (read-next-char t))))
+ (continue-as-is ()
+ :report "Continue reading uri without attempting to convert the escaped-code to a char."
+ (setf input-index restart-input-index)
+ (write-next-byte #.(char-code #\%)))))
+ (values))
+ (char+ ()
+ (write-next-byte #.(char-code #\Space))))
+ (parse)))))
+
+(declaim (inline unescape-as-uri))
+(defun unescape-as-uri (string)
+ (%unescape-as-uri string))
+
+(declaim (inline nunescape-as-uri))
+(defun nunescape-as-uri (string)
+ (%unescape-as-uri string))
+
+
+
+;;;; ** HTML
+
+;;;; This so blatently wrong its not even funny, and while this is
+;;;; exactly what I need I would do well to start using a "real" html
+;;;; escaping library (there are a couple to choose from).
+
+(defun make-html-entities ()
+ (let ((ht (make-hash-table :test 'equalp)))
+ (flet ((add-mapping (char escaped)
+ (setf (gethash char ht) escaped
+ (gethash escaped ht) char)))
+ (add-mapping #\< "<")
+ (add-mapping #\> ">")
+ (add-mapping #\& "&")
+ (add-mapping #\" """)
+ (add-mapping #\space " ")
+ (add-mapping "a`" "à")
+ (add-mapping "a'" "á")
+ (add-mapping "e`" "è")
+ (add-mapping "e'" "é")
+ (add-mapping "i'" "ì")
+ (add-mapping "i`" "í")
+ (add-mapping "o`" "ò")
+ (add-mapping "o'" "ó")
+ (add-mapping "u`" "ù")
+ (add-mapping "u'" "ú"))
+ ht))
+
+(defparameter *html-entites* (make-html-entities))
+
+(defun html-entity->char (entity &optional (default #\?))
+ (let ((res (gethash entity *html-entites*)))
+ (if res
+ (if (stringp res)
+ (char res 0)
+ res)
+ default)))
+
+(defun write-as-html (string &key (stream t) (escape-whitespace nil))
+ (loop
+ for char across string
+ do (cond
+ ((char= char #\Space)
+ (if escape-whitespace
+ (princ " " stream)
+ (write-char char stream)))
+ ((gethash char *html-entites*)
+ (princ (gethash char *html-entites*) stream))
+ (t (write-char char stream)))))
+
+(defun escape-as-html (string &key (escape-whitespace nil))
+ (with-output-to-string (escaped)
+ (write-as-html string
+ :stream escaped
+ :escape-whitespace escape-whitespace)))
+
+(define-condition html-escape-error (error)
+ ((what :accessor html-escape-error.what :initarg :what)))
+
+(define-condition unterminated-html-entity (html-escape-error)
+ ())
+
+(define-condition unknown-html-entity (html-escape-error)
+ ())
+
+(define-condition unknown-char-escape (warning)
+ ((what :accessor html-escape-error.what :initarg :what)))
+
+(defun unescape-as-html (string)
+ (with-output-to-string (unescaped)
+ (loop
+ for offset upfrom 0 below (length string)
+ for char = (aref string offset)
+ if (char= #\& char)
+ do (progn
+ (aif (position #\; string :start offset)
+ (let ((escape-tag (subseq string offset (1+ it))))
+ (aif (gethash escape-tag *html-entites*)
+ (progn
+ (princ it unescaped)
+ (incf offset (1- (length escape-tag))))
+ (if (char= #\# (aref escape-tag 1))
+ ;; special code, ignore
+ (restart-case
+ (warn 'unknown-char-escape :what escape-tag)
+ (continue-delete ()
+ :report "Continue processing, delete this char."
+ (incf offset (1- (length escape-tag)))))
+ (restart-case
+ (error 'unknown-html-entity :what escape-tag)
+ (continue-as-is ()
+ :report "Continue processing, leaving the string as is."
+ (write-char #\& unescaped))
+ (continue-delete ()
+ :report "Continue processing, delete this entity."
+ (incf offset (1- (length escape-tag))))))))
+ (restart-case
+ (error 'unterminated-html-entity
+ :what (subseq string offset
+ (min (+ offset 20)
+ (length string))))
+ (continue-as-is ()
+ :report "Continue processing, leave the string as is."
+ (write-char #\& unescaped)))))
+ else do (write-char char unescaped))))
+
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;; - Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;;
+;; - Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;;
+;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;; of its contributors may be used to endorse or promote products
+;; derived from this software without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Added: branches/trunk-reorg/thirdparty/arnesi/src/io.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/io.lisp Mon Feb 11 08:38:43 2008
@@ -0,0 +1,156 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * Utilites for file system I/O
+
+(defmacro with-input-from-file ((stream-name file-name &rest args &key
+ (direction nil direction-provided-p)
+ external-format
+ &allow-other-keys)
+ &body body)
+ "Evaluate BODY with STREAM-NAME bound to an
+ input-stream from file FILE-NAME. ARGS is passed
+ directly to open."
+ (declare (ignore direction))
+ (when direction-provided-p
+ (error "Can't specifiy :DIRECTION in WITH-INPUT-FILE."))
+ (remf-keywords args :external-format)
+ `(with-open-file (,stream-name ,file-name :direction :input
+ ,@(when external-format
+ `(:external-format
+ ,(if (keywordp external-format)
+ `(encoding-keyword-to-native ,external-format)
+ external-format)))
+ , at args)
+ , at body))
+
+(defmacro with-output-to-file ((stream-name file-name &rest args &key
+ (direction nil direction-provided-p)
+ external-format
+ &allow-other-keys)
+ &body body)
+ "Evaluate BODY with STREAM-NAME to an output stream
+ on the file named FILE-NAME. ARGS is sent as is to
+ the call te open."
+ (declare (ignore direction))
+ (when direction-provided-p
+ (error "Can't specifiy :DIRECTION in WITH-OUTPUT-FILE."))
+ (remf-keywords args :external-format)
+ `(with-open-file (,stream-name ,file-name :direction :output
+ ,@(when external-format
+ `(:external-format
+ ,(if (keywordp external-format)
+ `(encoding-keyword-to-native ,external-format)
+ external-format)))
+ , at args)
+ , at body))
+
+(defun read-string-from-file (pathname &key (buffer-size 4096)
+ (element-type 'character)
+ (external-format :us-ascii))
+ "Return the contents of PATHNAME as a fresh string.
+
+The file specified by PATHNAME will be read one ELEMENT-TYPE
+element at a time, the EXTERNAL-FORMAT and ELEMENT-TYPEs must be
+compatible.
+
+The EXTERNAL-FORMAT parameter will be passed to
+ENCODING-KEYWORD-TO-NATIVE, see ENCODING-KEYWORD-TO-NATIVE to
+possible values."
+ (with-input-from-file
+ (file-stream pathname :external-format (encoding-keyword-to-native external-format))
+ (with-output-to-string (datum)
+ (let ((buffer (make-array buffer-size :element-type element-type)))
+ (loop for bytes-read = (read-sequence buffer file-stream)
+ do (write-sequence buffer datum :start 0 :end bytes-read)
+ while (= bytes-read buffer-size))))))
+
+(defun write-string-to-file (string pathname &key (if-exists :error)
+ (if-does-not-exist :error)
+ (external-format :us-ascii))
+ "Write STRING to PATHNAME.
+
+The EXTERNAL-FORMAT parameter will be passed to
+ENCODING-KEYWORD-TO-NATIVE, see ENCODING-KEYWORD-TO-NATIVE to
+possible values."
+ (with-output-to-file (file-stream pathname :if-exists if-exists
+ :if-does-not-exist if-does-not-exist
+ :external-format (encoding-keyword-to-native external-format))
+ (write-sequence string file-stream)))
+
+(defun copy-file (from to &key (if-to-exists :supersede)
+ (element-type '(unsigned-byte 8)))
+ (with*
+ (with-input-from-file (input from :element-type element-type))
+ (with-output-to-file (output to :element-type element-type
+ :if-exists if-to-exists))
+ (progn
+ (copy-stream input output))))
+
+(defun copy-stream (input output &optional (element-type (stream-element-type input)))
+ "Reads data from FROM and writes it to TO. Both FROM and TO
+ must be streams, they will be passed to
+ read-sequence/write-sequence and must have compatable
+ element-types."
+ (loop
+ with buffer-size = 4096
+ with buffer = (make-array buffer-size :element-type element-type)
+ for bytes-read = (read-sequence buffer input)
+ while (= bytes-read buffer-size)
+ do (write-sequence buffer output)
+ finally (write-sequence buffer output :end bytes-read)))
+
+(defmacro defprint-object ((self class-name &key (identity t) (type t) with-package
+ (muffle-errors t))
+ &body body)
+ "Define a print-object method using print-unreadable-object.
+ An example:
+ (defprint-object (self parenscript-dispatcher)
+ (when (cachep self)
+ (princ \"cached\")
+ (princ \" \"))
+ (princ (parenscript-file self)))"
+ (with-unique-names (stream)
+ `(defmethod print-object ((,self ,class-name) ,stream)
+ (print-unreadable-object (,self ,stream :type ,type :identity ,identity)
+ (let ((*standard-output* ,stream))
+ (block printing
+ (,@(if muffle-errors
+ `(handler-bind ((error (lambda (error)
+ (declare (ignore error))
+ (write-string "<<error printing object>>")
+ (return-from printing)))))
+ `(progn))
+ (let (,@(when with-package `((*package* ,(find-package with-package)))))
+ , at body))))))))
+
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;; - Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;;
+;; - Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;;
+;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;; of its contributors may be used to endorse or promote products
+;; derived from this software without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Added: branches/trunk-reorg/thirdparty/arnesi/src/lambda-list.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/lambda-list.lisp Mon Feb 11 08:38:43 2008
@@ -0,0 +1,92 @@
+;;;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * Lambda-lists
+
+(defun extract-argument-names (lambda-list &key allow-specializers)
+ "Returns a list of symbols representing the names of the
+ variables bound by the lambda list LAMBDA-LIST."
+ (mapcan (lambda (argument)
+ (let1 vars '()
+ (dolist (slot-name '(name supplied-p-parameter))
+ (awhen (and (slot-exists-p argument slot-name)
+ (slot-boundp argument slot-name)
+ (slot-value argument slot-name))
+ (push it vars)))
+ (nreverse vars)))
+ (walk-lambda-list lambda-list nil '() :allow-specializers allow-specializers)))
+
+(defun convert-to-generic-lambda-list (defmethod-lambda-list)
+ (loop
+ with generic-lambda-list = '()
+ for arg in (walk-lambda-list defmethod-lambda-list
+ nil nil
+ :allow-specializers t)
+ do (etypecase arg
+ ((or required-function-argument-form
+ specialized-function-argument-form)
+ (push (name arg) generic-lambda-list))
+ (keyword-function-argument-form
+ (pushnew '&key generic-lambda-list)
+ (if (keyword-name arg)
+ (push (list (list (keyword-name arg)
+ (name arg)))
+ generic-lambda-list)
+ (push (list (name arg)) generic-lambda-list)))
+ (rest-function-argument-form
+ (push '&rest generic-lambda-list)
+ (push (name arg) generic-lambda-list))
+ (optional-function-argument-form
+ (pushnew '&optional generic-lambda-list)
+ (push (name arg) generic-lambda-list))
+ (allow-other-keys-function-argument-form
+ (unless (member '&key generic-lambda-list)
+ (push '&key generic-lambda-list))
+ (push '&allow-other-keys generic-lambda-list)))
+ finally (return (nreverse generic-lambda-list))))
+
+(defun clean-argument-list (lambda-list)
+ (loop
+ for head on lambda-list
+ for argument = (car head)
+ if (member argument '(&optional &key &rest &allow-other-keys))
+ return (append cleaned head)
+ else
+ collect (if (listp argument)
+ (first argument)
+ argument)
+ into cleaned
+ finally (return cleaned)))
+
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; Copyright (c) 2006, Hoan Ton-That
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;; - Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;;
+;; - Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;;
+;; - Neither the name of Edward Marco Baringer, Hoan Ton-That, nor
+;; BESE, nor the names of its contributors may be used to endorse
+;; or promote products derived from this software without specific
+;; prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Added: branches/trunk-reorg/thirdparty/arnesi/src/lambda.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/lambda.lisp Mon Feb 11 08:38:43 2008
@@ -0,0 +1,120 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * Higher order functions
+
+(defun compose (f1 &rest functions)
+ "Returns a function which applies the arguments in order.
+
+ (funcall (compose #'list #'+) 1 2 3) ==> (6)"
+ (case (length functions)
+ (0 f1)
+ (1 (lambda (&rest args)
+ (funcall f1 (apply (car functions) args))))
+ (2 (lambda (&rest args)
+ (funcall f1
+ (funcall (first functions)
+ (apply (second functions) args)))))
+ (3 (lambda (&rest args)
+ (funcall f1
+ (funcall (first functions)
+ (funcall (second functions)
+ (apply (third functions) args))))))
+ (t
+ (let ((funcs (nreverse (cons f1 functions))))
+ (lambda (&rest args)
+ (loop
+ for f in funcs
+ for r = (multiple-value-list (apply f args))
+ then (multiple-value-list (apply f r))
+ finally (return (values-list r))))))))
+
+(defun conjoin (&rest predicates)
+ (case (length predicates)
+ (0 (constantly t))
+ (1 (car predicates))
+ (2 (lambda (&rest args)
+ (and (apply (first predicates) args)
+ (apply (second predicates) args))))
+ (3 (lambda (&rest args)
+ (and (apply (first predicates) args)
+ (apply (second predicates) args)
+ (apply (third predicates) args))))
+ (t
+ (lambda (&rest args)
+ (loop
+ for p in predicates
+ for val = (apply p args)
+ while val
+ finally (return val))))))
+
+(defun curry (function &rest initial-args)
+ "Returns a function which will call FUNCTION passing it
+ INITIAL-ARGS and then any other args.
+
+ (funcall (curry #'list 1) 2) ==> (list 1 2)"
+ (lambda (&rest args)
+ (apply function (append initial-args args))))
+
+(defun rcurry (function &rest initial-args)
+ "Returns a function which will call FUNCTION passing it the
+ passed args and then INITIAL-ARGS.
+
+ (funcall (rcurry #'list 1) 2) ==> (list 2 1)"
+ (lambda (&rest args)
+ (apply function (append args initial-args))))
+
+(defun noop (&rest args)
+ "Do nothing."
+ (declare (ignore args))
+ (values))
+
+(defmacro lambda-rec (name args &body body)
+ "Just like lambda except BODY can make recursive calls to the
+ lambda by calling the function NAME."
+ `(lambda ,args
+ (labels ((,name ,args , at body))
+ (,name , at args))))
+
+;;;; ** Just for fun
+
+(defun y (lambda)
+ (funcall (lambda (f)
+ (funcall (lambda (g)
+ (funcall g g))
+ (lambda (x)
+ (funcall f
+ (lambda ()
+ (funcall x x))))))
+ lambda))
+
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;; - Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;;
+;; - Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;;
+;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;; of its contributors may be used to endorse or promote products
+;; derived from this software without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Added: branches/trunk-reorg/thirdparty/arnesi/src/lexenv.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/lexenv.lisp Mon Feb 11 08:38:43 2008
@@ -0,0 +1,588 @@
+;;;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * Portable lexical environment access
+
+(defgeneric environment-p (environment)
+ (:documentation "Returns T if ENVIRONMENT is a lexical
+ environment object (something suitable for passing to
+ macroexpand-1 or similar)"))
+
+(defgeneric lexical-variables (environment)
+ (:documentation "Return the names of all the local variables
+ in ENVIRONMENT. Does not return neither symbol-macrolets nor
+ ignared variables."))
+
+(defgeneric lexical-functions (environment)
+ (:documentation "Returns the names of all the local functions
+ in ENVIRONMENT. Names may be symbols of lists of the form (setf
+ name)."))
+
+(defgeneric lexical-macros (environment)
+ (:documentation "Returns the lexical macro definitions in
+ ENVIRONMENT. The return value is a list of elements of form
+ (SYMBOL . MACRO-FUNCTION. MACRO-FUNCTION can be called like
+ functions returned by macro-function."))
+
+(defgeneric lexical-symbol-macros (environment)
+ (:documentation "Returns the lexical symbol macro definitions
+ in ENVIRONMENT. The return value is a list of elements of form
+ (SYMBOL . EXPANSION)."))
+
+(defmethod lexical-variables ((environment t))
+ '())
+
+(defmethod lexical-functions ((environment t))
+ '())
+
+(defmethod lexical-macros ((environment t))
+ '())
+
+(defmethod lexical-symbol-macros ((environment t))
+ '())
+
+;;;; ** OpenMCL
+
+#+openmcl
+(defmethod environment-p ((e ccl::lexical-environment))
+ t)
+
+#+openmcl
+(defmethod lexical-variables ((environment ccl::lexical-environment))
+ (loop
+ for env = environment
+ then (ccl::lexenv.parent-env env)
+ while (and env
+ (not (ccl::istruct-typep env 'ccl::definition-environment)))
+ for vars = (ccl::lexenv.variables env)
+ when (listp vars)
+ ;; we now weed out all symbol-macros and ignored variables
+ append (remove-if (lambda (var-name)
+ (let ((decs (assoc var-name (ccl::lexenv.vdecls env))))
+ (and decs
+ (eql 'cl:ignore (second decs))
+ (eql 'cl:t (cddr decs)))))
+ (mapcar (lambda (var)
+ ;; ccl::var-name is a macro, se we can't do #'ccl::var-name directly
+ (ccl::var-name var))
+ (remove-if (lambda (var-spec)
+ (and (ccl::var-ea var-spec)
+ (consp (ccl::var-ea var-spec))
+ (eql :symbol-macro (car (ccl::var-ea var-spec)))))
+ vars)))))
+
+#+openmcl
+(defmethod lexical-functions ((environment ccl::lexical-environment))
+ (loop
+ for env = environment
+ then (ccl::lexenv.parent-env env)
+ while (and env
+ (not (ccl::istruct-typep env 'ccl::definition-environment)))
+ for funs = (ccl::lexenv.functions env)
+ when (listp funs)
+ ;; we now weed out all symbol-macros and ignored variables
+ append (mapcar (lambda (func-spec)
+ ;; convert the function name to a "real" function name
+ (let ((name (first func-spec)))
+ (if (eql (symbol-package (first func-spec))
+ (find-package :SETF))
+ (list 'cl:setf (read-from-string (symbol-name name)))
+ name)))
+ (remove-if (lambda (func-spec)
+ ;; weed out all the macrolets
+ (eql 'ccl::macro (second func-spec)))
+ funs))))
+
+;;;; ** SBCL
+
+#+sbcl
+(defmethod environment-p ((environment sb-kernel:lexenv))
+ t)
+
+#+sbcl
+(defmethod lexical-variables ((environment sb-kernel:lexenv))
+ (loop
+ for var-spec in (sb-c::lexenv-vars environment)
+ when (and (atom (cdr var-spec))
+ (not (and (typep (cdr var-spec) 'sb-c::lambda-var)
+ (sb-c::lambda-var-ignorep (cdr var-spec)))))
+ collect (car var-spec)))
+
+#+sbcl
+(defmethod lexical-functions ((environment sb-kernel:lexenv))
+ (loop
+ for fun-spec in (sb-c::lexenv-funs environment)
+ when (not (consp (cdr fun-spec)))
+ collect (car fun-spec)))
+
+#+sbcl
+(defmethod lexical-macros ((environment sb-kernel:lexenv))
+ (loop
+ for mac-spec in (sb-c::lexenv-funs environment)
+ when (and (consp (cdr mac-spec))
+ (eq 'sb-sys::macro (cadr mac-spec)))
+ collect (cons (car mac-spec) (cddr mac-spec))))
+
+#+sbcl
+(defmethod lexical-symbol-macros ((environment sb-kernel:lexenv))
+ (loop
+ for mac-spec in (sb-c::lexenv-vars environment)
+ when (and (consp (cdr mac-spec))
+ (eq 'sb-sys::macro (cadr mac-spec)))
+ collect (cons (car mac-spec) (cddr mac-spec))))
+
+;;;; ** CMUCL
+
+#+cmu
+(defmethod environment-p ((environment c::lexenv))
+ t)
+
+#+cmu
+(defmethod lexical-variables ((environment c::lexenv))
+ (loop
+ for var-spec in (c::lexenv-variables environment)
+ ;; variable refs are (NAME . LAMBDA-VAR), we want to void
+ ;; symbol-macrolets which are (NAME SYSTEM:MACRO . EXPANSION)
+ when (and (atom (cdr var-spec))
+ ;; don't return ignored vars
+ (not (eq (type-of (cdr var-spec)) 'c::global-var))
+ (not (c::lambda-var-ignorep (cdr var-spec))))
+ collect (car var-spec)))
+
+#+cmu
+(defmethod lexical-functions ((environment c::lexenv))
+ (loop
+ for func-spec in (c::lexenv-functions environment)
+ ;; flet and labels function look like ((FLET ACTUAL-NAME) . STUFF)
+ if (and (consp (first func-spec))
+ (member (car (first func-spec)) '(flet labels)))
+ collect (second (first func-spec))
+ ;; macrolets look like (NAME SYSTEM:MACRO . STUFF)
+ else if (and (consp (cdr func-spec))
+ (eql 'system:macro (second func-spec)))
+ ;; except that we don't return macros for now
+ do (progn)
+ ;; handle the case (NAME . #<C::FUNCTIONAL>)
+ else if (typep (cdr func-spec) 'C::FUNCTIONAL)
+ collect (car func-spec)
+ ;; if we get here we're confused :(
+ else
+ do (error "Sorry, don't know how to handle the lexcial function spec ~S."
+ func-spec)))
+
+#+cmu
+(defmethod lexical-macros ((environment c::lexenv))
+ (loop
+ for mac-spec in (c::lexenv-functions environment)
+ when (and (consp (cdr mac-spec))
+ (eq 'system::macro (cadr mac-spec)))
+ collect (cons (car mac-spec) (cddr mac-spec))))
+
+#+cmu
+(defmethod lexical-symbol-macros ((environment c::lexenv))
+ (loop
+ for mac-spec in (c::lexenv-variables environment)
+ when (and (consp (cdr mac-spec))
+ (eq 'system::macro (cadr mac-spec)))
+ collect (cons (car mac-spec) (cddr mac-spec))))
+
+;;;; ** CLISP
+
+#+clisp
+(defmethod environment-p ((environment vector))
+ (= 2 (length environment)))
+
+#+clisp
+(defun walk-vector-tree (function vector-tree)
+ (labels ((%walk (vector-tree)
+ (loop
+ for index upfrom 0 by 2
+ for tree-top = (aref vector-tree index)
+ if (null tree-top)
+ do (return-from %walk nil)
+ else if (vectorp tree-top)
+ do (return-from %walk
+ (%walk tree-top))
+ else
+ do (funcall function
+ (aref vector-tree index)
+ (aref vector-tree (1+ index))))))
+ (%walk vector-tree)))
+
+#+clisp
+(defmethod lexical-variables ((environment vector))
+ (let ((vars '()))
+ (when (aref environment 0)
+ (walk-vector-tree (lambda (var-name var-spec)
+ (unless (system::symbol-macro-p var-spec)
+ (push var-name vars)))
+ (aref environment 0)))
+ vars))
+
+#+clisp
+(defmethod lexical-functions ((environment vector))
+ (let ((vars '()))
+ (when (aref environment 1)
+ (walk-vector-tree (lambda (func-name func-spec)
+ (push func-name vars))
+ (aref environment 1)))
+ vars))
+
+#+clisp
+(defmethod lexical-macros ((environment vector))
+ (let ((macros '()))
+ (when (aref environment 1)
+ (walk-vector-tree
+ (lambda (macro-name macro-spec)
+ (if (system::macrop macro-spec)
+ (push (cons macro-name
+ (macro-function macro-name environment))
+ macros)))
+ (aref environment 1)))
+ macros))
+
+#+clisp
+(defmethod lexical-symbol-macros ((environment vector))
+ (let (symbol-macros '())
+ (when (aref environment 0)
+ (walk-vector-tree
+ (lambda (macro-name macro-spec)
+ (if (system::symbol-macro-p macro-spec)
+ (push (cons macro-name
+ (macroexpand-1 macro-name environment))
+ symbol-macros)))
+ (aref environment 0)))
+ symbol-macros))
+
+;;;; ** LispWorks
+
+#+(and lispworks macosx)
+(defmethod environment-p ((environment system::augmented-environment))
+ t)
+
+#+(and lispworks macosx)
+(defmethod lexical-variables ((environment system::augmented-environment))
+ (mapcar (lambda (venv)
+ (slot-value venv 'compiler::name))
+ (remove-if (lambda (venv)
+ ;; regular variables, the ones we're interested
+ ;; in, appear to have a NIL in this slot.
+ (slot-value venv 'compiler::kind))
+ (slot-value environment 'compiler::venv))))
+
+#+(and lispworks macosx)
+(defmethod lexical-functions ((environment system::augmented-environment))
+ (mapcar #'car
+ (remove-if (lambda (fenv)
+ ;; remove all the macros
+ (eql 'compiler::macro (slot-value (cdr fenv) 'compiler::function-or-macro)))
+ (slot-value environment 'compiler::fenv))))
+
+#+(and lispworks macosx)
+(defmethod environment-p ((environment compiler::environment))
+ t)
+
+#+(and lispworks macosx)
+(defmethod lexical-variables ((environment compiler::environment))
+ (mapcar (lambda (venv)
+ (slot-value venv 'compiler::name))
+ (remove-if (lambda (venv)
+ ;; regular variables, the ones we're interested
+ ;; in, appear to have a NIL in this slot.
+ (slot-value venv 'compiler::kind))
+ (slot-value environment 'compiler::venv))))
+
+#+(and lispworks macosx)
+(defmethod lexical-functions ((environment compiler::environment))
+ (mapcar #'car
+ (remove-if (lambda (fenv)
+ ;; remove all the macros
+ (macro-function (car fenv) environment))
+ (slot-value environment 'compiler::fenv))))
+
+#+(and lispworks (or win32 linux))
+(defmethod environment-p ((environment lexical::environment))
+ t)
+
+#+(and lispworks (or win32 linux))
+(defun lexical-runtime-p (value)
+ (and (symbolp value)
+ (eq (symbol-package value) nil)))
+
+#+(and lispworks (or win32 linux))
+(defmethod lexical-variables ((environment lexical::environment))
+ (loop for candidate in (slot-value environment 'lexical::variables)
+ if (lexical-runtime-p (cdr candidate))
+ collect (car candidate)))
+
+#+(and lispworks (or win32 linux))
+(defmethod lexical-functions ((environment lexical::environment))
+ (loop for candidate in (slot-value environment 'lexical::functions)
+ if (lexical-runtime-p (cdr candidate))
+ collect (car candidate)))
+
+
+#+(and lispworks (or win32 linux))
+(defmethod lexical-symbol-macros ((environment lexical::environment))
+ (loop for candidate in (slot-value environment 'lexical::variables)
+ unless (lexical-runtime-p (cdr candidate))
+ collect candidate))
+
+#+(and lispworks (or win32 linux))
+(defmethod lexical-macros ((environment lexical::environment))
+ (loop for candidate in (slot-value environment 'lexical::functions)
+ unless (lexical-runtime-p (cdr candidate))
+ collect candidate))
+
+;;;; ** Allegro
+
+#+(and allegro (version>= 7 0))
+(defmethod environment-p ((env sys::augmentable-environment)) t)
+
+#+(and allegro (version>= 7 0))
+(defmethod lexical-variables ((env sys::augmentable-environment))
+ (let (fns)
+ (system::map-over-environment-variables
+ (lambda (symbol type rest)
+ (declare (ignore rest))
+ (when (and (eq type :lexical)
+ (sys:variable-information symbol env))
+ (push symbol fns)))
+ env)
+ fns))
+
+#+(and allegro (version>= 7 0))
+(defmethod lexical-functions ((env sys::augmentable-environment))
+ (let (fns)
+ (system::map-over-environment-functions
+ (lambda (name type rest)
+ (when (and (eq type :function)
+ (sys:function-information name env))
+ (push name fns)))
+ env)
+ fns))
+
+#+(and allegro (version>= 7 0))
+(defmethod lexical-macros ((env sys::augmentable-environment))
+ (let (fns)
+ (system::map-over-environment-functions
+ (lambda (name type rest)
+ (when (eq type :macro)
+ (push (cons name (car rest)) fns)))
+ env)
+ fns))
+
+#+(and allegro (version>= 7 0))
+(defmethod lexical-symbol-macros ((env sys::augmentable-environment))
+ (let (fns)
+ (system::map-over-environment-variables
+ (lambda (symbol type rest)
+ (when (eq type :symbol-macro)
+ (push (cons symbol (car rest)) fns)))
+ env)
+ fns))
+
+
+;; These functions are a half-assed implementation of section 8.5 in CLtL2
+;; (environment manipulation)
+;; I really don't feel like implementing THAT interface for every supported
+;; Lisp.
+
+(defgeneric augment-with-variable (env var))
+
+(defgeneric augment-with-function (env fun))
+
+(defgeneric augment-with-macro (env mac def))
+
+(defgeneric augment-with-symbol-macro (env symmac def))
+
+(defmethod augment-with-variable ((env t) var)
+ (declare (ignore var))
+ env)
+
+(defmethod augment-with-function ((env t) fun)
+ (declare (ignore fun))
+ env)
+
+(defmethod augment-with-macro ((env t) mac def)
+ (declare (ignore mac def))
+ env)
+
+(defmethod augment-with-symbol-macro ((env t) symmac def)
+ (declare (ignore symmac def))
+ env)
+
+#+sbcl
+(defmethod augment-with-variable ((env sb-kernel:lexenv) var)
+ (sb-c::make-lexenv :default env :vars (list (cons var t))))
+
+#+sbcl
+(defmethod augment-with-function ((env sb-kernel:lexenv) fun)
+ (sb-c::make-lexenv :default env :funs (list (cons fun t))))
+
+#+sbcl
+(defmethod augment-with-macro ((env sb-kernel:lexenv) mac def)
+ (sb-c::make-lexenv :default env :funs (list (list* mac 'sb-sys::macro def))))
+
+#+sbcl
+(defmethod augment-with-symbol-macro ((env sb-kernel:lexenv) symmac def)
+ (sb-c::make-lexenv :default env :vars (list (list* symmac 'sb-sys::macro def))))
+
+#+cmu
+(defmethod augment-with-variable ((env c::lexenv) var)
+ (c::make-lexenv :default env
+ :variables (list (cons var (c::make-lambda-var :name var)))))
+
+#+cmu
+(defmethod augment-with-function ((env c::lexenv) fun)
+ (c::make-lexenv :default env
+ :functions (list (cons fun (lambda () 42)))))
+
+#+cmu
+(defmethod augment-with-macro ((env c::lexenv) mac def)
+ (c::make-lexenv :default env
+ :functions (list (list* mac 'system::macro def))))
+
+#+cmu
+(defmethod augment-with-symbol-macro ((env c::lexenv) symmac def)
+ (c::make-lexenv :default env
+ :variables (list (list* symmac 'system::macro def))))
+
+
+#+clisp
+(defun augment-with-var-and-fun (env &key var fun)
+ (let* ((old-vars (aref env 0))
+ (old-funs (aref env 1))
+ (new-vars (if (eq var nil)
+ (make-array '(1) :initial-contents (list old-vars))
+ (make-array '(3) :initial-contents (list (car var) (cdr var) old-vars))))
+ (new-funs (if (eq fun nil)
+ (make-array '(1) :initial-contents (list old-funs))
+ (make-array '(3) :initial-contents (list (car fun) (cdr fun) old-funs)))))
+ (make-array '(2) :initial-contents (list new-vars new-funs))))
+
+;; I don't know whether t is an acceptable value to store here,
+;; but CLISP does not complain.
+#+clisp
+(defmethod augment-with-variable ((env vector) var)
+ (augment-with-var-and-fun env :var (cons var t)))
+
+#+clisp
+(defmethod augment-with-function ((env vector) fun)
+ (augment-with-var-and-fun env :fun (cons fun t)))
+
+#+clisp
+(defmethod augment-with-macro ((env vector) mac def)
+ (augment-with-var-and-fun env :fun (cons mac (system::make-macro def))))
+
+#+clisp
+(defmethod augment-with-symbol-macro ((env vector) symmac def)
+ (augment-with-var-and-fun env :var
+ (cons symmac
+ (system::make-symbol-macro def))))
+
+
+#+(and lispworks (or win32 linux))
+(defmethod augment-with-variable ((env lexical::environment) var)
+ (harlequin-common-lisp:augment-environment
+ env :variable (list var)))
+
+#+(and lispworks (or win32 linux))
+(defmethod augment-with-function ((env lexical::environment) fun)
+ (harlequin-common-lisp:augment-environment
+ env :function (list fun)))
+
+#+(and lispworks (or win32 linux))
+(defmethod augment-with-macro ((env lexical::environment) mac def)
+ (harlequin-common-lisp:augment-environment
+ env :macro (list (list mac def))))
+
+#+(and lispworks (or win32 linux))
+(defmethod augment-with-symbol-macro ((env lexical::environment) symmac def)
+ (harlequin-common-lisp:augment-environment
+ env :symbol-macro (list (list symmac def))))
+
+#+(and allegro (version>= 7 0))
+(defmethod augment-with-variable ((env sys::augmentable-environment) var)
+ (system:augment-environment env :variable (list var)))
+
+#+(and allegro (version>= 7 0))
+(defmethod augment-with-function ((env sys::augmentable-environment) fun)
+ (system:augment-environment env :function (list fun)))
+
+#+(and allegro (version>= 7 0))
+(defmethod augment-with-macro ((env sys::augmentable-environment) mac def)
+ (system:augment-environment env :macro (list (list mac def))))
+
+#+(and allegro (version>= 7 0))
+(defmethod augment-with-symbol-macro ((env sys::augmentable-environment) symmac def)
+ (system:augment-environment env :symbol-macro (list (list symmac def))))
+
+
+(defun macroexpand-all (form &optional env)
+ (unwalk-form (walk-form form nil (make-walk-env env))))
+
+;; Sort of parse-macro from CLtL2.
+
+(defun parse-macro-definition (name lambda-list body env)
+ (declare (ignore name))
+ (let* ((environment-var nil)
+ (lambda-list-without-environment
+ (loop
+ for prev = nil then i
+ for i in lambda-list
+ if (not (or (eq '&environment i) (eq '&environment prev)))
+ collect i
+ if (eq '&environment prev)
+ do (if (eq environment-var nil)
+ (setq environment-var i)
+ (error "Multiple &ENVIRONMENT clauses in macro lambda list: ~S" lambda-list))))
+ (handler-env (if (eq environment-var nil) (gensym "ENV-") environment-var))
+ whole-list lambda-list-without-whole)
+ (if (eq '&whole (car lambda-list-without-environment))
+ (setq whole-list (list '&whole (second lambda-list-without-environment))
+ lambda-list-without-whole (cddr lambda-list-without-environment))
+ (setq whole-list '()
+ lambda-list-without-whole lambda-list-without-environment))
+ (eval
+ (with-unique-names (handler-args form-name)
+ `(lambda (,handler-args ,handler-env)
+ ,@(if (eq environment-var nil)
+ `((declare (ignore ,handler-env)))
+ nil)
+ (destructuring-bind (, at whole-list ,form-name , at lambda-list-without-whole)
+ ,handler-args
+ (declare (ignore ,form-name))
+ ,@(mapcar (lambda (form) (macroexpand-all form env)) body)))))))
+
+
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;; - Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;;
+;; - Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;;
+;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;; of its contributors may be used to endorse or promote products
+;; derived from this software without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Added: branches/trunk-reorg/thirdparty/arnesi/src/lisp1.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/lisp1.lisp Mon Feb 11 08:38:43 2008
@@ -0,0 +1,255 @@
+;;;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * Entry point
+
+(defgeneric lisp1 (form)
+ (:documentation "Translate FORM from Lisp-1 to Lisp-2.
+
+Define methods on this generic function with DEFLISP1-WALKER."))
+
+(defmethod lisp1 (form)
+ "If FORM isn't a FORM object, we'll convert it to one, apply
+the transformation and convert it back."
+ (unwalk-form (lisp1 (walk-form form))))
+
+(defmacro with-lisp1 (form)
+ "Execute FORM as if it were run in a Lisp-1."
+ (lisp1 form))
+
+(defmacro deflisp1-walker (class (&rest slots) &body body)
+ "Define a Lisp-1 to Lisp-2 walker.
+
+It takes the class of a CL form object, and its slots as
+arguments. It also captures the variable FORM for convenience."
+ `(defmethod lisp1 ((form ,class))
+ (with-slots ,slots form
+ , at body)))
+
+;;;; * Special Variables
+
+(defvar *bound-vars* nil
+ "When walking code, this variable contains a list of
+variables (represented by symbols) which have been bound in
+the variable namespace.
+
+In essence these variables do not have to be sharp-quoted.")
+
+(defvar *bound-funs* nil
+ "When walking code, this variable contains a list of
+variables (represented by symbols) which have been bound in
+the function namespace.
+
+In essence these variables must be sharp-quoted.")
+
+(defmacro with-bound-vars (vars &body body)
+ "Execute BODY with VARS added to the variable namespace and
+VARS removed from the function namespace.
+
+This should only be used when code-walking."
+ `(let ((*bound-vars* (append *bound-vars* ,vars))
+ (*bound-funs* (set-difference *bound-funs* ,vars)))
+ , at body))
+
+(defmacro with-bound-funs (funs &body body)
+ "Execute BODY with FUNS added to the function namespace and
+FUNS removed from the variable namespace.
+
+This should only be used when code-walking."
+ `(let ((*bound-funs* (append *bound-funs* ,funs))
+ (*bound-vars* (set-difference *bound-vars* ,funs)))
+ , at body))
+
+;;;; * Definers
+
+(defmacro defun1 (name (&rest args) &body body)
+ "Define a function with BODY written in Lisp-1 style.
+
+This is just like DEFUN."
+ (with-bound-vars (extract-argument-names args :allow-specializers nil)
+ `(defun ,name ,args
+ ,(lisp1 `(block ,name , at body)))))
+
+(defmacro defmethod1 (name (&rest args) &body body)
+ "Define a method with BODY written in Lisp-1 style.
+
+This is just like DEFMETHOD."
+ (with-bound-vars (extract-argument-names args :allow-specializers t)
+ `(defmethod ,name ,args
+ ,(lisp1 `(block ,name , at body)))))
+
+;;;; * Utils
+
+(defun lisp1s (forms)
+ "Convert a list of forms to Lisp-1 style."
+ (mapcar #'lisp1 forms))
+
+(defun lisp1b (binds)
+ "Convert an alist of (VAR . FORM) to Lisp-1 style."
+ (mapcar (lambda (bind)
+ (cons (car bind)
+ (lisp1 (cdr bind))))
+ binds))
+
+;;;; * Walkers
+
+(deflisp1-walker form ()
+ ;; By default all forms will stay the same.
+ form)
+
+(deflisp1-walker if-form (consequent then else)
+ ;; Transform the test and branches recursively.
+ (new 'if-form
+ :consequent (lisp1 consequent)
+ :then (lisp1 then)
+ :else (lisp1 else)))
+
+(deflisp1-walker lambda-function-form (arguments body)
+ ;; For any function-form (ie lambda), we just transform the body.
+ ;; We also must add the parameters to the variable namespace, and
+ ;; remove the parameters from the function namespace.
+ (with-bound-vars (mapcar #'name arguments)
+ (new 'lambda-function-form
+ :arguments arguments
+ :body (lisp1s body))))
+
+(deflisp1-walker variable-reference (name)
+ ;; If a free variable is bound in the toplevel, *and* not bound by
+ ;; an enclosing lambda, then we'll return that function. Also, if
+ ;; the variable has been bound by an enclosing function binding form
+ ;; then we'll return that function. We take advantage of the fact
+ ;; that the `name' slot is shared.
+ (if (or (and (fboundp name) (not (member name *bound-vars*)))
+ (member name *bound-funs*))
+ (change-class form 'free-function-object-form)
+ form))
+
+(deflisp1-walker application-form (operator arguments)
+ ;; We transform all applications so they use explicit funcall. We
+ ;; also must take into account ((a b) c ...) which must also
+ ;; transform the operator accordingly.
+ (new 'free-application-form
+ :operator 'funcall
+ :arguments (cons (if (not (typep operator 'form))
+ (lisp1 (walk-form operator))
+ (lisp1 operator))
+ (lisp1s arguments))))
+
+(deflisp1-walker function-binding-form (binds body)
+ ;; Add all the bindings to the function namespace to be sharp
+ ;; quoted.
+ (with-bound-funs (mapcar #'car binds)
+ (new (class-name-of form)
+ :binds (lisp1b binds)
+ :body (lisp1s body))))
+
+(deflisp1-walker variable-binding-form (binds body)
+ ;; Add all the bindings to the variable namespace so they aren't
+ ;; sharp-quoted.
+ (with-bound-vars (mapcar #'car binds)
+ (new (class-name-of form)
+ :binds (lisp1b binds)
+ :body (lisp1s body))))
+
+;; Walking all the other Common Lisp forms is rather straight-forward.
+
+(deflisp1-walker setq-form (var value)
+ (new 'setq-form
+ :var var
+ :value (lisp1 value)))
+
+(deflisp1-walker progn-form (body)
+ (new 'progn-form
+ :body (lisp1s body)))
+
+(deflisp1-walker progv-form (vars-form values-form)
+ (new 'progv-form
+ :vars-form vars-form
+ :values-form (lisp1s values-form)))
+
+(deflisp1-walker block-form (name body)
+ (new 'block-form
+ :name name
+ :body (lisp1s body)))
+
+(deflisp1-walker return-from-form (target-block result)
+ (new 'return-from-form
+ :target-block target-block
+ :result (lisp1 result)))
+
+(deflisp1-walker catch-form (tag body)
+ (new 'catch-form
+ :tag tag
+ :body (lisp1s body)))
+
+(deflisp1-walker throw-form (tag value)
+ (new 'throw-form
+ :tag tag
+ :value (lisp1 value)))
+
+(deflisp1-walker eval-when-form (body eval-when-times)
+ (new 'eval-when-form
+ :eval-when-times eval-when-times
+ :body (lisp1s body)))
+
+(deflisp1-walker multiple-value-call-form (func arguments)
+ (new 'multiple-value-call-form
+ :func (lisp1 func)
+ :arguments (lisp1s arguments)))
+
+(deflisp1-walker multiple-value-prog1-form (first-form other-forms)
+ (new 'multiple-value-prog1-form
+ :first-form (lisp1 first-form)
+ :other-forms (lisp1s other-forms)))
+
+(deflisp1-walker symbol-macrolet-form (binds body)
+ (new 'symbol-macrolet-form
+ :binds (lisp1b binds)
+ :body (lisp1s body)))
+
+(deflisp1-walker tagbody-form (body)
+ (new 'tagbody-form
+ :body (lisp1s body)))
+
+(deflisp1-walker the-form (type-form value)
+ (new 'the-form
+ :type-form type-form
+ :value (lisp1 value)))
+
+(deflisp1-walker unwind-protect-form (protected-form cleanup-form)
+ (new 'unwind-protect-form
+ :protected-form (lisp1 protected-form)
+ :cleanup-form (lisp1s cleanup-form)))
+
+;;;; http://groups.google.com/group/comp.lang.lisp/browse_thread/thread/82994055009163e9
+
+;; Copyright (c) 2006, Hoan Ton-That
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;; - Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;;
+;; - Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;;
+;; - Neither the name of Hoan Ton-That, nor the names of the
+;; contributors may be used to endorse or promote products derived
+;; from this software without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Added: branches/trunk-reorg/thirdparty/arnesi/src/list.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/list.lisp Mon Feb 11 08:38:43 2008
@@ -0,0 +1,223 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * Working with lists
+
+(defmacro dolist* ((iterator list &optional return-value) &body body)
+ "Like DOLIST but destructuring-binds the elements of LIST.
+
+If ITERATOR is a symbol then dolist* is just like dolist EXCEPT
+that it creates a fresh binding."
+ (if (listp iterator)
+ (let ((i (gensym "DOLIST*-I-")))
+ `(dolist (,i ,list ,return-value)
+ (destructuring-bind ,iterator ,i
+ , at body)))
+ `(dolist (,iterator ,list ,return-value)
+ (let ((,iterator ,iterator))
+ , at body))))
+
+(defun ensure-list (thing)
+ "Returns THING as a list.
+
+If THING is already a list (as per listp) it is returned,
+otherwise a one element list containing THING is returned."
+ (if (listp thing)
+ thing
+ (list thing)))
+
+(defun ensure-cons (thing)
+ (if (consp thing)
+ thing
+ (cons thing nil)))
+
+(defun partition (list &rest lambdas)
+ "Split LIST into sub lists according to LAMBDAS.
+
+Each element of LIST will be passed to each element of LAMBDAS,
+the first function in LAMBDAS which returns T will cause that
+element to be collected into the corresponding list.
+
+Examples:
+
+ (partition '(1 2 3) #'oddp #'evenp) => ((1 3) (2))
+
+ (partition '(1 2 3) #'oddp t) => ((1 3) (1 2 3))
+
+ (partition '(1 2 3) #'oddp #'stringp) => ((1 3) nil)"
+ (let ((collectors (mapcar (lambda (predicate)
+ (cons (case predicate
+ ((t :otherwise)
+ (constantly t))
+ ((nil)
+ (constantly nil))
+ (t predicate))
+ (make-collector)))
+ lambdas)))
+ (dolist (item list)
+ (dolist* ((test-func . collector-func) collectors)
+ (when (funcall test-func item)
+ (funcall collector-func item))))
+ (mapcar #'funcall (mapcar #'cdr collectors))))
+
+(defun partitionx (list &rest lambdas)
+ (let ((collectors (mapcar (lambda (l)
+ (cons (if (and (symbolp l)
+ (member l (list :otherwise t)
+ :test #'string=))
+ (constantly t)
+ l)
+ (make-collector)))
+ lambdas)))
+ (dolist (item list)
+ (block item
+ (dolist* ((test-func . collector-func) collectors)
+ (when (funcall test-func item)
+ (funcall collector-func item)
+ (return-from item)))))
+ (mapcar #'funcall (mapcar #'cdr collectors))))
+
+(defmacro dotree ((name tree &optional ret-val) &body body)
+ "Evaluate BODY with NAME bound to every element in TREE. Return RET-VAL."
+ (with-unique-names (traverser list list-element)
+ `(progn
+ (labels ((,traverser (,list)
+ (dolist (,list-element ,list)
+ (if (consp ,list-element)
+ (,traverser ,list-element)
+ (let ((,name ,list-element))
+ , at body)))))
+ (,traverser ,tree)
+ ,ret-val))))
+
+(define-modify-macro push* (&rest items)
+ (lambda (list &rest items)
+ (dolist (i items)
+ (setf list (cons i list)))
+ list)
+ "Pushes every element of ITEMS onto LIST. Equivalent to calling PUSH
+ with each element of ITEMS.")
+
+(defun proper-list-p (object)
+ "Tests whether OBJECT is properlist.
+
+A proper list is a non circular cons chain whose last cdr is eq
+to NIL."
+ (or
+ (null object)
+ (and (consp object)
+ ;; check if the last cdr of object is null. deal with
+ ;; circular lists.
+ (loop
+ for turtoise = object then (cdr turtoise)
+ for hare = (cdr object) then (cddr hare)
+ ;; we need to agressivly check hare's cdr so that the call to
+ ;; cddr doesn't signal an error
+ when (eq turtoise hare) return nil
+ when (null turtoise) return t
+ when (null hare) return t
+ when (not (consp hare)) return nil
+ when (null (cdr hare)) return t
+ when (not (consp (cdr hare))) return nil
+ when (null (cddr hare)) return t
+ when (not (consp (cddr hare))) return nil))))
+
+;;;; ** Simple list matching based on code from Paul Graham's On Lisp.
+
+(defmacro acond2 (&rest clauses)
+ (if (null clauses)
+ nil
+ (with-unique-names (val foundp)
+ (destructuring-bind ((test &rest progn) &rest others)
+ clauses
+ `(multiple-value-bind (,val ,foundp)
+ ,test
+ (if (or ,val ,foundp)
+ (let ((it ,val))
+ (declare (ignorable it))
+ , at progn)
+ (acond2 , at others)))))))
+
+(defun varsymp (x)
+ (and (symbolp x) (eq (aref (symbol-name x) 0) #\?)))
+
+(defun binding (x binds)
+ (labels ((recbind (x binds)
+ (aif (assoc x binds)
+ (or (recbind (cdr it) binds)
+ it))))
+ (let ((b (recbind x binds)))
+ (values (cdr b) b))))
+
+(defun list-match (x y &optional binds)
+ (acond2
+ ((or (eql x y) (eql x '_) (eql y '_))
+ (values binds t))
+ ((binding x binds) (list-match it y binds))
+ ((binding y binds) (list-match x it binds))
+ ((varsymp x) (values (cons (cons x y) binds) t))
+ ((varsymp y) (values (cons (cons y x) binds) t))
+ ((and (consp x) (consp y) (list-match (car x) (car y) binds))
+ (list-match (cdr x) (cdr y) it))
+ (t (values nil nil))))
+
+(defun vars (match-spec)
+ (let ((vars nil))
+ (labels ((find-vars (spec)
+ (cond
+ ((null spec) nil)
+ ((varsymp spec) (push spec vars))
+ ((consp spec)
+ (find-vars (car spec))
+ (find-vars (cdr spec))))))
+ (find-vars match-spec))
+ (delete-duplicates vars)))
+
+(defmacro list-match-case (target &body clauses)
+ (if clauses
+ (destructuring-bind ((test &rest progn) &rest others)
+ clauses
+ (with-unique-names (tgt binds success)
+ `(let ((,tgt ,target))
+ (multiple-value-bind (,binds ,success)
+ (list-match ,tgt ',test)
+ (declare (ignorable ,binds))
+ (if ,success
+ (let ,(mapcar (lambda (var)
+ `(,var (cdr (assoc ',var ,binds))))
+ (vars test))
+ (declare (ignorable ,@(vars test)))
+ , at progn)
+ (list-match-case ,tgt , at others))))))
+ nil))
+
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;; - Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;;
+;; - Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;;
+;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;; of its contributors may be used to endorse or promote products
+;; derived from this software without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Added: branches/trunk-reorg/thirdparty/arnesi/src/log.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/log.lisp Mon Feb 11 08:38:43 2008
@@ -0,0 +1,512 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * A Trivial logging facility
+
+;;;; A logger is a way to have the system generate a text message and
+;;;; have that messaged saved somewhere for future review. Logging can
+;;;; be used as a debugging mechanism or for just reporting on the
+;;;; status of a system.
+
+;;;; Logs are sent to a particular log category, each log category
+;;;; sends the messages it receives to its handlers. A handler's job
+;;;; is to take a message and write it somewhere. Log categories are
+;;;; organized in a hierarchy and messages sent to a log category will
+;;;; also be sent to that category's ancestors.
+
+;;;; Each log category has a log level which is used to determine
+;;;; whether are particular message should be processed or
+;;;; not. Categories inherit their log level from their ancestors. If a
+;;;; category has multiple fathers its log level is the min of the
+;;;; levels of its fathers.
+
+;;;; ** Log Levels
+
+(eval-always
+ (defconstant +dribble+ 0)
+ (defconstant +debug+ 1)
+ (defconstant +info+ 2)
+ (defconstant +warn+ 3)
+ (defconstant +error+ 4)
+ (defconstant +fatal+ 5)
+
+ (defparameter *log-level-names* (coerce '(+dribble+ +debug+ +info+ +warn+ +error+ +fatal+)
+ 'simple-vector))
+ (deflookup-table logger))
+
+(defun log-level-name-of (level)
+ (when (not (<= 0 level #.(1- (length *log-level-names*))))
+ (error "~S is an invalid log level" level))
+ (aref *log-level-names* level))
+
+;;;; ** Log Categories
+
+(defclass log-category ()
+ ((ancestors :initform '() :accessor ancestors :initarg :ancestors
+ :documentation "The log categories this category inherits from.")
+ (children :initform '() :accessor children :initarg :children
+ :documentation "The log categories which inherit from this category.")
+ (appenders :initform '() :accessor appenders :initarg :appenders
+ :documentation "A list of appender objects this category sholud send messages to.")
+ (level :initform nil :initarg :level :accessor level
+ :type (or null integer)
+ :documentation "This category's log level.")
+ (compile-time-level
+ :initform +dribble+ :initarg :compile-time-level :accessor compile-time-level
+ :type integer
+ :documentation "This category's compile time log level. Any log expression below this level will macro-expand to NIL.")
+ (name :initarg :name :accessor name)))
+
+(defmethod make-load-form ((self log-category) &optional env)
+ (declare (ignore env))
+ `(let ((result (get-logger ',(name self))))
+ (assert result)
+ result))
+
+(defmethod print-object ((category log-category) stream)
+ (print-unreadable-object (category stream :type t :identity t)
+ (if (slot-boundp category 'name)
+ (format stream "~S" (name category))
+ (format stream "#<NO NAME>"))))
+
+(defmethod shared-initialize :after ((l log-category) slot-names
+ &key ancestors &allow-other-keys)
+ (declare (ignore slot-names))
+ (dolist (anc ancestors)
+ (pushnew l (children anc) :test (lambda (a b)
+ (eql (name a) (name b))))))
+
+(defun log-level-setter-inspector-action-for (prompt current-level setter)
+ (lambda ()
+ (with-simple-restart
+ (abort "Abort setting log level")
+ (let ((value-string (swank::eval-in-emacs
+ `(condition-case c
+ (let ((arnesi-log-levels '(,@(mapcar #'string-downcase (coerce *log-level-names* 'list)))))
+ (slime-read-object ,prompt :history (cons 'arnesi-log-levels ,(1+ current-level))
+ :initial-value ,(string-downcase (log-level-name-of current-level))))
+ (quit nil)))))
+ (when (and value-string
+ (not (string= value-string "")))
+ (funcall setter (eval (let ((*package* #.(find-package :arnesi)))
+ (read-from-string value-string)))))))))
+
+(defmethod swank:inspect-for-emacs ((category log-category))
+ (let ((class (class-of category)))
+ (values "A log-category."
+ `("Class: " (:value ,class) (:newline)
+ "Runtime level: " (:value ,(log.level category)
+ ,(string (log-level-name-of (log.level category))))
+ " "
+ (:action "[set level]" ,(log-level-setter-inspector-action-for
+ "Set runtime log level to (evaluated): "
+ (log.level category)
+ (lambda (value)
+ (setf (log.level category) value))))
+ (:newline)
+ "Compile-time level: " (:value ,(log.compile-time-level category)
+ ,(string (log-level-name-of (log.compile-time-level category))))
+ " "
+ (:action "[set level]" ,(log-level-setter-inspector-action-for
+ "Set compile-time log level to (evaluated): "
+ (log.compile-time-level category)
+ (lambda (value)
+ (setf (log.compile-time-level category) value))))
+ (:newline)
+ ,@(swank::all-slots-for-inspector category)))))
+
+;;; Runtime levels
+(defmethod enabled-p ((cat log-category) level)
+ (>= level (log.level cat)))
+
+(defmethod log.level ((cat log-category))
+ (or (level cat)
+ (if (ancestors cat)
+ (loop for ancestor in (ancestors cat)
+ minimize (log.level ancestor))
+ (error "Can't determine level for ~S" cat))))
+
+(defmethod log.level ((cat-name symbol))
+ (log.level (get-logger cat-name)))
+
+(defmethod (setf log.level) (new-level (cat log-category)
+ &optional (recursive t))
+ "Change the log level of CAT to NEW-LEVEL. If RECUSIVE is T the
+ setting is also applied to the sub categories of CAT."
+ (setf (slot-value cat 'level) new-level)
+ (when recursive
+ (dolist (child (children cat))
+ (setf (log.level child) new-level)))
+ new-level)
+
+(defmethod (setf log.level) (new-level (cat-name symbol) &optional (recursive t))
+ (setf (log.level (get-logger cat-name) recursive) new-level))
+
+(defmethod (setf log.level) (new-level (cat-name null) &optional (recursive t))
+ (declare (ignore new-level cat-name recursive))
+ (error "NIL does not specify a category."))
+
+;;; Compile time levels
+(defmethod compile-time-enabled-p ((cat log-category) level)
+ (>= level (log.compile-time-level cat)))
+
+(defmethod log.compile-time-level ((cat log-category))
+ (or (compile-time-level cat)
+ (if (ancestors cat)
+ (loop for ancestor in (ancestors cat)
+ minimize (log.compile-time-level ancestor))
+ (error "Can't determine compile time level for ~S" cat))))
+
+(defmethod log.compile-time-level ((cat-name symbol))
+ (log.compile-time-level (get-logger cat-name)))
+
+(defmethod (setf log.compile-time-level) (new-level (cat log-category)
+ &optional (recursive t))
+ "Change the compile time log level of CAT to NEW-LEVEL. If RECUSIVE is T the
+ setting is also applied to the sub categories of CAT."
+ (setf (slot-value cat 'compile-time-level) new-level)
+ (when recursive
+ (dolist (child (children cat))
+ (setf (log.compile-time-level child) new-level)))
+ new-level)
+
+(defmethod (setf log.compile-time-level) (new-level (cat-name symbol) &optional (recursive t))
+ (setf (log.compile-time-level (get-logger cat-name) recursive) new-level))
+
+(defmethod (setf log.compile-time-level) (new-level (cat-name null) &optional (recursive t))
+ (declare (ignore new-level cat-name recursive))
+ (error "NIL does not specify a category."))
+
+(defmacro with-logger-level (logger-name new-level &body body)
+ "Set the level of the listed logger(s) to NEW-LEVEL and restore the original value in an unwind-protect."
+ (cond ((consp logger-name)
+ `(with-logger-level ,(pop logger-name) ,new-level
+ ,(if logger-name
+ `(with-logger-level ,logger-name ,new-level
+ , at body)
+ `(progn
+ , at body))))
+ ((symbolp logger-name)
+ (with-unique-names (logger old-level)
+ `(let* ((,logger (get-logger ',logger-name))
+ (,old-level (level ,logger)))
+ (setf (level ,logger) ,new-level)
+ (unwind-protect
+ (progn , at body)
+ (setf (level ,logger) ,old-level)))))
+ (t (error "Don't know how to interpret ~S as a logger name" logger-name))))
+
+;;;; ** Handling Messages
+
+(defmacro with-logging-io (&body body)
+ `(let ((*print-right-margin* most-positive-fixnum)
+ (*print-readably* nil)
+ (*print-length* 64)
+ (*package* #+ecl (find-package "COMMON-LISP")
+ #-ecl #.(find-package "COMMON-LISP")))
+ , at body))
+
+(defgeneric handle (category message level)
+ (:documentation "Message is either a string or a list. When it's a list and the first element is a string then it's processed as args to cl:format."))
+
+(defmethod handle :around ((cat log-category) message level)
+ ;; turn off line wrapping for the entire time while inside the loggers
+ (with-logging-io
+ (call-next-method)))
+
+(defmethod handle ((cat log-category) message level)
+ (if (appenders cat)
+ ;; if we have any appenders send them the message
+ (dolist (appender (appenders cat))
+ (append-message cat appender message level))
+ ;; send the message to our ancestors
+ (dolist (ancestor (ancestors cat))
+ (handle ancestor message level))))
+
+(defgeneric append-message (category log-appender message level)
+ (:method :around (category log-appender message level)
+ ;; what else should we do?
+ (ignore-errors
+ (call-next-method))))
+
+;;;; *** Stream log appender
+
+(defclass appender ()
+ ((verbosity :initform 2 :initarg :verbosity :accessor verbosity-of)))
+
+(defclass stream-log-appender (appender)
+ ((stream :initarg :stream :accessor log-stream))
+ (:documentation "Human readable to the console logger."))
+
+(defmethod make-instance ((class (eql (find-class 'stream-log-appender)))
+ &rest initargs)
+ (declare (ignore initargs))
+ (error "STREAM-LOG-APPENDER is an abstract class. You must use either brief-stream-log-appender or verbose-stream-log-appender objects."))
+
+(defmethod append-message :around (category (appender stream-log-appender) (message cons) level)
+ (append-message category appender (apply #'format nil message) level))
+
+(defclass brief-stream-log-appender (stream-log-appender)
+ ((last-message-year :initform 0)
+ (last-message-month :initform 0)
+ (last-message-day :initform 0))
+ (:documentation "A subclass of stream-log-appender with minimal
+ 'overhead' text in log messages. This amounts to: not printing
+ the package names of log categories and log levels and a more
+ compact printing of the current time."))
+
+(defclass verbose-stream-log-appender (stream-log-appender)
+ ()
+ (:documentation "A subclass of stream-log-appender which
+ attempts to be as precise as possible, category names and log
+ level names are printed with a package prefix and the time is
+ printed in long format."))
+
+(defmethod append-message :around ((category log-category) (s stream-log-appender)
+ message level)
+ (restart-case
+ (call-next-method)
+ (use-*debug-io* ()
+ :report "Use the current value of *debug-io*"
+ (setf (log-stream s) *debug-io*)
+ (append-message category s message level))
+ (use-*standard-output* ()
+ :report "Use the current value of *standard-output*"
+ (setf (log-stream s) *standard-output*)
+ (append-message category s message level))
+ (silence-logger ()
+ :report "Ignore all future messages to this logger."
+ (setf (log-stream s) (make-broadcast-stream)))))
+
+(eval-always
+ (defparameter *max-category-name-length* 12))
+
+(defmethod append-message ((category log-category) (s brief-stream-log-appender)
+ message level)
+ (multiple-value-bind (second minute hour day month year)
+ (decode-universal-time (get-universal-time))
+ (declare (ignore second))
+ (with-slots (last-message-year last-message-month last-message-day)
+ s
+ (unless (and (= year last-message-year)
+ (= month last-message-month)
+ (= day last-message-day))
+ (format (log-stream s) "--TIME MARK ~4,'0D-~2,'0D-~2,'0D--~%"
+ year month day)
+ (setf last-message-year year
+ last-message-month month
+ last-message-day day)))
+ (let* ((category-name (symbol-name (name category)))
+ (level-name (symbol-name level))
+ (category-length (length category-name)))
+ (format (log-stream s)
+ #.(strcat "~2,'0D:~2,'0D ~"
+ *max-category-name-length*
+ "@A ~7A ")
+ hour minute
+ (subseq category-name
+ (max 0 (- category-length
+ *max-category-name-length*))
+ category-length)
+ (subseq level-name 1 (1- (length level-name)))))
+ (format (log-stream s) "~A~%" message)))
+
+(defmethod append-message ((category log-category) (s verbose-stream-log-appender)
+ message level)
+ (multiple-value-bind (second minute hour date month year)
+ (decode-universal-time (get-universal-time))
+ (format (log-stream s)
+ "~4,'0D-~2,'0D-~2,'0DT~2,'0D:~2,'0D.~2,'0D ~S/~S: "
+ year month date hour minute second
+ (name category) level)
+ (format (log-stream s) "~A~%" message)))
+
+(defun make-stream-log-appender (&rest args &key (stream *debug-io*) (verbosity 2) &allow-other-keys)
+ (remf-keywords args :stream :verbosity)
+ (apply #'make-instance (case verbosity
+ ((0 1) 'brief-stream-log-appender)
+ (t 'verbose-stream-log-appender))
+ :stream stream
+ :verbosity verbosity
+ args))
+
+(defclass slime-repl-log-appender (appender)
+ ()
+ (:documentation "Logs to the slime repl when there's a valid swank::*emacs-connection* bound. Arguments are presented ready for inspection.
+
+You may want to add this to your init.el to speed up cursor movement in the repl buffer with many presentations:
+
+\(add-hook 'slime-repl-mode-hook
+ (lambda ()
+ (setf parse-sexp-lookup-properties nil)))
+"))
+
+(defun swank::present-in-emacs (value-or-values &key (separated-by " "))
+ "Present VALUE in the Emacs repl buffer of the current thread."
+ (unless (consp value-or-values)
+ (setf value-or-values (list value-or-values)))
+ (flet ((present (value)
+ (if (stringp value)
+ (swank::send-to-emacs `(:write-string ,value))
+ (let ((id (swank::save-presented-object value)))
+ (swank::send-to-emacs `(:write-string ,(prin1-to-string value) ,id))))))
+ (map nil (let ((first-time-p t))
+ (lambda (value)
+ (when (and (not first-time-p)
+ separated-by)
+ (present separated-by))
+ (present value)
+ (setf first-time-p nil)))
+ value-or-values))
+ (values))
+
+(defmethod append-message ((category log-category) (appender slime-repl-log-appender)
+ message level)
+ (when (swank::default-connection)
+ (swank::with-connection ((swank::default-connection))
+ (multiple-value-bind (second minute hour day month year)
+ (decode-universal-time (get-universal-time))
+ (declare (ignore second day month year))
+ (swank::present-in-emacs (format nil
+ "~2,'0D:~2,'0D ~A/~A: "
+ hour minute
+ (symbol-name (name category))
+ (symbol-name level))))
+ (if (consp message)
+ (let ((format-control (when (stringp (first message))
+ (first message)))
+ (args (if (stringp (first message))
+ (rest message)
+ message)))
+ (when format-control
+ (setf message (apply #'format nil format-control args)))
+ (swank::present-in-emacs message)
+ (awhen (and format-control
+ (> (verbosity-of appender) 1)
+ (remove-if (lambda (el)
+ (or (stringp el)
+ (null el)))
+ args))
+ (swank::present-in-emacs " (")
+ (swank::present-in-emacs it)
+ (swank::present-in-emacs ")")))
+ (swank::present-in-emacs message))
+ (swank::present-in-emacs #.(string #\Newline)))))
+
+(defun arnesi-logger-inspector-lookup-hook (form)
+ (when (symbolp form)
+ (if-bind logger (get-logger form)
+ (values logger t)
+ (when-bind logger-name (get form 'logger)
+ (when-bind logger (get-logger logger-name)
+ (values logger t))))))
+
+(awhen (find-symbol (symbol-name '#:*inspector-dwim-lookup-hooks*) :swank)
+ (pushnew 'arnesi-logger-inspector-lookup-hook (symbol-value it)))
+
+(defun make-slime-repl-log-appender (&rest args &key (verbosity 2))
+ (remf-keywords args :verbosity)
+ (apply #'make-instance 'slime-repl-log-appender :verbosity verbosity args))
+
+(defclass file-log-appender (stream-log-appender)
+ ((log-file :initarg :log-file :accessor log-file
+ :documentation "Name of the file to write log messages to."))
+ (:documentation "Logs to a file. the output of the file logger
+ is not meant to be read directly by a human."))
+
+(defmethod append-message ((category log-category) (appender file-log-appender)
+ message level)
+ (with-output-to-file (log-file (log-file appender)
+ :if-exists :append
+ :if-does-not-exist :create)
+ (format log-file "(~S ~D ~S ~S)~%" level (get-universal-time) (name category) message)))
+
+(defun make-file-log-appender (file-name)
+ (make-instance 'file-log-appender :log-file file-name))
+
+;;;; ** Creating Loggers
+
+(defmacro deflogger (name ancestors &key compile-time-level level appender appenders documentation)
+ (declare (ignore documentation)
+ (type symbol name))
+ (unless (eq (symbol-package name) *package*)
+ (warn "When defining a logger named ~A the home package of the symbol is not *package* (not (eq ~A ~A)) "
+ (let ((*package* (find-package "KEYWORD")))
+ (format nil "~S" name))
+ (symbol-package name) *package*))
+ (when appender
+ (setf appenders (append appenders (list appender))))
+ (let ((ancestors (mapcar (lambda (ancestor-name)
+ `(or (get-logger ',ancestor-name)
+ (error "Attempt to define a sub logger of the undefined logger ~S."
+ ',ancestor-name)))
+ ancestors)))
+ (flet ((make-log-helper (suffix level)
+ (let ((logger-macro-name (intern (strcat name "." suffix))))
+ `(progn
+ (setf (get ',logger-macro-name 'logger) ',name)
+ (defmacro ,logger-macro-name (message-control &rest message-args)
+ ;; first check at compile time
+ (if (compile-time-enabled-p (get-logger ',name) ,level)
+ ;; then check at runtime
+ `(progn
+ (when (enabled-p (load-time-value (get-logger ',',name)) ,',level)
+ ,(if message-args
+ `(handle (load-time-value (get-logger ',',name)) (list ,message-control , at message-args)
+ ',',level)
+ `(handle (load-time-value (get-logger ',',name)) ,message-control ',',level)))
+ (values))
+ (values)))))))
+ `(progn
+ (eval-when (:load-toplevel :execute)
+ (setf (get-logger ',name) (make-instance 'log-category
+ :name ',name
+ ,@(cond (level
+ `(:level ,level))
+ ((not ancestors)
+ `(:level +debug+))
+ (t '()))
+ ,@(when compile-time-level
+ `(:compile-time-level ,compile-time-level))
+ :appenders (remove nil (list , at appenders))
+ :ancestors (list , at ancestors))))
+ ,(make-log-helper '#:dribble '+dribble+)
+ ,(make-log-helper '#:debug '+debug+)
+ ,(make-log-helper '#:info '+info+)
+ ,(make-log-helper '#:warn '+warn+)
+ ,(make-log-helper '#:error '+error+)
+ ,(make-log-helper '#:fatal '+fatal+)
+ (values)))))
+
+
+
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;; - Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;;
+;; - Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;;
+;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;; of its contributors may be used to endorse or promote products
+;; derived from this software without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Added: branches/trunk-reorg/thirdparty/arnesi/src/matcher.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/matcher.lisp Mon Feb 11 08:38:43 2008
@@ -0,0 +1,341 @@
+;;;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * A fare-like matchingfacility
+
+;;;; The code is written in CPS style, it's hard to understand at
+;;;; first but once you "get it" it's actually quite simple. Basically
+;;;; the idea is that at every point during a match one of two things
+;;;; can happen, the match can succeed or it can fail. What we do is
+;;;; we pass every match two functions (closures usually), one which
+;;;; specifies what to if it succeeds and one which specifies what to
+;;;; do if it fails. These two closures can refer to the original
+;;;; match parameter and hence we can easily "backtrack" if we
+;;;; fail. Another important aspect is that we explicitly pass the
+;;;; target against which to match, if we didn't do this it would be
+;;;; impossible to really backtrack.
+
+;;;; ** The matching and compiling environment
+
+(deflookup-table match-handler
+ :documentation "Table mapping symbol names to the matching function")
+
+(defstruct (match-state (:conc-name ||))
+ target
+ bindings
+ matched)
+
+(defun copy-state (orig-state
+ &key (target nil target-supp)
+ (bindings nil bindings-supp)
+ (matched nil matched-supp))
+ "Make a copy ORIG-STATE."
+ (make-match-state :target (if target-supp
+ target
+ (target orig-state))
+ :bindings (if bindings-supp
+ bindings
+ (bindings orig-state))
+ :matched (if matched-supp
+ matched
+ (matched orig-state))))
+
+(defmacro def-matcher (name args &body body)
+ `(progn (setf (get-match-handler ',name)
+ (lambda ,args , at body))
+ ',name))
+
+(defmacro def-matcher-macro (name args &body body)
+ `(progn (setf (get-match-handler ',name)
+ (lambda ,args
+ (%make-matcher (progn , at body))))
+ ',name))
+
+;;;; ** Matching
+
+(defun make-matcher (spec)
+ "Create a matcher function from SPEC."
+ (let ((%bind-vars% '()))
+ (declare (special %bind-vars%))
+ (values (%make-matcher spec)
+ %bind-vars%)))
+
+(defun %make-matcher (spec)
+ ;; NIL means many different things, deal with it explicitly
+ (if (eql nil spec)
+ (%make-matcher `(:eql ,spec))
+ (if (listp spec)
+ (aif (get-match-handler (car spec))
+ (apply it (cdr spec))
+ (error "Don't know how to handle ~S" spec))
+ (aif (get-match-handler spec)
+ ;; we allow :x as a an abbreviation for (:x)
+ (funcall it)
+ (if (and (symbolp spec)
+ (not (keywordp spec)))
+ (%make-matcher `(:bind :anything ,spec))
+ (if (constantp spec)
+ (%make-matcher `(:eql ,spec))
+ (error "Don't know how to deal with ~S" spec)))))))
+
+(defun match (matcher target)
+ "Attempt to match MATCHER against TARGET. MATCHER can be either a
+function or a list."
+ (if (functionp matcher)
+ (funcall matcher
+ (make-match-state :target target
+ :bindings '()
+ :matched nil)
+ (lambda (s k q)
+ (declare (ignore k q))
+ (return-from match (values t
+ (matched s)
+ (bindings s))))
+ (lambda (s k q)
+ (declare (ignore s k q))
+ (return-from match (values nil nil nil))))
+ (match (make-matcher matcher) target)))
+
+(defmacro match-case (form &rest clauses)
+ "NB: the clauses wil be compiled at macro expansion time."
+ (when clauses
+ (destructuring-bind ((spec &rest body) &rest other-clauses) clauses
+ (with-unique-names (form-sym matched-p dummy bindings)
+ (multiple-value-bind (matcher-func vars)
+ (make-matcher spec)
+ (declare (ignore matcher-func))
+ `(let ((,form-sym ,form))
+ (multiple-value-bind (,matched-p ,dummy ,bindings)
+ (match (make-matcher ',spec) ,form-sym)
+ (declare (ignore ,dummy) (ignorable ,bindings))
+ (if ,matched-p
+ (let ,vars
+ ,@(mapcar (lambda (var-name)
+ `(setf ,var-name (cdr (assoc ',var-name ,bindings))))
+ vars)
+ , at body)
+ (match-case ,form-sym , at other-clauses)))))))))
+
+;;;; ** Matching forms
+
+(def-matcher :bind (spec var)
+ "The :bind matcher attempts to match MATCHER and bind whatever
+ MATCHER consumnd to VAR. group is equivalent to SPEC except the value
+ of matched when spec has matched will be bound to var."
+ (declare (special %bind-vars%))
+ (push var %bind-vars%)
+ (let ((spec-matcher (%make-matcher spec)))
+ (lambda (s k q)
+ (funcall spec-matcher s
+ (lambda (s. k. q.)
+ (declare (ignore k.))
+ ;; SPEC succeded, bind var
+ (funcall k (copy-state s. :bindings (cons (cons var (matched s.)) (bindings s.)))
+ k q.))
+ q))))
+
+(def-matcher :ref (var &key (test #'eql))
+ (lambda (s k q)
+ (if (and (assoc var (bindings s))
+ (funcall test (target s) (cdr (assoc var (bindings s)))))
+ (funcall k (copy-state s :matched (target s))
+ k q)
+ (funcall q s k q))))
+
+(def-matcher :alternation (a-spec b-spec)
+ (let ((a (%make-matcher a-spec))
+ (b (%make-matcher b-spec)))
+ (lambda (s k q)
+ ;; first try A
+ (funcall a s k
+ ;; a failed, try B
+ (lambda (s. k. q.)
+ (declare (ignore s. k. q.))
+ (funcall b s k q))))))
+
+(def-matcher-macro :alt (&rest possibilities)
+ (case (length possibilities)
+ (0 `(:fail))
+ (1 (car possibilities))
+ (t `(:alternation ,(car possibilities) (:alt ,@(cdr possibilities))))))
+
+(def-matcher :fail ()
+ (lambda (s k q)
+ (funcall q s k q)))
+
+(def-matcher :not (match)
+ (let ((m (%make-matcher match)))
+ (lambda (s k q)
+ (funcall m s q k))))
+
+(def-matcher :anything ()
+ (lambda (s k q)
+ (funcall k (copy-state s :matched (target s))
+ k q)))
+
+;;;; ** Matching within a sequence
+
+(defun next-target ()
+ (declare (special *next-target*))
+ (funcall *next-target*))
+
+(defun make-greedy-star (m)
+ (lambda (s k q)
+ (if (funcall m (target s))
+ (funcall (make-greedy-star m) (copy-state s
+ :matched (target s)
+ :target (next-target))
+ k (lambda (s. k. q.)
+ (declare (ignore k. s.))
+ (funcall k s k q.)))
+ (funcall q s k q))))
+
+(def-matcher :greedy-star (match)
+ (make-greedy-star (%make-matcher match)))
+
+;;;; ** The actual matching operators
+
+;;;; All of the above allow us to build matchers but non of them
+;;;; actually match anything.
+
+(def-matcher :test (predicate)
+ "Matches if the current matches satisfies PREDICATE."
+ (lambda (s k q)
+ (if (funcall predicate (target s))
+ (funcall k (copy-state s :matched (target s))
+ k q)
+ (funcall q s k q))))
+
+(def-matcher-macro :test-not (predicate)
+ `(:not (:test ,predicate)))
+
+(def-matcher-macro :satisfies-p (predicate)
+ `(:test ,(lambda (target) (funcall predicate target))))
+
+(def-matcher-macro :eq (object)
+ `(:test ,(lambda (target) (eq object target))))
+
+(def-matcher-macro :eql (object)
+ `(:test ,(lambda (target) (eql object target))))
+
+(def-matcher-macro cl:quote (constant)
+ `(:eql ,constant))
+
+(def-matcher-macro :equal (object)
+ `(:test ,(lambda (target) (equal object target))))
+
+(def-matcher-macro :equalp (object)
+ `(:test ,(lambda (target) (equalp object target))))
+
+(def-matcher :cons (car-spec cdr-spec)
+ (let ((car (%make-matcher car-spec))
+ (cdr (%make-matcher cdr-spec)))
+ (lambda (s k q)
+ (if (consp (target s))
+ (funcall car (copy-state s :target (car (target s)))
+ (lambda (s. k. q.)
+ (declare (ignore k.))
+ ;; car matched, try cdr
+ (funcall cdr (copy-state s. :target (cdr (target s)))
+ (lambda (s.. k.. q..)
+ (declare (ignore k.. q..))
+ ;; cdr matched, ok, we've matched!
+ (funcall k (copy-state s.. :matched (target s))
+ k q))
+ q.))
+ q)
+ (funcall q s k q)))))
+
+(def-matcher-macro :list (&rest items)
+ `(:list* , at items nil))
+
+(def-matcher-macro :list* (&rest items)
+ (case (length items)
+ (1 (car items))
+ (2 `(:cons ,(first items) ,(second items)))
+ (t
+ `(:cons ,(first items) (:list* ,@(cdr items))))))
+
+(def-matcher :property (key value-spec)
+ (let ((value (%make-matcher value-spec)))
+ (lambda (s k q)
+ (if (listp (target s))
+ (aif (getf (target s) key)
+ (funcall value (copy-state s :target it)
+ (lambda (s. k. q.)
+ (declare (ignore k. q.))
+ (funcall k (copy-state s. :matched (target s))
+ k q))
+ q)
+ (funcall q s k q))
+ (funcall q s k q)))))
+
+(def-matcher :accessor (type accessor value-spec)
+ (let ((value (%make-matcher value-spec)))
+ (lambda (s k q)
+ (if (typep (target s) type)
+ (funcall value (copy-state s :target (funcall accessor (target s)))
+ (lambda (s. k. q.)
+ (declare (ignore k. q.))
+ (funcall k (copy-state s. :matched (target s))
+ k q))
+ q)
+ (funcall q s k q)))))
+
+(def-matcher :and (a-spec b-spec)
+ (let ((a (%make-matcher a-spec))
+ (b (%make-matcher b-spec)))
+ (lambda (s k q)
+ (funcall a s
+ (lambda (s. k. q.)
+ (declare (ignore k. q.))
+ (funcall b (copy-state s. :target (target s))
+ k q))
+ q))))
+
+(def-matcher-macro :plist (&rest items)
+ (case (length items)
+ (1 (error ":PLIST has been given an odd num of args."))
+ (2 `(:PROPERTY ,(first items) ,(second items)))
+ (t
+ `(:AND (:PROPERTY ,(first items) ,(second items))
+ (:PLIST ,@(nthcdr 2 items))))))
+
+(def-matcher-macro :accessors (type &rest accs-vals)
+ (case (length accs-vals)
+ (1 (error ":ACCESSORS has been given an odd num of args."))
+ (2 `(:ACCESSOR ,type ,(first accs-vals) ,(second accs-vals)))
+ (t
+ `(:AND (:ACCESSOR ,type ,(first accs-vals) ,(second accs-vals))
+ (:ACCESSORS ,type ,@(nthcdr 2 accs-vals))))))
+
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;; - Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;;
+;; - Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;;
+;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;; of its contributors may be used to endorse or promote products
+;; derived from this software without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Added: branches/trunk-reorg/thirdparty/arnesi/src/mop.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/mop.lisp Mon Feb 11 08:38:43 2008
@@ -0,0 +1,126 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * Messing with the MOP
+
+;;;; The code pre-dates Pascal Costanza's closer-mop package. If
+;;;; you're looking for a compatability layer you should probably look
+;;;; there instead.
+
+(defmacro with-class-slots ((object class-name &key except) &body body)
+ "Execute BODY as if in a with-slots form containig _all_ the
+ slots of (find-clas CLASS-NAME). This macro, which is something
+ of an ugly hack, inspects the class named by CLASS-NAME at
+ macro expansion time. Should the class CLASS-NAME change form
+ containing WITH-CLASS-SLOTS must be recompiled. Should the
+ class CLASS-NAME not be available at macro expansion time
+ WITH-CLASS-SLOTS will fail."
+ (declare (ignore object class-name except body))
+ (error "Not yet implemented."))
+
+;;;; ** wrapping-standard method combination
+
+(define-method-combination wrapping-standard
+ (&key (around-order :most-specific-first)
+ (before-order :most-specific-first)
+ (primary-order :most-specific-first)
+ (after-order :most-specific-last)
+ (wrapping-order :most-specific-last)
+ (wrap-around-order :most-specific-last))
+ ((wrap-around (:wrap-around))
+ (around (:around))
+ (before (:before))
+ (wrapping (:wrapping))
+ (primary () :required t)
+ (after (:after)))
+ "Same semantics as standard method combination but allows
+\"wrapping\" methods. Ordering of methods:
+
+ (wrap-around
+ (around
+ (before)
+ (wrapping
+ (primary))
+ (after)))
+
+:warp-around, :around, :wrapping and :primary methods call the
+next least/most specific method via call-next-method (as in
+standard method combination).
+
+The various WHATEVER-order keyword arguments set the order in
+which the methods are called and be set to either
+:most-specific-last or :most-specific-first."
+ (labels ((effective-order (methods order)
+ (ecase order
+ (:most-specific-first methods)
+ (:most-specific-last (reverse methods))))
+ (call-methods (methods)
+ (mapcar (lambda (meth) `(call-method ,meth))
+ methods)))
+ (let* (;; reorder the methods based on the -order arguments
+ (wrap-around (effective-order wrap-around wrap-around-order))
+ (around (effective-order around around-order))
+ (wrapping (effective-order wrapping wrapping-order))
+ (before (effective-order before before-order))
+ (primary (effective-order primary primary-order))
+ (after (effective-order after after-order))
+ ;; inital value of the effective call is a call its primary
+ ;; method(s)
+ (form (case (length primary)
+ (1 `(call-method ,(first primary)))
+ (t `(call-method ,(first primary) ,(rest primary))))))
+ (when wrapping
+ ;; wrap form in call to the wrapping methods
+ (setf form `(call-method ,(first wrapping)
+ (,@(rest wrapping) (make-method ,form)))))
+ (when before
+ ;; wrap FORM in calls to its before methods
+ (setf form `(progn
+ ,@(call-methods before)
+ ,form)))
+ (when after
+ ;; wrap FORM in calls to its after methods
+ (setf form `(multiple-value-prog1
+ ,form
+ ,@(call-methods after))))
+ (when around
+ ;; wrap FORM in calls to its around methods
+ (setf form `(call-method ,(first around)
+ (,@(rest around)
+ (make-method ,form)))))
+ (when wrap-around
+ (setf form `(call-method ,(first wrap-around)
+ (,@(rest wrap-around)
+ (make-method ,form)))))
+ form)))
+
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;; - Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;;
+;; - Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;;
+;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;; of its contributors may be used to endorse or promote products
+;; derived from this software without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Added: branches/trunk-reorg/thirdparty/arnesi/src/mopp.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/mopp.lisp Mon Feb 11 08:38:43 2008
@@ -0,0 +1,340 @@
+;; -*- lisp -*-
+
+;;;; * A MOP compatibility protocol
+
+(defpackage :it.bese.arnesi.mopp
+ (:nicknames :mopp)
+ (:documentation "A MOP compatabilitly layer.
+
+This package wraps the various similar but slightly different MOP
+APIs. All the MOP symbols are exported (even those which are
+normally exported from the common-lisp package) though not all
+maybe be properly defined on all lisps.
+
+The name of the library in an acronym for \"the Meta Object
+Protocol Package\".
+
+This package is nominally part of the arnesi utility library but
+has been written so that this single file can be included in
+other applications without requiring the rest of the arnesi
+library.
+
+Implementation Notes:
+
+1) The mopp package also exports the function
+ SLOT-DEFINITION-DOCUMENTATION which while not strictly part of
+ the MOP specification really should be and is implementened on
+ most systems.
+
+2) On Lispworks (tested only lightly) the MOPP package
+ implementes an eql-specializer class and defines a version of
+ method-specializers built upon clos:method-specializers which
+ returns them.")
+ (:use)
+ (:export
+ ;; classes
+ #:standard-object
+ #:funcallable-standard-object
+ #:metaobject
+ #:generic-function
+ #:standard-generic-function
+ #:method
+ #:standard-method
+ #:standard-accessor-method
+ #:standard-reader-method
+ #:standard-writer-method
+ #:method-combination
+ #:slot-definition
+ #:direct-slot-definition
+ #:effective-slot-definition
+ #:standard-slot-definition
+ #:standard-direct-slot-definition
+ #:standard-effective-slot-definition
+ #:specializer
+ #:eql-specializer
+ #:class
+ #:built-in-class
+ #:forward-referenced-class
+ #:standard-class
+ #:funcallable-standard-class
+ ;; Taken from the MOP dictionary
+ #:accessor-method-slot-definition
+ #:add-dependent
+ #:add-direct-method
+ #:add-direct-subclass
+ #:add-method
+ #:allocate-instance
+ #:class-default-initargs
+ #:class-direct-default-initargs
+ #:class-direct-slots
+ #:class-direct-subclasses
+ #:class-direct-superclasses
+ #:class-finalized-p
+ #:class-name
+ #:class-precedence-list
+ #:class-prototype
+ #:class-slots
+ #:compute-applicable-methods
+ #:compute-applicable-methods-using-classes
+ #:compute-class-precedence-list
+ #:compute-default-initargs
+ #:compute-discriminating-function
+ #:compute-effective-method
+ #:compute-effective-slot-definition
+ #:compute-slots
+ #:direct-slot-definition-class
+ #:effective-slot-definition-class
+ #:ensure-class-using-class
+ #:ensure-generic-function
+ #:ensure-generic-function-using-class
+ #:eql-specializer-object
+ #:extract-lambda-list
+ #:extract-specializer-names
+ #:finalize-inheritance
+ #:find-method-combination
+ #:funcallable-standard-instance-access
+ #:generic-function-argument-precedence-order
+ #:generic-function-declarations
+ #:generic-function-lambda-list
+ #:generic-function-method-class
+ #:generic-function-method-combination
+ #:generic-function-methods
+ #:generic-function-name
+ #:intern-eql-specializer
+ #:make-instance
+ #:make-method-lambda
+ #:map-dependents
+ #:method-function
+ #:method-generic-function
+ #:method-lambda-list
+ #:method-specializers
+ #:method-qualifiers
+ #:reader-method-class
+ #:remove-dependent
+ #:remove-direct-method
+ #:remove-direct-subclass
+ #:remove-method
+ #:set-funcallable-instance-function
+ #:slot-boundp-using-class
+ #:slot-definition-allocation
+ #:slot-definition-documentation
+ #:slot-definition-initargs
+ #:slot-definition-initform
+ #:slot-definition-initfunction
+ #:slot-definition-location
+ #:slot-definition-name
+ #:slot-definition-readers
+ #:slot-definition-writers
+ #:slot-definition-type
+ #:slot-makunbound-using-class
+ #:slot-value-using-class
+ #:specializer-direct-generic-functions
+ #:specializer-direct-methods
+ #:standard-instance-access
+ #:update-dependent
+ #:validate-superclass
+ #:writer-method-class))
+
+(defpackage :it.bese.arnesi.mopp%internals
+ (:use :common-lisp))
+
+(in-package :it.bese.arnesi.mopp%internals)
+
+(defgeneric provide-mopp-symbol (symbol implementation)
+ (:documentation "Provide the implementation of the MOP symbol SYMBOL.
+
+SYMBOL - One of the external symbols of the package it.bese.arnesi.mopp
+
+IMPLEMENTATION - A keyword indetifying the implementation, one
+of: :OPENMCL, :SBCL, :CMU, :LISPWORKS, :ALLEGRO.
+
+Do \"something\" such that the external symbol SYMBOL in the mopp
+package provides the sematics for the like named symbol in the
+MOP. Methods defined on this generic function are free to
+destructivly modify SYMBOL (and the mopp package) as long as when
+the method terminates there is a symbol with the same name as
+SYMBOL exported form the package mopp.
+
+Methods must return a true value if they have successfully
+provided SYMBOL and nil otherwise."))
+
+(defun import-to-mopp (symbol)
+ (let ((sym (find-symbol (string symbol) :it.bese.arnesi.mopp)))
+ (when sym
+ (unexport sym :it.bese.arnesi.mopp)
+ (unintern sym :it.bese.arnesi.mopp)))
+ (import symbol :it.bese.arnesi.mopp)
+ (export symbol :it.bese.arnesi.mopp)
+ t)
+
+;;;; OpenMCL
+
+(defmethod provide-mopp-symbol ((symbol symbol)
+ (implementation (eql :openmcl)))
+ "Provide MOP symbols for OpenMCL.
+
+All of OpenMCL's MOP is defined in the CCL package."
+ (when (find-symbol (string symbol) :ccl)
+ (import-to-mopp (find-symbol (string symbol) :ccl))))
+
+;;;; SBCL
+
+(defmethod provide-mopp-symbol ((symbol symbol)
+ (implementation (eql :sbcl)))
+ (when (find-symbol (string symbol) :sb-mop)
+ (import-to-mopp (find-symbol (string symbol) :sb-mop))))
+
+(defmethod provide-mopp-symbol ((symbol (eql 'mopp:slot-definition-documentation))
+ (implementation (eql :sbcl)))
+ "Provide SLOT-DEFINITION-DOCUMENTATION for SBCL.
+
+On SBCL SLOT-DEFINITION-DOCUMENTATION is just a call to
+sb-pcl:documentation."
+ t)
+
+#+sbcl
+(defun mopp:slot-definition-documentation (slot)
+ (sb-pcl::documentation slot t))
+
+;;;; CMUCL
+
+(defmethod provide-mopp-symbol ((symbol symbol) (implementation (eql :cmu)))
+ (when (find-symbol (string symbol) :pcl)
+ (import-to-mopp (find-symbol (string symbol) :pcl))))
+
+(defmethod provide-mopp-symbol ((symbol (eql 'mopp:slot-definition-documentation))
+ (implementation (eql :cmu)))
+ "Provide SLOT-DEFINITION-DOCUMENTATION on CMUCL.
+
+Like SBCL SLOT-DEFINITION-DOCUMENTATION on CMUCL is just a call
+to documentation."
+ t)
+
+#+cmu
+(defun mopp:slot-definition-documentation (slot)
+ (documentation slot t))
+
+;;;; Lispworks
+
+(defmethod provide-mopp-symbol ((symbol symbol) (implementation (eql :lispworks)))
+ (when (find-symbol (string symbol) :clos)
+ (import-to-mopp (find-symbol (string symbol) :clos))))
+
+(defmethod provide-mopp-symbol ((symbol (eql 'mopp:eql-specializer))
+ (implementation (eql :lispworks)))
+ t)
+
+(defmethod provide-mopp-symbol ((symbol (eql 'mopp:eql-specializer-object))
+ (implementation (eql :lispworks)))
+ t)
+
+(defmethod provide-mopp-symbol ((symbol (eql 'mopp:method-specializers))
+ (implementation (eql :lispworks)))
+ "We can not simply export CLOS:METHOD-SPECIALIZERS as we have
+to insert mopp:eql-specializers"
+ t)
+
+#+lispworks
+(defclass mopp:eql-specializer ()
+ ((object :accessor mopp::eql-specializer-object :initarg :object))
+ (:documentation "Wrapper class representing eql-specializers.
+
+Lispworks does not implement an eql-specializer class but simply
+returns lists form method-specializers, this class (along with a
+wrapper for clos:method-specializers) hide this detail."))
+
+#+lispworks
+(defun mopp:method-specializers (method)
+ "More MOP-y implementation of clos:method-specializers.
+
+For every returned value of clos:method-specializers of the
+form `(eql ,OBJECT) this function returns a mopp:eql-specializer
+object wrapping OBJECT."
+ (mapcar (lambda (spec)
+ (typecase spec
+ (cons (make-instance 'mopp:eql-specializer :object (second spec)))
+ (t spec)))
+ (clos:method-specializers method)))
+
+;;;; CLISP
+
+(defmethod provide-mopp-symbol ((symbol symbol) (implementation (eql :clisp)))
+ (when (find-symbol (string symbol) :clos)
+ (import-to-mopp (find-symbol (string symbol) :clos))))
+
+;;;; ALLEGRO
+
+(defmethod provide-mopp-symbol ((symbol symbol) (implementation (eql :allegro)))
+ (when (find-symbol (string symbol) :mop)
+ (import-to-mopp (find-symbol (string symbol) :mop))))
+
+(defmethod provide-mopp-symbol ((symbol (eql 'mopp:slot-definition-documentation))
+ (implementation (eql :allegro)))
+ t)
+
+#+allegro
+(defun mopp:slot-definition-documentation (slot)
+ (documentation slot t))
+
+;;;; ** Building the MOPP package
+
+;;;; we can't just do a do-external-symbols since we mess with the
+;;;; package and that would put us in implementation dependent
+;;;; territory, so we first build up a list of all the external symbols
+;;;; in mopp and then work on that list.
+
+#+(or
+ openmcl
+ sbcl
+ cmu
+ lispworks
+ clisp
+ allegro)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (pushnew 'mopp::have-mop *features*))
+
+#+mopp::have-mop
+(let ((external-symbols '()))
+ (do-external-symbols (sym (find-package :it.bese.arnesi.mopp))
+ (push sym external-symbols))
+ (dolist (sym external-symbols)
+ (unless (provide-mopp-symbol sym #+openmcl :openmcl
+ #+sbcl :sbcl
+ #+cmu :cmu
+ #+lispworks :lispworks
+ #+clisp :clisp
+ #+allegro :allegro)
+ (warn "Unimplemented MOP symbol: ~S" sym))))
+
+#-mopp::have-mop
+(warn "No MOPP implementation available for this lisp implementation.")
+
+;; Copyright (C) 2004-2006 Edward Marco Baringer
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;; - Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;;
+;; - Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;;
+;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;; of its contributors may be used to endorse or promote products
+;; derived from this software without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Added: branches/trunk-reorg/thirdparty/arnesi/src/numbers.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/numbers.lisp Mon Feb 11 08:38:43 2008
@@ -0,0 +1,152 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * Messing with numbers
+
+(defun parse-ieee-double (u64)
+ "Given an IEEE 64 bit double representeted as an integer (ie a
+ sequence of 64 bytes), return the coressponding double value"
+ (* (expt -1 (ldb (byte 1 63) u64))
+ (expt 2 (- (ldb (byte 11 52) u64) 1023))
+ (1+ (float (loop for i from 51 downto 0
+ for n = 2 then (* 2 n)
+ for frac = (* (/ n) (ldb (byte 1 i) u64))
+ sum frac)))))
+
+(defun radix-values (radix)
+ (assert (<= 2 radix 35)
+ (radix)
+ "RADIX must be between 2 and 35 (inclusive), not ~D." radix)
+ (make-array radix
+ :displaced-to "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"
+ :displaced-index-offset 0
+ :element-type
+ #+lispworks 'base-char
+ #-lispworks 'character))
+
+(defun parse-float (float-string
+ &key (start 0) (end nil) (radix 10)
+ (junk-allowed t)
+ (type 'single-float)
+ (decimal-character #\.))
+ (let ((radix-array (radix-values radix))
+ (integer-part 0)
+ (mantissa 0)
+ (mantissa-size 1)
+ (sign 1))
+ (with-input-from-string (float-stream (string-upcase (string-trim '(#\Space #\Tab) float-string)) :start start :end end)
+ (labels ((peek () (peek-char nil float-stream nil nil nil))
+ (next () (read-char float-stream nil nil nil))
+ (sign () ;; reads the (optional) sign of the number
+ (cond
+ ((char= (peek) #\+) (next) (setf sign 1))
+ ((char= (peek) #\-) (next) (setf sign -1)))
+ (integer-part))
+ (integer-part ()
+ (cond
+ ((position (peek) radix-array)
+ ;; the next char is a valid char
+ (setf integer-part (+ (* integer-part radix)
+ (position (next) radix-array)))
+ ;; again
+ (return-from integer-part (integer-part)))
+ ((null (peek))
+ ;; end of string
+ (done))
+ ((char= decimal-character (peek))
+ ;; the decimal seperator
+ (next)
+ (return-from integer-part (mantissa)))
+ ;; junk
+ (junk-allowed (done))
+ (t (bad-string))))
+ (mantissa ()
+ (cond
+ ((position (peek) radix-array)
+ (setf mantissa (+ (* mantissa radix)
+ (position (next) radix-array))
+ mantissa-size (* mantissa-size radix))
+ (return-from mantissa
+ (mantissa)))
+ ((or (null (peek)) junk-allowed)
+ ;; end of string
+ (done))
+ (t (bad-string))))
+ (bad-string ()
+ (error "Unable to parse ~S." float-string))
+ (done ()
+ (return-from parse-float
+ (coerce (* sign (+ integer-part (/ mantissa mantissa-size))) type))))
+ (sign)))))
+
+(define-modify-macro mulf (B)
+ *
+ "SETF NUM to the result of (* NUM B).")
+
+(define-modify-macro divf (B)
+ /
+ "SETF NUM to the result of (/ NUM B).")
+
+(define-modify-macro minf (other)
+ (lambda (current other)
+ (if (< other current)
+ other
+ current))
+ "Sets the place to new-value if new-value is #'< the current value")
+
+(define-modify-macro maxf (other)
+ (lambda (current other)
+ (if (> other current)
+ other
+ current))
+ "Sets the place to new-value if new-value is #'> the current value")
+
+(defun map-range (lambda min max &optional (step 1))
+ (loop for i from min upto max by step
+ collect (funcall lambda i)))
+
+(defmacro do-range ((index &optional min max step return-value)
+ &body body)
+ (assert (or min max)
+ (min max)
+ "Must specify at least MIN or MAX")
+ `(loop
+ for ,index ,@(when min `(from ,min))
+ ,@(when max `(upto ,max))
+ ,@(when step `(by ,step))
+ do (progn , at body)
+ finally (return ,return-value)))
+
+(defun 10^ (x)
+ (expt 10 x))
+
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;; - Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;;
+;; - Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;;
+;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;; of its contributors may be used to endorse or promote products
+;; derived from this software without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Added: branches/trunk-reorg/thirdparty/arnesi/src/one-liners.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/one-liners.lisp Mon Feb 11 08:38:43 2008
@@ -0,0 +1,228 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * Miscalaneous stuff
+
+(defun intern-concat (string-designators &optional (package *package*))
+ (intern (with-output-to-string (symbol-name)
+ (dolist (designator string-designators)
+ (write-string (etypecase designator
+ (symbol (symbol-name designator))
+ (string designator))
+ symbol-name)))
+ package))
+
+(defmacro with-unique-names ((&rest bindings) &body body)
+ "Evaluate BODY with BINDINGS bound to fresh unique symbols.
+
+Syntax: WITH-UNIQUE-NAMES ( [ var | (var x) ]* ) declaration* form*
+
+Executes a series of forms with each VAR bound to a fresh,
+uninterned symbol. The uninterned symbol is as if returned by a call
+to GENSYM with the string denoted by X - or, if X is not supplied, the
+string denoted by VAR - as argument.
+
+The variable bindings created are lexical unless special declarations
+are specified. The scopes of the name bindings and declarations do not
+include the Xs.
+
+The forms are evaluated in order, and the values of all but the last
+are discarded \(that is, the body is an implicit PROGN)."
+ ;; reference implementation posted to comp.lang.lisp as
+ ;; <cy3bshuf30f.fsf at ljosa.com> by Vebjorn Ljosa - see also
+ ;; <http://www.cliki.net/Common%20Lisp%20Utilities>
+ `(let ,(mapcar (lambda (binding)
+ (check-type binding (or cons symbol))
+ (destructuring-bind (var &optional (prefix (symbol-name var)))
+ (if (consp binding) binding (list binding))
+ (check-type var symbol)
+ `(,var (gensym ,(concatenate 'string prefix "-")))))
+ bindings)
+ , at body))
+
+(defmacro rebinding (bindings &body body)
+ "Bind each var in BINDINGS to a gensym, bind the gensym to
+var's value via a let, return BODY's value wrapped in this let.
+
+Evaluates a series of forms in the lexical environment that is
+formed by adding the binding of each VAR to a fresh, uninterned
+symbol, and the binding of that fresh, uninterned symbol to VAR's
+original value, i.e., its value in the current lexical
+environment.
+
+The uninterned symbol is created as if by a call to GENSYM with the
+string denoted by PREFIX - or, if PREFIX is not supplied, the string
+denoted by VAR - as argument.
+
+The forms are evaluated in order, and the values of all but the last
+are discarded \(that is, the body is an implicit PROGN)."
+ ;; reference implementation posted to comp.lang.lisp as
+ ;; <cy3wv0fya0p.fsf at ljosa.com> by Vebjorn Ljosa - see also
+ ;; <http://www.cliki.net/Common%20Lisp%20Utilities>
+ (loop for binding in bindings
+ for var = (car (if (consp binding) binding (list binding)))
+ for name = (gensym)
+ collect `(,name ,var) into renames
+ collect ``(,,var ,,name) into temps
+ finally (return `(let* ,renames
+ (with-unique-names ,bindings
+ `(let (,, at temps)
+ ,, at body))))))
+
+(defmacro rebind (bindings &body body)
+ `(let ,(loop
+ for symbol-name in bindings
+ collect (list symbol-name symbol-name))
+ , at body))
+
+(defmacro with-accessors* (accessor-names object &body body)
+ "Just like WITH-ACCESSORS, but if the slot-entry is a symbol
+ assume the variable and accessor name are the same."
+ `(with-accessors ,(mapcar (lambda (name)
+ (if (consp name)
+ name
+ `(,name ,name)))
+ accessor-names)
+ ,object
+ , at body))
+
+(defmacro define-constant (name value doc-string &optional export-p)
+ "DEFCONSTANT with extra EXPORT-P argument."
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ ,(when export-p
+ `(export ',name ,(package-name (symbol-package name))))
+ (defconstant ,name ,value ,doc-string)))
+
+
+(defun register (environment type name datum &rest other-datum)
+ (cons (if other-datum
+ (list* type name datum other-datum)
+ (list* type name datum))
+ environment))
+
+(defmacro extend (environment type name datum &rest other-datum)
+ `(setf ,environment (register ,environment ,type ,name ,datum , at other-datum)))
+
+(defun lookup (environment type name &key (error-p nil) (default-value nil))
+ (loop
+ for (.type .name . data) in environment
+ when (and (eql .type type) (eql .name name))
+ return (values data t)
+ finally
+ (if error-p
+ (error "Sorry, No value for ~S of type ~S in environment ~S found."
+ name type environment)
+ (values default-value nil))))
+
+(defun (setf lookup) (value environment type name &key (error-p nil))
+ (loop
+ for env-piece in environment
+ when (and (eql (first env-piece) type)
+ (eql (second env-piece) name))
+ do (setf (cddr env-piece) value) and
+ return value
+ finally
+ (when error-p
+ (error "Sorry, No value for ~S of type ~S in environment ~S found."
+ name type environment))))
+
+(defun remove-keywords (plist &rest keywords)
+ "Creates a copy of PLIST without the listed KEYWORDS."
+ (declare (optimize (speed 3)))
+ (loop for cell = plist :then (cddr cell)
+ for el = (car cell)
+ while cell
+ unless (member el keywords :test #'eq)
+ collect el
+ and collect (cadr cell)
+ and do (assert (cdr cell) () "Not a proper plist")))
+
+(define-modify-macro remf-keywords (&rest keywords) remove-keywords
+ "Creates a copy of PLIST without the properties identified by KEYWORDS.")
+
+(defmacro eval-always (&body body)
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ , at body))
+
+(defmacro defalias (function redefinition)
+ `(eval-always
+ (progn
+ (setf (fdefinition ',redefinition) (function ,function))
+ ',redefinition)))
+
+(defmacro defvaralias (variable redefinition)
+ `(eval-always
+ (defvar ,redefinition ,variable)))
+
+(defmacro defmacalias (macro redefinition)
+ #-allegro
+ (with-unique-names (args)
+ `(eval-always
+ (defmacro ,redefinition (&rest ,args)
+ `(,',macro ,@,args))))
+ #+allegro ;; with-unique-names is undefined in allegro, why? This is a quick fix.
+ (let ((args (gensym)))
+ `(eval-always
+ (defmacro ,redefinition (&rest ,args)
+ `(,',macro ,@,args)))))
+
+
+(defmacalias lambda fun)
+
+(defalias make-instance new)
+
+(defun append1 (list x)
+ (append list (list x)))
+
+(defun last1 (l)
+ (car (last l)))
+
+(defun flatten1 (l)
+ (reduce #'append l))
+
+(defun singlep (list)
+ (and (consp list) (not (cdr list))))
+
+(defun class-name-of (obj)
+ (class-name (class-of obj)))
+
+(defun circularize (&rest items)
+ (let ((items (copy-list items)))
+ (nconc items items)))
+
+(defmacro let1 (var val &body body)
+ `(let ((,var ,val))
+ , at body))
+
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; Copyright (c) 2006, Hoan Ton-That
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;; - Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;;
+;; - Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;;
+;; - Neither the name of Edward Marco Baringer, Hoan Ton-That, nor
+;; BESE, nor the names of its contributors may be used to endorse
+;; or promote products derived from this software without specific
+;; prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Added: branches/trunk-reorg/thirdparty/arnesi/src/packages.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/packages.lisp Mon Feb 11 08:38:43 2008
@@ -0,0 +1,496 @@
+;; -*- lisp -*-
+
+(in-package :common-lisp-user)
+
+;;;; * Introduction
+
+;;;; It is a collection of lots of small bits and pieces which have
+;;;; proven themselves usefull in various applications. They are all
+;;;; tested, some even have a test suite and a few are even
+;;;; documentated.
+
+(defpackage :it.bese.arnesi
+ (:documentation "The arnesi utility suite.")
+ (:nicknames :arnesi)
+ (:use :common-lisp)
+ (:export
+
+ #:clean-op
+ #:collect-timing
+
+ #:make-reducer
+ #:make-pusher
+ #:make-collector
+ #:with-reducer
+ #:with-collector
+ #:with-collectors
+
+ #:form
+ #:walk-form
+ #:make-walk-env
+ #:*walk-handlers*
+ #:*warn-undefined*
+ #:undefined-reference
+ #:undefined-variable-reference
+ #:undefined-function-reference
+ #:return-from-unknown-block
+ #:defwalker-handler
+ #:implicit-progn-mixin
+ #:implicit-progn-with-declare-mixin
+ #:binding-form-mixin
+ #:declaration-form
+ #:constant-form
+ #:variable-reference
+ #:local-variable-reference
+ #:local-lexical-variable-reference
+ #:free-variable-reference
+ #:application-form
+ #:local-application-form
+ #:lexical-application-form
+ #:free-application-form
+ #:lambda-application-form
+ #:function-form
+ #:lambda-function-form
+ #:function-object-form
+ #:local-function-object-form
+ #:free-function-object-form
+ #:lexical-function-object-form
+ #:function-argument-form
+ #:required-function-argument-form
+ #:specialized-function-argument-form
+ #:optional-function-argument-form
+ #:keyword-function-argument-form
+ #:allow-other-keys-function-argument-form
+ #:rest-function-argument-form
+ #:block-form
+ #:return-from-form
+ #:catch-form
+ #:throw-form
+ #:eval-when-form
+ #:if-form
+ #:function-binding-form
+ #:flet-form
+ #:labels-form
+ #:variable-binding-form
+ #:let-form
+ #:let*-form
+ #:locally-form
+ #:macrolet-form
+ #:multiple-value-call-form
+ #:multiple-value-prog1-form
+ #:progn-form
+ #:progv-form
+ #:setq-form
+ #:symbol-macrolet-form
+ #:tagbody-form
+ #:go-tag-form
+ #:go-form
+ #:the-form
+ #:unwind-protect-form
+ #:extract-argument-names
+ #:walk-lambda-list
+ #:walk-implict-progn
+ #:arguments
+ #:binds
+ #:body
+ #:cleanup-form
+ #:code
+ #:consequent
+ #:declares
+ #:default-value
+;; #:else ; iterate
+ #:enclosing-tagbody
+ #:eval-when-times
+ #:first-form
+ #:func
+ #:keyword-name
+ #:name
+ #:operator
+ #:optimize-spec
+ #:other-forms
+ #:parent
+ #:protected-form
+ #:read-only-p
+ #:result
+ #:source
+;; #:specializer ; closer-mop
+ #:supplied-p-parameter
+ #:tag
+ #:target-block
+ #:target-progn
+ #:then
+ #:type-form
+ #:value
+ #:values-form
+ #:var
+ #:vars-form
+
+ #:defunwalker-handler
+ #:unwalk-form
+ #:unwalk-forms
+ #:unwalk-lambda-list
+
+ #:to-cps
+ #:with-call/cc
+ #:kall
+ #:call/cc
+ #:let/cc
+ #:*call/cc-returns*
+ #:invalid-return-from
+ #:unreachable-code
+ #:defun/cc
+ #:defgeneric/cc
+ #:defmethod/cc
+ #:fmakun-cc
+ #:*debug-evaluate/cc*
+ #:*trace-cc*
+
+ #:ppm
+ #:ppm1
+ #:apropos-list*
+ #:apropos*
+
+ #:with-input-from-file
+ #:with-output-to-file
+ #:read-string-from-file
+ #:write-string-to-file
+ #:copy-file
+ #:copy-stream
+ #:string-to-octets
+ #:octets-to-string
+ #:encoding-keyword-to-native
+ #:defprint-object
+
+ #:if-bind
+ #:aif
+ #:when-bind
+ #:awhen
+ #:cond-bind
+ #:acond
+ #:aand
+ #:and-bind
+ #:if2-bind
+ #:aif2
+;; #:while ; iterate
+ #:awhile
+;; #:until ; iterate
+ #:it
+ #:whichever
+ #:xor
+ #:switch
+ #:eswitch
+ #:cswitch
+
+ #:build-hash-table
+ #:deflookup-table
+ #:hash-to-alist
+ #:hash-table-keys
+ #:hash-table-values
+
+ #:write-as-uri
+ #:escape-as-uri
+ #:unescape-as-uri
+ #:nunescape-as-uri
+ #:unescape-as-uri-non-strict
+ #:uri-parse-error
+ #:expected-digit-uri-parse-error
+ #:continue-as-is
+
+ #:write-as-html
+ #:escape-as-html
+ #:unescape-as-html
+ #:html-entity->char
+
+ #:compose
+ #:conjoin
+ #:curry
+ #:rcurry
+ #:noop
+ #:y
+ #:lambda-rec
+
+ #:dolist*
+ #:dotree
+ #:ensure-list
+ #:ensure-cons
+ #:partition
+ #:partitionx
+ #:proper-list-p
+ #:push*
+
+ #:get-logger
+ #:log-category
+ #:stream-log-appender
+ #:brief-stream-log-appender
+ #:verbose-stream-log-appender
+ #:make-stream-log-appender
+ #:make-slime-repl-log-appender
+ #:file-log-appender
+ #:make-file-log-appender
+ #:deflogger
+ #:with-logger-level
+ #:log.level
+ #:log.compile-time-level
+ #:+dribble+
+ #:+debug+
+ #:+info+
+ #:+warn+
+ #:+error+
+ #:+fatal+
+ #:handle
+ #:append-message
+ #:ancestors
+ #:appenders
+ #:children
+
+ #:with-unique-names
+ #:rebinding
+ #:rebind
+ #:define-constant
+ #:remove-keywords
+ #:remf-keywords
+
+ #:make-matcher
+ #:match
+ #:match-case
+ #:list-match-case
+
+ #:parse-ieee-double
+ #:parse-float
+ #:mulf
+ #:divf
+ #:minf
+ #:maxf
+ #:map-range
+ #:do-range
+ #:10^
+
+ #:tail
+ #:but-tail
+ #:head
+ #:but-head
+ #:starts-with
+ #:ends-with
+ #:read-sequence*
+ #:deletef
+ #:copy-array
+ #:make-displaced-array
+
+ #:+lower-case-ascii-alphabet+
+ #:+upper-case-ascii-alphabet+
+ #:+ascii-alphabet+
+ #:+alphanumeric-ascii-alphabet+
+ #:+base64-alphabet+
+ #:random-string
+ #:strcat
+ #:strcat*
+ #:princ-csv
+ #:parse-csv-string
+ #:join-strings
+ #:fold-strings
+ #:~%
+ #:~T
+ #:+CR-LF+
+ #:~D
+ #:~A
+ #:~S
+ #:~W
+
+ #:def-special-environment
+
+ #:intern-concat
+
+ #:vector-push-extend*
+ #:string-from-array
+
+ #:queue
+ #:enqueue
+ #:dequeue
+ #:peek-queue
+ #:queue-empty-p
+ #:queue-count
+ #:random-queue-element
+ #:queue->list
+ #:lru-queue
+
+ ;; decimal arith
+ #:*precision*
+ #:with-precision
+ #:decimal-from-float
+ #:float-from-decimal
+ #:round-down
+ #:round-half-up
+ #:round-half-even
+ #:round-ceiling
+ #:round-floor
+ #:round-half-down
+ #:round-up
+
+ #:enable-sharp-l-syntax
+ #:enable-bracket-syntax
+ #:enable-pf-syntax
+ #:with-sharp-l-syntax
+ #:with-package
+
+ #:defclass-struct
+
+ #:with*
+
+ #:quit
+
+ #:wrapping-standard
+
+ #:levenshtein-distance
+
+ #:getenv
+
+
+ #:lisp1
+ #:with-lisp1
+ #:defun1
+ #:defmethod1
+
+ #:_
+
+ #:eval-always
+ #:defalias
+ #:defvaralias
+ #:defmacalias
+ #:fun
+ #:set
+ #:new
+ #:append1
+ #:last1
+ #:singlep
+ #:class-name-of
+ #:circularize
+ #:let1
+
+ ;; Obsolete stuff for backward compatibility. To be removed eventually.
+ #:enable-sharp-l
+ #:enable-bracket-reader
+ #:enable-pf-reader
+ ))
+
+;;;; * Colophon
+
+;;;; This documentation was produced by qbook.
+
+;;;; arnesi, and the associated documentation, is written by Edward
+;;;; Marco Baringer <mb at bese.it>.
+
+;;;; ** COPYRIGHT
+
+;;;; Copyright (c) 2002-2006, Edward Marco Baringer
+;;;; Copyright (c) 2006 Luca Capello http://luca.pca.it <luca at pca.it>
+;;;; All rights reserved.
+
+;;;; Redistribution and use in source and binary forms, with or without
+;;;; modification, are permitted provided that the following conditions are
+;;;; met:
+
+;;;; - Redistributions of source code must retain the above copyright
+;;;; notice, this list of conditions and the following disclaimer.
+
+;;;; - Redistributions in binary form must reproduce the above copyright
+;;;; notice, this list of conditions and the following disclaimer in the
+;;;; documentation and/or other materials provided with the distribution.
+
+;;;; - Neither the name of Edward Marco Baringer, Luca Capello, nor
+;;;; BESE, nor the names of its contributors may be used to endorse
+;;;; or promote products derived from this software without specific
+;;;; prior written permission.
+
+;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+;;;;@include "accumulation.lisp"
+
+;;;;@include "asdf.lisp"
+
+;;;;@include "compat.lisp"
+
+;;;; / @include "cps.lisp"
+
+;;;;@include "csv.lisp"
+
+;;;;@include "debug.lisp"
+
+;;;;@include "decimal-arithmetic.lisp"
+
+;;;;@include "defclass-struct.lisp"
+
+;;;;@include "flow-control.lisp"
+
+;;;;@include "hash.lisp"
+
+;;;;@include "http.lisp"
+
+;;;;@include "io.lisp"
+
+;;;;@include "lambda.lisp"
+
+;;;;@include "list.lisp"
+
+;;;;@include "log.lisp"
+
+;;;;@include "matcher.lisp"
+
+;;;;@include "mop.lisp"
+
+;;;;@include "mopp.lisp"
+
+;;;;@include "numbers.lisp"
+
+;;;;@include "one-liners.lisp"
+
+;;;;@include "sequence.lisp"
+
+;;;;@include "sharpl-reader.lisp"
+
+;;;;@include "specials.lisp"
+
+;;;;@include "string.lisp"
+
+;;;;@include "walk.lisp"
+
+;;;;@include "vector.lisp"
+
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;; - Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;;
+;; - Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;;
+;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;; of its contributors may be used to endorse or promote products
+;; derived from this software without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Added: branches/trunk-reorg/thirdparty/arnesi/src/pf-reader.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/pf-reader.lisp Mon Feb 11 08:38:43 2008
@@ -0,0 +1,74 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * A partial application syntax
+
+;;;; Reader
+(defmacro enable-pf-syntax (&optional (open-character #\[) (close-character #\]))
+ "Enable bracket reader for the rest of the file (being loaded or compiled).
+Be careful when using in different situations, because it modifies *readtable*."
+ ;; The standard sais that *readtable* is restored after loading/compiling a file,
+ ;; so we make a copy and alter that. The effect is that it will be enabled
+ ;; for the rest of the file being processed.
+ `(eval-when (:compile-toplevel :execute)
+ (setf *readtable* (copy-readtable *readtable*))
+ (%enable-pf-reader ,open-character ,close-character)))
+
+(defun %enable-pf-reader (&optional (open-character #\[) (close-character #\]))
+ (set-macro-character open-character #'|[-reader| t *readtable*)
+ (set-syntax-from-char close-character #\) *readtable*))
+
+(defun enable-pf-reader ()
+ "TODO Obsolete, to be removed. Use the enable-pf-syntax macro."
+ ;; (warn "Use the enable-pf-syntax macro instead of enable-pf-reader")
+ (%enable-pf-reader))
+
+(defun |[-reader| (stream char)
+ (declare (ignore char))
+ (destructuring-bind (fname &rest args)
+ (read-delimited-list #\] stream t)
+ (let* ((rest (gensym "REST"))
+ (count (count '_ args))
+ (end (if (zerop count) rest `(nthcdr ,count ,rest)))
+ (args (reduce (lambda (x y)
+ (cons (if (eq x '_)
+ `(nth ,(decf count) ,rest)
+ x)
+ y))
+ args
+ :from-end t
+ :initial-value '())))
+ `(lambda (&rest ,rest) (apply #',fname , at args ,end)))))
+
+;;;; http://groups.google.com/group/comp.lang.lisp/browse_thread/thread/1a86740db77b2f3a
+
+;; Copyright (c) 2006, Hoan Ton-That
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;; - Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;;
+;; - Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;;
+;; - Neither the name of Hoan Ton-That, nor the names of the
+;; contributors may be used to endorse or promote products derived
+;; from this software without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Added: branches/trunk-reorg/thirdparty/arnesi/src/posixenv.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/posixenv.lisp Mon Feb 11 08:38:43 2008
@@ -0,0 +1,50 @@
+;;; -*- lisp -*-
+
+
+(in-package :it.bese.arnesi)
+
+;;;; * POSIX environment functions
+
+(defun getenv (var)
+ #+allegro (sys:getenv var)
+ #+clisp (ext:getenv var)
+ #+cmu
+ (cdr (assoc var ext:*environment-list* :test #'string=))
+ #+lispworks (lw:environment-variable var)
+ #+openmcl (ccl::getenv var)
+ #+sbcl (sb-ext:posix-getenv var)
+
+ #-(or allegro clisp cmu lispworks openmcl openmcl sbcl)
+ (error "Could not define `getenv'."))
+
+
+;; Copyright (c) 2006 Luca Capello http://luca.pca.it <luca at pca.it>
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;; - Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;;
+;; - Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;;
+;; - Neither the name of Luca Capello, Edward Marco Baringer, nor
+;; BESE, nor the names of its contributors may be used to endorse
+;; or promote products derived from this software without specific
+;; prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Added: branches/trunk-reorg/thirdparty/arnesi/src/queue.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/queue.lisp Mon Feb 11 08:38:43 2008
@@ -0,0 +1,164 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * Queues (FIFO)
+
+;;;; The class QUEUE represents a simple, circular buffer based, FIFO
+;;;; implementation. The two core operations are enqueue and dequeue,
+;;;; the utility method queue-count is also provided.
+
+(defclass queue ()
+ ((head-index :accessor head-index)
+ (tail-index :accessor tail-index)
+ (buffer :accessor buffer)))
+
+(defmethod initialize-instance :after
+ ((queue queue)
+ &key
+ (size 20)
+ (element-type t)
+ &allow-other-keys)
+ (assert (< 1 size)
+ (size)
+ "Initial size of a queue must be greater than 1.")
+ (setf (head-index queue) 0
+ (tail-index queue) 0
+ (buffer queue) (make-array (1+ size) :element-type element-type)))
+
+(defmethod enqueue ((queue queue) value)
+ (when (queue-full-p queue)
+ (grow-queue queue))
+ (setf (aref (buffer queue) (head-index queue)) value)
+ (move-head queue)
+ queue)
+
+(defmethod dequeue ((queue queue) &optional (default-value nil))
+ (if (queue-empty-p queue)
+ default-value
+ (prog1
+ (aref (buffer queue) (tail-index queue))
+ (move-tail queue))))
+
+(defmethod peek-queue ((queue queue))
+ (aref (buffer queue) (tail-index queue)))
+
+(defmethod queue-empty-p ((queue queue))
+ (= (head-index queue) (tail-index queue)))
+
+(defmethod queue-full-p ((queue queue))
+ (= (mod (tail-index queue) (length (buffer queue)))
+ (mod (1+ (head-index queue)) (length (buffer queue)))))
+
+(defmethod queue-count ((queue queue))
+ (let ((head-index (head-index queue))
+ (tail-index (tail-index queue)))
+ (cond
+ ((= head-index tail-index)
+ 0)
+ ((< tail-index head-index)
+ (- head-index tail-index))
+ ((> tail-index head-index)
+ (- (+ (length (buffer queue)) head-index)
+ tail-index)))))
+
+(defmethod random-queue-element ((queue queue))
+ (let ((tail-index (tail-index queue))
+ (buffer (buffer queue))
+ (count (queue-count queue)))
+ (when (zerop count)
+ (error "Queue ~A is empty" queue))
+ (aref buffer (mod (+ tail-index (random count))
+ (length buffer)))))
+
+(defmethod call-for-all-elements-with-index ((queue queue) callback)
+ "Calls CALLBACK passing it each element in QUEUE. The elements
+will be called in the same order thah DEQUEUE would return them."
+ (flet ((callback (index)
+ (funcall callback (aref (buffer queue) index) index)))
+ (if (< (head-index queue) (tail-index queue))
+ ;; growing from the bottom. conceptualy the new elements need
+ ;; to go between tail and head. it's simpler to just move them
+ ;; all
+ (progn
+ (loop
+ for index upfrom (tail-index queue) below (length (buffer queue))
+ do (callback index))
+ (loop
+ for index upfrom 0 below (head-index queue)
+ do (callback index)))
+ ;; growing from the top
+ (loop
+ for index from (tail-index queue) below (head-index queue)
+ do (callback index)))))
+
+(defmacro do-all-elements ((element queue &optional index) &body body)
+ (if index
+ `(call-for-all-elements-with-index ,queue
+ (lambda (,element ,index)
+ , at body))
+ (let ((index (gensym "do-all-elements-index-")))
+ `(call-for-all-elements-with-index ,queue
+ (lambda (,element ,index)
+ (declare (ignore ,index))
+ , at body)))))
+
+(defmethod grow-queue ((queue queue))
+ (let ((new-buffer (make-array (* (length (buffer queue)) 2)
+ :element-type (array-element-type (buffer queue)))))
+ (let ((index 0))
+ (do-all-elements (element queue)
+ (setf (aref new-buffer index) element)
+ (incf index))
+ (setf (head-index queue) index
+ (tail-index queue) 0
+ (buffer queue) new-buffer))
+ queue))
+
+(defmacro incf-mod (place divisor)
+ `(setf ,place (mod (1+ ,place) ,divisor)))
+
+(defmethod move-tail ((queue queue))
+ (incf-mod (tail-index queue) (length (buffer queue))))
+
+(defmethod move-head ((queue queue))
+ (incf-mod (head-index queue) (length (buffer queue))))
+
+(defmethod print-object ((queue queue) stream)
+ (print-unreadable-object (queue stream :type t :identity t)
+ (format stream "~D" (queue-count queue))))
+
+(defmethod queue->list ((queue queue))
+ (let ((res nil))
+ (do-all-elements (element queue)
+ (push element res))
+ (nreverse res)))
+
+;;;; ** LRU Queue
+
+(defclass lru-queue (queue)
+ ()
+ (:documentation "A queue which never grows. When an element is
+ enqueued and the buffer is full we simply drop the last
+ element."))
+
+(defmethod enqueue ((queue lru-queue) value)
+ (when (queue-full-p queue)
+ (dequeue queue))
+ (call-next-method queue value))
+
+(defmethod enqueue-or-move-to-front ((queue lru-queue) element &key (test #'eql) (key #'identity))
+ "Enqueues ELEMENT, if ELEMENT is already in the queue it is
+ moved to the head.
+
+NB: this method needs a better name."
+ (do-all-elements (e queue index)
+ (when (funcall test element (funcall key e))
+ ;; found the element
+ (rotatef (aref (buffer queue) index)
+ (aref (buffer queue) (1- (if (zerop (head-index queue))
+ (length (buffer queue))
+ (head-index queue)))))
+ (return-from enqueue-or-move-to-front queue)))
+ ;; if we get here the element wasn't found
+ (enqueue queue element))
Added: branches/trunk-reorg/thirdparty/arnesi/src/sequence.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/sequence.lisp Mon Feb 11 08:38:43 2008
@@ -0,0 +1,221 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * Manipulating sequences
+
+(defun tail (seq &optional (how-many 1))
+ "Returns the last HOW-MANY elements of the sequence SEQ. HOW-MANY is
+ greater than (length SEQ) then all of SEQ is returned."
+ (let ((seq-length (length seq)))
+ (cond
+ ((<= 0 how-many seq-length)
+ (subseq seq (- seq-length how-many)))
+ ((< seq-length how-many)
+ (copy-seq seq))
+ (t ; (< how-many 0)
+ (head seq (- how-many))))))
+
+(defun but-tail (seq &optional (how-many 1))
+ "Returns SEQ with the last HOW-MANY elements removed."
+ (let ((seq-length (length seq)))
+ (cond
+ ((<= 0 how-many seq-length)
+ (subseq seq 0 (- seq-length how-many)))
+ ((< seq-length how-many)
+ (copy-seq seq))
+ (t
+ (but-head seq (- how-many))))))
+
+(defun head (seq &optional (how-many 1))
+ "Returns the first HOW-MANY elements of SEQ."
+ (let ((seq-length (length seq)))
+ (cond
+ ((<= 0 how-many seq-length)
+ (subseq seq 0 how-many))
+ ((< seq-length how-many)
+ (copy-seq seq))
+ (t
+ (tail seq (- how-many))))))
+
+(defun but-head (seq &optional (how-many 1))
+ "Returns SEQ with the first HOW-MANY elements removed."
+ (let ((seq-length (length seq)))
+ (cond ((<= 0 how-many (length seq))
+ (subseq seq how-many))
+ ((< seq-length how-many)
+ (copy-seq seq))
+ (t
+ (but-tail seq (- how-many))))))
+
+(defun starts-with (sequence prefix &key (test #'eql) (return-suffix nil))
+ "Test whether the first elements of SEQUENCE are the same (as
+ per TEST) as the elements of PREFIX.
+
+If RETURN-SUFFIX is T the functions returns, as a second value, a
+displaced array pointing to the sequence after PREFIX."
+ (let ((length1 (length sequence))
+ (length2 (length prefix)))
+ (when (< length1 length2)
+ (return-from starts-with (values nil nil)))
+ (dotimes (index length2)
+ (when (not (funcall test (elt sequence index) (elt prefix index)))
+ (return-from starts-with (values nil nil))))
+ ;; if we get here then we match
+ (values t
+ (if return-suffix
+ (make-array (- (length sequence) (length prefix))
+ :element-type (array-element-type sequence)
+ :displaced-to sequence
+ :displaced-index-offset (length prefix)
+ :adjustable nil)
+ nil))))
+
+(defun ends-with (seq1 seq2 &key (test #'eql))
+ "Test whether SEQ1 ends with SEQ2. In other words: return true if
+ the last (length seq2) elements of seq1 are equal to seq2."
+ (let ((length1 (length seq1))
+ (length2 (length seq2)))
+ (when (< length1 length2)
+ ;; if seq1 is shorter than seq2 than seq1 can't end with seq2.
+ (return-from ends-with nil))
+ (loop
+ for seq1-index from (- length1 length2) below length1
+ for seq2-index from 0 below length2
+ when (not (funcall test (elt seq1 seq1-index) (elt seq2 seq2-index)))
+ do (return-from ends-with nil)
+ finally (return t))))
+
+(defun read-sequence* (sequence stream &key (start 0) end)
+ "Like READ-SEQUENCE except the sequence is returned as well.
+
+The second value returned is READ-SEQUENCE's primary value, the
+primary value returned by READ-SEQUENCE* is the medified
+sequence."
+ (let ((pos (read-sequence sequence stream :start start :end end)))
+ (values sequence pos)))
+
+(defmacro deletef
+ (item sequence &rest delete-args
+ &environment e)
+ "Delete ITEM from SEQUENCE, using cl:delete, and update SEQUENCE.
+
+DELETE-ARGS are passed directly to cl:delete."
+ (multiple-value-bind (vars vals store-vars writer-form reader-form)
+ (get-setf-expansion sequence e)
+ `(let* (,@(mapcar #'list vars vals)
+ (,(car store-vars) ,reader-form))
+ (setq ,(car store-vars) (delete ,item ,(car store-vars)
+ , at delete-args))
+ ,writer-form)))
+
+
+(defun copy-array (array)
+ "Returns a fresh copy of ARRAY. The returned array will have
+ the same dimensions and element-type, will not be displaced and
+ will have the same fill-pointer as ARRAY.
+
+See http://thread.gmane.org/gmane.lisp.allegro/13 for the
+original implementation and discussion."
+ (let ((dims (array-dimensions array))
+ (fill-pointer (and (array-has-fill-pointer-p array)
+ (fill-pointer array))))
+ (adjust-array
+ (make-array dims :displaced-to array)
+ dims
+ :fill-pointer fill-pointer)))
+
+(defun make-displaced-array (array &optional (start 0) (end (length array)))
+ (make-array (- end start)
+ :element-type (array-element-type array)
+ :displaced-to array
+ :displaced-index-offset start))
+
+;;;; ** Levenshtein Distance
+
+;;;; 1) Set n to be the length of s. Set m to be the length of t. If n
+;;;; = 0, return m and exit. If m = 0, return n and exit. Construct
+;;;; a matrix containing 0..m rows and 0..n columns.
+
+;;;; 2) Initialize the first row to 0..n. Initialize the first column
+;;;; to 0..m.
+
+;;;; 3) Examine each character of s (i from 1 to n).
+
+;;;; 4) Examine each character of t (j from 1 to m).
+
+;;;; 5) If s[i] equals t[j], the cost is 0. If s[i] doesn't equal
+;;;; t[j], the cost is 1.
+
+;;;; 6) Set cell d[i,j] of the matrix equal to the minimum of: a. The
+;;;; cell immediately above plus 1: d[i-1,j] + 1. b. The cell
+;;;; immediately to the left plus 1: d[i,j-1] + 1. c. The cell
+;;;; diagonally above and to the left plus the cost: d[i-1,j-1] +
+;;;; cost.
+
+;;;; 7) After the iteration steps (3, 4, 5, 6) are complete, the
+;;;; distance is found in cell d[n,m].
+
+(defun levenshtein-distance (source target &key (test #'eql))
+ (block nil
+ (let ((source-length (length source))
+ (target-length (length target)))
+ (when (zerop source-length)
+ (return target-length))
+ (when (zerop target-length)
+ (return source-length))
+ (let ((buffer (make-array (1+ target-length))))
+ (dotimes (i (1+ target-length))
+ (setf (aref buffer i) i))
+ ;; we make a slight modification to the alogrithm described
+ ;; above. we don't create the entire array, just enough to
+ ;; keep the info we need, which is an array of size
+ ;; target-length + the "above" value and the "over". (this is
+ ;; similar to the optimizaiont for determining lcs).
+ (loop
+ for i from 1 upto source-length
+ do (setf (aref buffer 0) i)
+ do (loop
+ with above-value = i
+ with over-value = (1- i)
+ for j from 1 upto target-length
+ for cost = (if (funcall test (elt source (1- i))
+ (elt target (1- j)))
+ 0 1)
+ do (let ((over-value* (aref buffer j)))
+ (setf (aref buffer j) (min (1+ above-value)
+ (1+ (aref buffer j))
+ (+ cost over-value))
+ above-value (aref buffer j)
+ over-value over-value*))))
+ (return (aref buffer target-length))))))
+
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;; - Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;;
+;; - Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;;
+;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;; of its contributors may be used to endorse or promote products
+;; derived from this software without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Added: branches/trunk-reorg/thirdparty/arnesi/src/sharpl-reader.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/sharpl-reader.lisp Mon Feb 11 08:38:43 2008
@@ -0,0 +1,173 @@
+;; -*- lisp -*-
+
+(in-package :arnesi)
+
+;;;; * A reader macro for simple lambdas
+
+;;;; Often we have to create small (in the sense of textually short)
+;;;; lambdas. This read macro, bound to #L by default, allows us to
+;;;; eliminate the 'boilerplate' LAMBDA and concentrate on the body of
+;;;; the lambda.
+
+(defmacro sharpl-expander (package body min-args &environment env)
+ (let* ((form body)
+ (lambda-args (loop
+ for i upfrom 1 upto (max (or min-args 0)
+ (highest-bang-var form env))
+ collect (make-sharpl-arg package i))))
+ `(lambda ,lambda-args
+ , (when lambda-args
+ `(declare (ignorable , at lambda-args)))
+ ,form)))
+
+(defun sharpL-reader (stream subchar min-args)
+ "Reader macro for simple lambdas.
+
+This read macro reads exactly one form and serves to eliminate
+the 'boiler' plate text from such lambdas and write only the body
+of the lambda itself. If the form contains any references to
+variables named !1, !2, !3, !n etc. these are bound to the Nth
+parameter of the lambda.
+
+Examples:
+
+#L(foo) ==> (lambda () (foo)).
+
+#L(foo !1) ==> (lambda (!1) (foo !1))
+
+#L(foo (bar !2) !1) ==> (lambda (!1 !2) (foo (bar !2) !1))
+
+All arguments are declared ignorable. So if there is a reference
+to an argument !X but not !(x-1) we still take X arguments, but x
+- 1 is ignored. Examples:
+
+#L(foo !2) ==> (lambda (!1 !2) (declare (ignore !1)) (foo !2))
+
+We can specify exactly how many arguments to take by using the
+read macro's prefix parameter. NB: this is only neccessary if the
+lambda needs to accept N arguments but only uses N - 1. Example:
+
+#2L(foo !1) ==> (lambda (!1 !2) (declare (ignore !2)) (foo !1))
+
+When #l forms are nested, !X variables are bound to the innermost
+form. Example:
+
+#l#l(+ !1 !2)
+
+returns a function that takes no arguments and returns a function
+that adds its two arguments."
+ (declare (ignore subchar))
+ (let ((body (read stream t nil t)))
+ `(sharpl-expander ,*package* ,body ,min-args)))
+
+(defun with-sharp-l-syntax ()
+ "To be used with the curly reader from arnesi: {with-sharp-l-syntax #L(typep !1 'foo)}"
+ (lambda (handler)
+ (%enable-sharp-l-reader)
+ `(progn ,@(funcall handler))))
+
+(defmacro enable-sharp-l-syntax ()
+ ;; The standard sais that *readtable* is restored after loading/compiling a file,
+ ;; so we make a copy and alter that. The effect is that it will be enabled
+ ;; for the rest of the file being processed.
+ `(eval-when (:compile-toplevel :execute)
+ (setf *readtable* (copy-readtable *readtable*))
+ (%enable-sharp-l-reader)))
+
+(defun %enable-sharp-l-reader ()
+ "Bind SHARPL-READER to the macro character #L.
+
+This function overrides (and forgets) and previous value of #L."
+ (set-dispatch-macro-character #\# #\L 'sharpL-reader))
+
+(defun enable-sharp-l ()
+ "TODO: Obsolete, to be removed. Use the enable-sharp-l-syntax macro."
+ ;; (warn "Use the enable-sharp-l-syntax macro instead of enable-sharp-l")
+ (%enable-sharp-l-reader))
+
+(defun find-var-references (input-form)
+ (typecase input-form
+ (cons
+ (append (find-var-references (car input-form))
+ (find-var-references (cdr input-form))))
+
+ (free-variable-reference (list (slot-value input-form 'name)))
+ (local-lexical-variable-reference (list (slot-value input-form 'name)))
+
+ (form
+ (loop for slot-name in (mapcar #'mopp:slot-definition-name
+ (mopp::class-slots (class-of input-form)))
+ if (not (member slot-name '(parent target-progn enclosing-tagbody target-block)))
+ append (find-var-references (slot-value input-form slot-name))))
+
+ (t nil)))
+
+(defun highest-bang-var (form env)
+ (let ((*warn-undefined* nil))
+ (or
+ (loop for var in (find-var-references (walk-form form nil (make-walk-env env)))
+ if (bang-var-p var)
+ maximize (bang-var-p var))
+ 0)))
+
+(defun bang-var-p (form)
+ (and (char= #\! (aref (symbol-name form) 0))
+ (parse-integer (subseq (symbol-name form) 1) :junk-allowed t)))
+
+(defun make-sharpl-arg (package number)
+ (intern (format nil "!~D" number) package))
+
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;; - Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;;
+;; - Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;;
+;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;; of its contributors may be used to endorse or promote products
+;; derived from this software without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+;; This code was heavily inspired by iterate, which has the following
+;; copyright:
+
+;; ITERATE, An Iteration Macro
+;;
+;; Copyright 1989 by Jonathan Amsterdam
+;; Adapted to ANSI Common Lisp in 2003 by Andreas Fuchs
+;;
+;; Permission to use, copy, modify, and distribute this software and its
+;; documentation for any purpose and without fee is hereby granted,
+;; provided that this copyright and permission notice appear in all
+;; copies and supporting documentation, and that the name of M.I.T. not
+;; be used in advertising or publicity pertaining to distribution of the
+;; software without specific, written prior permission. M.I.T. makes no
+;; representations about the suitability of this software for any
+;; purpose. It is provided "as is" without express or implied warranty.
+
+;; M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
+;; ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL
+;; M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
+;; ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+;; WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
+;; ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
+;; SOFTWARE.
Added: branches/trunk-reorg/thirdparty/arnesi/src/specials.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/specials.lisp Mon Feb 11 08:38:43 2008
@@ -0,0 +1,81 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * def-special-environment
+
+(defun check-required (name vars required)
+ (dolist (var required)
+ (assert (member var vars)
+ (var)
+ "Unrecognized symbol ~S in ~S." var name)))
+
+(defmacro def-special-environment (name (&key accessor binder binder*)
+ &rest vars)
+ "Define two macros for dealing with groups or related special variables.
+
+ACCESSOR is defined as a macro: (defmacro ACCESSOR (VARS &rest
+BODY)). Each element of VARS will be bound to the
+current (dynamic) value of the special variable.
+
+BINDER is defined as a macro for introducing (and binding new)
+special variables. It is basically a readable LET form with the
+prorpe declarations appended to the body. The first argument to
+BINDER must be a form suitable as the first argument to LET.
+
+ACCESSOR defaults to a new symbol in the same package as NAME
+which is the concatenation of \"WITH-\" NAME. BINDER is built as
+\"BIND-\" and BINDER* is BINDER \"*\"."
+ (unless accessor
+ (setf accessor (intern-concat (list '#:with- name) (symbol-package name))))
+ (unless binder
+ (setf binder (intern-concat (list '#:bind- name) (symbol-package name))))
+ (unless binder*
+ (setf binder* (intern-concat (list binder '#:*) (symbol-package binder))))
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (flet ()
+ (defmacro ,binder (requested-vars &body body)
+ (check-required ',name ',vars (mapcar #'car requested-vars))
+ `(let ,requested-vars
+ (declare (special ,@(mapcar #'car requested-vars)))
+ , at body))
+ (defmacro ,binder* (requested-vars &body body)
+ (check-required ',name ',vars (mapcar #'car requested-vars))
+ `(let* ,requested-vars
+ (declare (special ,@(mapcar #'car requested-vars)))
+ , at body))
+ (defmacro ,accessor (requested-vars &body body)
+ (check-required ',name ',vars requested-vars)
+ `(locally (declare (special , at requested-vars))
+ , at body))
+ ',name)))
+
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;; - Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;;
+;; - Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;;
+;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;; of its contributors may be used to endorse or promote products
+;; derived from this software without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Added: branches/trunk-reorg/thirdparty/arnesi/src/string.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/string.lisp Mon Feb 11 08:38:43 2008
@@ -0,0 +1,297 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * Manipulating strings
+
+(defvar +lower-case-ascii-alphabet+
+ "abcdefghijklmnopqrstuvwxyz"
+ "All the lower case letters in 7 bit ASCII.")
+(defvar +upper-case-ascii-alphabet+
+ "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
+ "All the upper case letters in 7 bit ASCII.")
+(defvar +ascii-alphabet+
+ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
+ "All letters in 7 bit ASCII.")
+(defvar +alphanumeric-ascii-alphabet+
+ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"
+ "All the letters and numbers in 7 bit ASCII.")
+(defvar +base64-alphabet+
+ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
+ "All the characters allowed in base64 encoding.")
+
+(defun random-string (&optional (length 32) (alphabet +ascii-alphabet+))
+ "Returns a random alphabetic string.
+
+The returned string will contain LENGTH characters chosen from
+the vector ALPHABET.
+"
+ (loop with id = (make-string length)
+ with alphabet-length = (length alphabet)
+ for i below length
+ do (setf (cl:aref id i)
+ (cl:aref alphabet (random alphabet-length)))
+ finally (return id)))
+
+(declaim (inline strcat))
+(defun strcat (&rest items)
+ "Returns a fresh string consisting of ITEMS concat'd together."
+ (declare (optimize speed))
+ (strcat* items))
+
+(defun strcat* (string-designators)
+ "Concatenate all the strings in STRING-DESIGNATORS."
+ (let ((*print-pretty* nil)
+ (*print-circle* nil))
+ (with-output-to-string (stream)
+ (dotree (str string-designators)
+ (when str
+ (princ str stream))))))
+
+;;; A "faster" version for string concatenating.
+;;; Could use just (apply #'concatenate 'string list), but that's quite slow
+(defun join-strings (list)
+ (let* ((length (reduce #'+ list :key #'length))
+ (result (make-string length)))
+ (loop
+ for string in list
+ for start = 0 then end
+ for end = (+ start (length string))
+ while string
+ do (replace result string :start1 start :end1 end)
+ finally (return result))))
+
+(defun fold-strings (list)
+ (declare (optimize (speed 3) (safety 0) (debug 0)))
+ (let ((strings '())
+ (result '()))
+ (dolist (object list)
+ (typecase object
+ (string (push object strings))
+ (t (when strings
+ (push (join-strings (nreverse strings)) result)
+ (setf strings '()))
+ (push object result))))
+ (when strings
+ (push (join-strings (nreverse strings)) result))
+ (nreverse result)))
+
+(defvar ~%
+ (format nil "~%")
+ "A string containing a single newline")
+(defvar ~T
+ (string #\Tab)
+ "A string containing a single tab character.")
+(defvar +CR-LF+
+ (make-array 2 :element-type 'character
+ :initial-contents (list (code-char #x0D)
+ (code-char #x0A)))
+ "A string containing the two characters CR and LF.")
+
+(defun ~D (number &optional stream &key mincol pad-char)
+ (format stream "~v,vD" mincol pad-char number))
+
+(defun ~A (object &optional stream)
+ (format stream "~A" object))
+
+(defun ~S (object &optional stream)
+ (format stream "~S" object))
+
+(defun ~W (object &optional stream)
+ (format stream "~W" object))
+
+;;;; ** Converting strings to/from foreign encodings
+
+;;;; *** CLISP
+
+#+(and clisp unicode)
+(progn
+ (defun %encoding-keyword-to-native (encoding)
+ (ext:make-encoding
+ :charset (case encoding
+ (:utf-8 charset:utf-8)
+ (:utf-16 charset:utf-16)
+ (:us-ascii charset:ascii)
+ (t (multiple-value-bind (symbol status)
+ (find-symbol (string encoding) (find-package :charset))
+ (if (eq status :external)
+ (symbol-value symbol)
+ ;; otherwise, if SYSTEM::*HTTP-ENCODING*
+ ;; is available, then use it
+ #+#.(cl:if (cl:and (cl:find-package "SYSTEM")
+ (cl:find-symbol "*HTTP-ENCODING*"
+ (cl:find-package "SYSTEM")))
+ '(and) '(or))
+ SYSTEM::*HTTP-ENCODING*
+ ;; otherwise, use EXT:*MISC-ENCODING*
+ #+#.(cl:if (cl:and (cl:find-package "SYSTEM")
+ (cl:find-symbol "*HTTP-ENCODING*"
+ (cl:find-package "SYSTEM")))
+ '(or) '(and))
+ EXT:*MISC-ENCODING*))))
+ ;; These native encodings will be used for the HTTP protocol,
+ ;; therefore we set the line-terminator to MS-DOS.
+ ;; Of course, it would be better if this was explicitely requested...
+ :line-terminator :dos
+ :input-error-action #\uFFFD
+ :output-error-action #+debug :error #-debug :ignore))
+ (defun %string-to-octets (string encoding)
+ (ext:convert-string-to-bytes string (encoding-keyword-to-native encoding)))
+ (defun %octets-to-string (octets encoding)
+ (ext:convert-string-from-bytes octets (encoding-keyword-to-native encoding))))
+
+;;;; *** SBCL
+
+#+(and sbcl sb-unicode)
+(progn
+ (defun %encoding-keyword-to-native (encoding)
+ (case encoding
+ (:utf-8 :utf8)
+ (:utf-16 :utf16)
+ (:us-ascii :us-ascii)
+ (t encoding)))
+ (defun %string-to-octets (string encoding)
+ (sb-ext:string-to-octets string :external-format (encoding-keyword-to-native encoding)))
+ (defun %octets-to-string (octets encoding)
+ (sb-ext:octets-to-string octets :external-format (encoding-keyword-to-native encoding))))
+
+;;;; *** Allegro
+
+#+allegro
+(progn
+ (defun %encoding-keyword-to-native (encoding)
+ (case encoding
+ (:utf-8 :utf8)
+ (:iso-8859-1 :iso8859-1)
+ (:utf-16 :unicode)
+ (:us-ascii :ascii)
+ (t encoding)))
+
+ (defun %string-to-octets (string encoding)
+ (excl:string-to-octets string :external-format (encoding-keyword-to-native encoding) :null-terminate nil))
+
+ (defun %octets-to-string (octets encoding)
+ (multiple-value-bind (displaced-array index) (array-displacement octets)
+ (if displaced-array
+ (excl:octets-to-string displaced-array :start index :end (+ index (length octets)) :external-format (encoding-keyword-to-native encoding))
+ (excl:octets-to-string octets :external-format (encoding-keyword-to-native encoding))))))
+
+
+;;;; *** LispWorks
+
+;; TODO this is partial. someone with a lispworks at hand should finish it.
+;; see this as an example:
+;; (defun encode-lisp-string (string)
+;; (translate-string-via-fli string :utf-8 :latin-1))
+;;
+;; (defun decode-external-string (string)
+;; (translate-string-via-fli string :latin-1 :utf-8))
+;;
+;; ;; Note that a :utf-8 encoding of a null in a latin-1 string is
+;; ;; also null, and vice versa. So don't have to worry about
+;; ;; null-termination or length. (If we were translating to/from
+;; ;; :unicode, this would become an issue.)
+;;
+;; (defun translate-string-via-fli (string from to)
+;; (fli:with-foreign-string (ptr elements bytes :external-format from)
+;; string
+;; (declare (ignore elements bytes))
+;; (fli:convert-from-foreign-string ptr :external-format to)))
+
+#+lispworks
+(progn
+ (defun %encoding-keyword-to-native (encoding)
+ (case encoding
+ (:utf-8 :utf-8)
+ (:iso-8859-1 :latin-1)
+ (:utf-16 :unicode)
+ (:us-ascii :us-ascii)
+ (t encoding)))
+
+ (defun %string-to-octets (string encoding)
+ (declare (ignore encoding))
+ ;; TODO
+ (map-into (make-array (length string) :element-type 'unsigned-byte)
+ #'char-code string))
+
+ (defun %octets-to-string (octets encoding)
+ (declare (ignore encoding))
+ ;; TODO
+ (map-into (make-array (length octets) :element-type 'character)
+ #'code-char octets)))
+
+
+;;;; *** Default Implementation
+
+#-(or (and sbcl sb-unicode) (and clisp unicode) allegro lispworks)
+(progn
+ (defun %encoding-keyword-to-native (encoding)
+ encoding)
+
+ (defun %string-to-octets (string encoding)
+ (declare (ignore encoding))
+ (map-into (make-array (length string) :element-type 'unsigned-byte)
+ #'char-code string))
+
+ (defun %octets-to-string (octets encoding)
+ (declare (ignore encoding))
+ (map-into (make-array (length octets) :element-type 'character)
+ #'code-char octets)))
+
+(declaim (inline string-to-octets %string-to-octets))
+(defun string-to-octets (string encoding)
+ "Convert STRING, a list string, a vector of bytes according to ENCODING.
+
+ENCODING is a keyword representing the desired character
+encoding. We gurantee that :UTF-8, :UTF-16 and :ISO-8859-1 will
+work as expected. Any other values are simply passed to the
+underlying lisp's function and the results are implementation
+dependant.
+
+On CLISP we intern the ENCODING symbol in the CHARSET package and
+pass that. On SBCL we simply pass the keyword."
+ (%string-to-octets string encoding))
+
+(declaim (inline octets-to-string %octets-to-string))
+(defun octets-to-string (octets encoding)
+ (%octets-to-string octets encoding))
+
+(declaim (inline encoding-keyword-to-native))
+(defun encoding-keyword-to-native (encoding)
+ "Convert ENCODING, a keyword, to an object the native list
+accepts as an encoding.
+
+ENCODING can be: :UTF-8, :UTF-16, or :US-ASCII and specify the
+corresponding encodings. Any other keyword is passed, as is, to
+the underlying lisp."
+ (%encoding-keyword-to-native encoding))
+
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;; - Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;;
+;; - Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;;
+;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;; of its contributors may be used to endorse or promote products
+;; derived from this software without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Added: branches/trunk-reorg/thirdparty/arnesi/src/time.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/time.lisp Mon Feb 11 08:38:43 2008
@@ -0,0 +1,185 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * Programmatic interface to CL:TIME
+
+(defclass timing-info ()
+ ((real-time :accessor real-time :initarg :real-time
+ :initform :not-available
+ :documentation "Real time (also known as wall time)
+ consumed. Expressed in milliseconds.")
+ (user-time :accessor user-time :initarg :user-time
+ :initform :not-available
+ :documentation "User time. Expressed in milliseconds.")
+ (system-time :accessor system-time :initarg :system-time
+ :initform :not-available
+ :documentation "System time. Expressed in milliseconds.")
+ (gc-time :accessor gc-time :initarg :gc-time
+ :initform :not-available
+ :documentation "GC time. Expressed in milliseconds.")
+ (page-faults :accessor page-faults :initarg :page-faults
+ :initform :not-available
+ :documentation "Number of page faults.")
+ (bytes-consed :accessor bytes-consed :initarg :bytes-consed
+ :initform :not-available
+ :documentation "Number of bytes allocated."))
+ (:documentation "Specificer for collect-timing info.
+
+Every slot is either a number (with the exact meanining depending
+on the slot) or the keyword :not-available in the case the lisp
+doesn't provide this information."))
+
+(defun pprint-milliseconds (milliseconds &optional stream)
+ (cond
+ ((< milliseconds 1000)
+ (format stream "~D ms" milliseconds))
+ ((= milliseconds 1000)
+ (format stream "1.00 second"))
+ ((< milliseconds (* 60 1000))
+ (format stream "~,2F seconds" (/ milliseconds 1000)))
+ ((= milliseconds (* 60 1000))
+ (format stream "1.00 minute"))
+ (t
+ (format stream "~,2F minutes" (/ milliseconds (* 60 1000))))))
+
+(defun pprint-bytes (num-bytes &optional stream)
+ "Writes NUM-BYTES to stream, rounds num-bytes and appends a
+suffix depending on the size of num-bytes."
+ (cond
+ ((< num-bytes (expt 2 10))
+ (format stream "~D B" num-bytes))
+ ((< num-bytes (expt 2 20))
+ (format stream "~,2F KiB" (/ num-bytes (expt 2 10))))
+ ((< num-bytes (expt 2 30))
+ (format stream "~,2F MiB" (/ num-bytes (expt 2 20))))
+ ((< num-bytes (expt 2 40))
+ (format stream "~,2F GiB" (/ num-bytes (expt 2 30))))
+ (t
+ (format stream "~,2F TiB" (/ num-bytes (expt 2 40))))))
+
+(defmethod print-object ((info timing-info) stream)
+ (print-unreadable-object (info stream :type t :identity t)
+ (format stream "~A/~A"
+ (pprint-milliseconds (real-time info))
+ (pprint-bytes (bytes-consed info)))))
+
+(defun collect-timing (lambda)
+ "Executes LAMBDA and returns a timing-info object specifying
+ how long execution took and how much memory was used.
+
+NB: Not all implementations provide all information. See the
+various %collect-timing definitions for details."
+ (%collect-timing lambda))
+
+#+sbcl
+(defun %collect-timing (fun)
+ (declare (type function fun))
+ "Implementation of collect-timing for SBCL.
+
+This code is a cut 'n paste from sbcl/src/code/time.lisp. It uses
+internal functions, all bets off."
+ (let (old-run-utime
+ new-run-utime
+ old-run-stime
+ new-run-stime
+ old-real-time
+ new-real-time
+ old-page-faults
+ new-page-faults
+ real-time-overhead
+ run-utime-overhead
+ run-stime-overhead
+ page-faults-overhead
+ old-bytes-consed
+ new-bytes-consed
+ cons-overhead)
+ ;; Calculate the overhead...
+ (multiple-value-setq
+ (old-run-utime old-run-stime old-page-faults old-bytes-consed)
+ (sb-impl::time-get-sys-info))
+ ;; Do it a second time to make sure everything is faulted in.
+ (multiple-value-setq
+ (old-run-utime old-run-stime old-page-faults old-bytes-consed)
+ (sb-impl::time-get-sys-info))
+ (multiple-value-setq
+ (new-run-utime new-run-stime new-page-faults new-bytes-consed)
+ (sb-impl::time-get-sys-info))
+ (setq run-utime-overhead (- new-run-utime old-run-utime))
+ (setq run-stime-overhead (- new-run-stime old-run-stime))
+ (setq page-faults-overhead (- new-page-faults old-page-faults))
+ (setq old-real-time (get-internal-real-time))
+ (setq old-real-time (get-internal-real-time))
+ (setq new-real-time (get-internal-real-time))
+ (setq real-time-overhead (- new-real-time old-real-time))
+ (setq cons-overhead (- new-bytes-consed old-bytes-consed))
+ ;; Now get the initial times.
+ (multiple-value-setq
+ (old-run-utime old-run-stime old-page-faults old-bytes-consed)
+ (sb-impl::time-get-sys-info))
+ (setq old-real-time (get-internal-real-time))
+ (let ((start-gc-run-time sb-impl::*gc-run-time*))
+ (progn
+ ;; Execute the form and return its values.
+ (funcall fun)
+ (multiple-value-setq
+ (new-run-utime new-run-stime new-page-faults new-bytes-consed)
+ (sb-impl::time-get-sys-info))
+ (setq new-real-time (- (get-internal-real-time) real-time-overhead))
+ (let ((gc-run-time (max (- sb-impl::*gc-run-time* start-gc-run-time) 0)))
+ (make-instance 'timing-info
+ :real-time (max (- new-real-time old-real-time) 0.0)
+ :user-time (max (/ (- new-run-utime old-run-utime) 1000.0) 0.0)
+ :system-time (max (/ (- new-run-stime old-run-stime) 1000.0) 0.0)
+ :gc-time (float gc-run-time)
+ :page-faults (max (- new-page-faults old-page-faults) 0)
+ :bytes-consed (max (- new-bytes-consed old-bytes-consed) 0)))))))
+
+#+openmcl
+(defun %collect-timing (lambda)
+ "Implementation of collect-timing for OpenMCL.
+
+We only report the MAJOR-PAGE-FAULTS, the number of
+MINOR-PAGE-FAULTS is ignored."
+ (let ((ccl:*report-time-function* #'list))
+ (destructuring-bind (&key elapsed-time user-time system-time
+ gc-time bytes-allocated major-page-faults
+ &allow-other-keys)
+ (time (funcall lambda))
+ (make-instance 'timing-info
+ :real-time elapsed-time
+ :user-time user-time
+ :system-time system-time
+ :gc-time gc-time
+ :bytes-consed bytes-allocated
+ :page-faults major-page-faults))))
+
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;; - Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;;
+;; - Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;;
+;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;; of its contributors may be used to endorse or promote products
+;; derived from this software without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Added: branches/trunk-reorg/thirdparty/arnesi/src/unwalk.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/unwalk.lisp Mon Feb 11 08:38:43 2008
@@ -0,0 +1,311 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * A Code UnWalker
+
+;;; ** Public Entry Point
+
+(defgeneric unwalk-form (form)
+ (:documentation "Unwalk FORM and return a list representation."))
+
+(defmacro defunwalker-handler (class (&rest slots) &body body)
+ (with-unique-names (form)
+ `(progn
+ (defmethod unwalk-form ((,form ,class))
+ (with-slots ,slots ,form
+ , at body))
+ ',class)))
+
+(declaim (inline unwalk-forms))
+(defun unwalk-forms (forms)
+ (mapcar #'unwalk-form forms))
+
+;;;; Atoms
+
+(defunwalker-handler constant-form (value)
+ (typecase value
+ (symbol `(quote ,value))
+ (cons `(quote ,value))
+ (t value)))
+
+(defunwalker-handler variable-reference (name)
+ name)
+
+;;;; Function Application
+
+(defunwalker-handler application-form (operator arguments)
+ (cons operator (unwalk-forms arguments)))
+
+(defunwalker-handler lambda-application-form (operator arguments)
+ ;; The cadr is for getting rid of (function ...) which we can't have
+ ;; at the beginning of a form.
+ (cons (cadr (unwalk-form operator)) (unwalk-forms arguments)))
+
+;;;; Functions
+
+(defunwalker-handler lambda-function-form (arguments body declares)
+ `(function
+ (lambda ,(unwalk-lambda-list arguments)
+ ,@(unwalk-declarations declares)
+ ,@(unwalk-forms body))))
+
+(defunwalker-handler function-object-form (name)
+ `(function ,name))
+
+;;;; Arguments
+
+(defun unwalk-lambda-list (arguments)
+ (let (optional-p rest-p keyword-p)
+ (mapcan #'(lambda (form)
+ (append
+ (typecase form
+ (optional-function-argument-form
+ (unless optional-p (setq optional-p t) '(&optional)))
+ (rest-function-argument-form
+ (unless rest-p (setq rest-p t) '(&rest)))
+ (keyword-function-argument-form
+ (unless keyword-p (setq keyword-p t) '(&key))))
+ (list (unwalk-form form))))
+ arguments)))
+
+(defunwalker-handler required-function-argument-form (name)
+ name)
+
+(defunwalker-handler specialized-function-argument-form (name specializer)
+ (if (eq specializer t)
+ name
+ `(,name ,specializer)))
+
+(defunwalker-handler optional-function-argument-form (name default-value supplied-p-parameter)
+ (let ((default-value (unwalk-form default-value)))
+ (cond ((and name default-value supplied-p-parameter)
+ `(,name ,default-value ,supplied-p-parameter))
+ ((and name default-value)
+ `(,name ,default-value))
+ (name name)
+ (t (error "Invalid optional argument")))))
+
+(defunwalker-handler keyword-function-argument-form (keyword-name name default-value supplied-p-parameter)
+ (let ((default-value (unwalk-form default-value)))
+ (cond ((and keyword-name name default-value supplied-p-parameter)
+ `((,keyword-name ,name) ,default-value ,supplied-p-parameter))
+ ((and name default-value supplied-p-parameter)
+ `(,name ,default-value ,supplied-p-parameter))
+ ((and name default-value)
+ `(,name ,default-value))
+ (name name)
+ (t (error "Invalid keyword argument")))))
+
+(defunwalker-handler allow-other-keys-function-argument-form ()
+ '&allow-other-keys)
+
+(defunwalker-handler rest-function-argument-form (name)
+ name)
+
+;;;; Declarations
+
+(defun unwalk-declarations (decls)
+ ;; Return a list so declarations can be easily spliced.
+ (if (null decls)
+ nil
+ (list `(declare ,@(unwalk-forms decls)))))
+
+(defunwalker-handler optimize-declaration-form (optimize-spec)
+ `(optimize ,optimize-spec))
+
+(defunwalker-handler dynamic-extent-declaration-form (name)
+ `(dynamic-extent ,name))
+
+(defunwalker-handler variable-ignorable-declaration-form (name)
+ `(ignorable ,name))
+
+(defunwalker-handler function-ignorable-declaration-form (name)
+ `(ignorable (function ,name)))
+
+(defunwalker-handler special-declaration-form (name)
+ `(special ,name))
+
+(defunwalker-handler type-declaration-form (type-form name)
+ `(type ,type-form ,name))
+
+(defunwalker-handler ftype-declaration-form (type-form name)
+ `(ftype ,type-form ,name))
+
+(defunwalker-handler notinline-declaration-form (name)
+ `(notinline ,name))
+
+;;;; BLOCK/RETURN-FROM
+
+(defunwalker-handler block-form (name body)
+ `(block ,name ,@(unwalk-forms body)))
+
+(defunwalker-handler return-from-form (target-block result)
+ `(return-from ,(name target-block) ,(unwalk-form result)))
+
+;;;; CATCH/THROW
+
+(defunwalker-handler catch-form (tag body)
+ `(catch ,(unwalk-form tag) ,@(unwalk-forms body)))
+
+(defunwalker-handler throw-form (tag value)
+ `(throw ,(unwalk-form tag) ,(unwalk-form value)))
+
+;;;; EVAL-WHEN
+
+(defunwalker-handler eval-when-form (body eval-when-times)
+ `(eval-when ,eval-when-times
+ ,@(unwalk-forms body)))
+
+;;;; IF
+
+(defunwalker-handler if-form (consequent then else)
+ `(if ,(unwalk-form consequent) ,(unwalk-form then) ,(unwalk-form else)))
+
+;;;; FLET/LABELS
+
+;; The cdadr is here to remove (function (lambda ...)) of the function
+;; bindings.
+
+(defunwalker-handler flet-form (binds body declares)
+ (flet ((unwalk-flet (binds)
+ (mapcar #'(lambda (bind)
+ (cons (car bind)
+ (cdadr (unwalk-form (cdr bind)))))
+ binds)))
+ `(flet ,(unwalk-flet binds)
+ ,@(unwalk-declarations declares)
+ ,@(unwalk-forms body))))
+
+(defunwalker-handler labels-form (binds body declares)
+ (flet ((unwalk-labels (binds)
+ (mapcar #'(lambda (bind)
+ (cons (car bind)
+ (cdadr (unwalk-form (cdr bind)))))
+ binds)))
+ `(labels ,(unwalk-labels binds)
+ ,@(unwalk-declarations declares)
+ ,@(unwalk-forms body))))
+
+;;;; LET/LET*
+
+(defunwalker-handler let-form (binds body declares)
+ (flet ((unwalk-let (binds)
+ (mapcar #'(lambda (bind)
+ (list (car bind) (unwalk-form (cdr bind))))
+ binds)))
+ `(let ,(unwalk-let binds)
+ ,@(unwalk-declarations declares)
+ ,@(unwalk-forms body))))
+
+(defunwalker-handler let*-form (binds body declares)
+ (flet ((unwalk-let* (binds)
+ (mapcar #'(lambda (bind)
+ (list (car bind) (unwalk-form (cdr bind))))
+ binds)))
+ `(let* ,(unwalk-let* binds)
+ ,@(unwalk-declarations declares)
+ ,@(unwalk-forms body))))
+
+;;;; LOAD-TIME-VALUE
+
+(defunwalker-handler load-time-value-form (value read-only-p)
+ `(load-time-value ,(unwalk-form value) ,read-only-p))
+
+;;;; LOCALLY
+
+(defunwalker-handler locally-form (body declares)
+ `(locally ,@(unwalk-declarations declares)
+ ,@(unwalk-forms body)))
+
+;;;; MACROLET
+
+(defunwalker-handler macrolet-form (body binds declares)
+ ;; We ignore the binds, because the expansion has already taken
+ ;; place at walk-time.
+ (declare (ignore binds))
+ `(locally ,@(unwalk-declarations declares) ,@(unwalk-forms body)))
+
+;;;; MULTIPLE-VALUE-CALL
+
+(defunwalker-handler multiple-value-call-form (func arguments)
+ `(multiple-value-call ,(unwalk-form func) ,@(unwalk-forms arguments)))
+
+;;;; MULTIPLE-VALUE-PROG1
+
+(defunwalker-handler multiple-value-prog1-form (first-form other-forms)
+ `(multiple-value-prog1 ,(unwalk-form first-form) ,@(unwalk-forms other-forms)))
+
+;;;; PROGN
+
+(defunwalker-handler progn-form (body)
+ `(progn ,@(unwalk-forms body)))
+
+;;;; PROGV
+
+(defunwalker-handler progv-form (body vars-form values-form)
+ `(progv ,(unwalk-form vars-form) ,(unwalk-form values-form) ,@(unwalk-forms body)))
+
+;;;; SETQ
+
+(defunwalker-handler setq-form (var value)
+ `(setq ,var ,(unwalk-form value)))
+
+;;;; SYMBOL-MACROLET
+
+(defunwalker-handler symbol-macrolet-form (body binds declares)
+ ;; We ignore the binds, because the expansion has already taken
+ ;; place at walk-time.
+ (declare (ignore binds))
+ `(locally ,@(unwalk-declarations declares) ,@(unwalk-forms body)))
+
+;;;; TAGBODY/GO
+
+(defunwalker-handler tagbody-form (body)
+ `(tagbody ,@(unwalk-forms body)))
+
+(defunwalker-handler go-tag-form (name)
+ name)
+
+(defunwalker-handler go-form (name)
+ `(go ,name))
+
+;;;; THE
+
+(defunwalker-handler the-form (type-form value)
+ `(the ,type-form ,(unwalk-form value)))
+
+;;;; UNWIND-PROTECT
+
+(defunwalker-handler unwind-protect-form (protected-form cleanup-form)
+ `(unwind-protect ,(unwalk-form protected-form) ,@(unwalk-forms cleanup-form)))
+
+;; Copyright (c) 2006, Hoan Ton-That
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;; - Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;;
+;; - Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;;
+;; - Neither the name of Hoan Ton-That, nor the names of the
+;; contributors may be used to endorse or promote products derived
+;; from this software without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Added: branches/trunk-reorg/thirdparty/arnesi/src/vector.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/vector.lisp Mon Feb 11 08:38:43 2008
@@ -0,0 +1,78 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * vector/array utilities
+
+(defun vector-push-extend* (vector &rest items)
+ (let ((element-type (array-element-type vector)))
+ (dolist (item items)
+ (cond
+ ((typep item element-type) ;; item can be put directly into the
+ (vector-push-extend item vector))
+ ((typep item `(vector ,element-type)) ;; item should be a vector
+ (loop
+ for i across item
+ do (vector-push-extend i vector)))
+ (t
+ (error "Bad type for item ~S." item))))
+ vector))
+
+(defun string-from-array (array &key (start 0) (end (1- (length array))))
+ "Assuming ARRAY is an array of ASCII chars encoded as bytes return
+the corresponding string. Respect the C convention of null terminating
+strings. START and END specify the zero indexed offsets of a sub range
+of ARRAY."
+ ;; This is almost always the case
+ (assert (<= 0 start (1- (length array)))
+ (start)
+ "START must be a valid offset of ARRAY.")
+ (assert (<= 0 end (1- (length array)))
+ (end)
+ "END must be a valid offset of ARRAY.")
+ (assert (<= start end)
+ (start end)
+ "START must be less than or equal to END.")
+ (assert (every (lambda (element) (<= 0 element 255)) array)
+ (array)
+ "Some element of ~S was not > 0 and < 255" array)
+ (let* ((working-array (make-array (1+ (- end start))
+ :element-type (array-element-type array)
+ :displaced-to array
+ :displaced-index-offset start))
+ (length (if-bind pos (position 0 working-array)
+ pos
+ (length working-array))))
+ (map-into (make-array length :element-type 'character)
+ #'code-char
+ working-array)))
+
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;; - Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;;
+;; - Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;;
+;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;; of its contributors may be used to endorse or promote products
+;; derived from this software without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Added: branches/trunk-reorg/thirdparty/arnesi/src/walk.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/walk.lisp Mon Feb 11 08:38:43 2008
@@ -0,0 +1,1002 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * A Code Walker
+
+;;;; ** Public Entry Point
+
+(defvar *warn-undefined* nil
+ "When non-NIL any references to undefined functions or
+ variables will signal a warning.")
+
+(defun walk-form (form &optional (parent nil) (env (make-walk-env)))
+ "Walk FORM and return a FORM object."
+ (funcall (find-walker-handler form) form parent env))
+
+(defun make-walk-env (&optional lexical-env)
+ (let ((walk-env '()))
+ (when lexical-env
+ (dolist (var (lexical-variables lexical-env))
+ (extend walk-env :lexical-let var t))
+ (dolist (fun (lexical-functions lexical-env))
+ (extend walk-env :lexical-flet fun t))
+ (dolist (mac (lexical-macros lexical-env))
+ (extend walk-env :macrolet (car mac) (cdr mac)))
+ (dolist (symmac (lexical-symbol-macros lexical-env))
+ (extend walk-env :symbol-macrolet (car symmac) (cdr symmac))))
+ (cons walk-env lexical-env)))
+
+(defun register-walk-env (env type name datum &rest other-datum)
+ (let ((walk-env (register (car env) type name datum))
+ (lexenv (case type
+ (:let (augment-with-variable (cdr env) name))
+ (:macrolet (augment-with-macro (cdr env) name datum))
+ (:flet (augment-with-function (cdr env) name))
+ (:symbol-macrolet (augment-with-symbol-macro (cdr env) name datum))
+ ;;TODO: :declare
+ (t (cdr env)))))
+ (cons walk-env lexenv)))
+
+(defmacro extend-walk-env (env type name datum &rest other-datum)
+ `(setf ,env (register-walk-env ,env ,type ,name ,datum , at other-datum)))
+
+(defun lookup-walk-env (env type name &key (error-p nil) (default-value nil))
+ (lookup (car env) type name :error-p error-p :default-value default-value))
+
+;;;; This takes a Common Lisp form and transforms it into a tree of
+;;;; FORM objects.
+
+(defvar *walker-handlers* (make-hash-table :test 'eq))
+
+(define-condition undefined-reference (warning)
+ ((enclosing-code :accessor enclosing-code :initform nil)
+ (name :accessor name :initarg :name)))
+
+(define-condition undefined-variable-reference (undefined-reference)
+ ()
+ (:report
+ (lambda (c s)
+ (if (enclosing-code c)
+ (format s "Reference to unknown variable ~S in ~S." (name c) (enclosing-code c))
+ (format s "Reference to unknown variable ~S." (name c))))))
+
+(define-condition undefined-function-reference (undefined-reference)
+ ()
+ (:report
+ (lambda (c s)
+ (if (enclosing-code c)
+ (format s "Reference to unknown function ~S in ~S." (name c) (enclosing-code c))
+ (format s "Reference to unknown function ~S." (name c))))))
+
+(defvar +atom-marker+ '+atom-marker+)
+
+(defun find-walker-handler (form)
+ "Simple function which tells us what handler should deal
+ with FORM. Signals an error if we don't have a handler for
+ FORM."
+ (if (atom form)
+ (gethash '+atom-marker+ *walker-handlers*)
+ (aif (gethash (car form) *walker-handlers*)
+ it
+ (case (car form)
+ ((block declare flet function go if labels let let*
+ macrolet progn quote return-from setq symbol-macrolet
+ tagbody unwind-protect catch multiple-value-call
+ multiple-value-prog1 throw load-time-value the
+ eval-when locally progv)
+ (error "Sorry, No walker for the special operater ~S defined." (car form)))
+ (t (gethash 'application *walker-handlers*))))))
+
+(defmacro defwalker-handler (name (form parent lexical-env)
+ &body body)
+ `(progn
+ (setf (gethash ',name *walker-handlers*)
+ (lambda (,form ,parent ,lexical-env)
+ (declare (ignorable ,parent ,lexical-env))
+ , at body))
+ ',name))
+
+(defclass form ()
+ ((parent :accessor parent :initarg :parent)
+ (source :accessor source :initarg :source)))
+
+(defmethod make-load-form ((object form) &optional env)
+ (make-load-form-saving-slots object
+ :slot-names (mapcar #'mopp:slot-definition-name
+ (mopp:class-slots (class-of object)))
+ :environment env))
+
+(defmethod print-object ((form form) stream)
+ (print-unreadable-object (form stream :type t :identity t)
+ (when (slot-boundp form 'source)
+ (let ((*print-readably* nil)
+ (*print-level* 0)
+ (*print-length* 4))
+ (format stream "~S" (source form))))))
+
+(defmacro with-form-object ((variable type &rest initargs)
+ &body body)
+ `(let ((,variable (make-instance ',type , at initargs)))
+ , at body
+ ,variable))
+
+(defclass implicit-progn-mixin ()
+ ((body :accessor body :initarg :body)))
+
+(defclass implicit-progn-with-declare-mixin (implicit-progn-mixin)
+ ((declares :accessor declares :initarg :declares)))
+
+(defclass binding-form-mixin ()
+ ((binds :accessor binds :initarg :binds)))
+
+(defmacro multiple-value-setf (places form)
+ (loop
+ for place in places
+ for name = (gensym)
+ collect name into bindings
+ if (eql 'nil place)
+ collect `(declare (ignore ,name)) into ignores
+ else
+ collect `(setf ,place ,name) into body
+ finally (return
+ `(multiple-value-bind ,bindings ,form
+ , at ignores
+ , at body))))
+
+(defun split-body (body env &key parent (docstring t) (declare t))
+ (let ((documentation nil)
+ (newdecls nil)
+ (decls nil))
+ (flet ((done ()
+ (return-from split-body (values body env documentation (nreverse decls)))))
+ (loop
+ for form = (car body)
+ while body
+ do (typecase form
+ (cons (if (and declare (eql 'cl:declare (first form)))
+ ;; declare form
+ (let ((declarations (rest form)))
+ (dolist* (dec declarations)
+ (multiple-value-setf (env newdecls) (parse-declaration dec env parent))
+ (setf decls (append newdecls decls))))
+ ;; source code, all done
+ (done)))
+ (string (if docstring
+ (if documentation
+ ;; already found the docstring, this is source
+ (done)
+ (if (cdr body)
+ ;; found the doc string
+ (setf documentation form)
+ ;; this looks like a doc string, but
+ ;; it's the only form in body, so
+ ;; it's actually code.
+ (done)))
+ ;; no docstring allowed, this is source
+ (done)))
+ (t ;; more code, all done
+ (done)))
+ do (pop body)
+ finally (done)))))
+
+(defclass declaration-form (form)
+ ())
+
+(defclass optimize-declaration-form (declaration-form)
+ ((optimize-spec :accessor optimize-spec :initarg :optimize-spec)))
+
+(defclass variable-declaration-form (declaration-form)
+ ((name :accessor name :initarg :name)))
+
+(defclass function-declaration-form (declaration-form)
+ ((name :accessor name :initarg :name)))
+
+(defclass dynamic-extent-declaration-form (variable-declaration-form)
+ ())
+
+(defclass ignorable-declaration-form-mixin (declaration-form)
+ ())
+
+(defclass variable-ignorable-declaration-form (variable-declaration-form ignorable-declaration-form-mixin)
+ ())
+
+(defclass function-ignorable-declaration-form (function-declaration-form ignorable-declaration-form-mixin)
+ ())
+
+(defclass special-declaration-form (variable-declaration-form)
+ ())
+
+(defclass type-declaration-form (variable-declaration-form)
+ ((type-form :accessor type-form :initarg :type-form)))
+
+(defclass ftype-declaration-form (function-declaration-form)
+ ((type-form :accessor type-form :initarg :type-form)))
+
+(defclass notinline-declaration-form (function-declaration-form)
+ ())
+
+(defun parse-declaration (declaration environment parent)
+ (let ((declares nil))
+ (flet ((funname (form)
+ (if (and (consp form) (eql (car form) 'function))
+ (cadr form)
+ nil)))
+ (macrolet ((mkdecl (varname formclass &rest rest)
+ `(make-instance ,formclass :parent parent :source (list type ,varname) , at rest))
+ (extend-env ((var list) newdeclare &rest datum)
+ `(dolist (,var ,list)
+ (when ,newdeclare (push ,newdeclare declares))
+ (extend-walk-env environment :declare , at datum))))
+ (destructuring-bind (type &rest arguments)
+ declaration
+ (case type
+ (dynamic-extent
+ (extend-env (var arguments)
+ (mkdecl var 'dynamic-extent-declaration-form :name var)
+ var `(dynamic-extent)))
+ (ftype
+ (extend-env (function-name (cdr arguments))
+ (make-instance 'ftype-declaration-form
+ :parent parent
+ :source `(ftype ,(first arguments) function-name)
+ :name function-name
+ :type-form (first arguments))
+ function-name `(ftype ,(first arguments))))
+ ((ignore ignorable)
+ (extend-env (var arguments)
+ (aif (funname var)
+ (mkdecl var 'function-ignorable-declaration-form :name it)
+ (mkdecl var 'variable-ignorable-declaration-form :name var))
+ var `(ignorable)))
+ (inline
+ (extend-env (function arguments)
+ (mkdecl function 'function-ignorable-declaration-form :name function)
+ function `(ignorable)))
+ (notinline
+ (extend-env (function arguments)
+ (mkdecl function 'notinline-declaration-form :name function)
+ function `(notinline)))
+ (optimize
+ (extend-env (optimize-spec arguments)
+ (mkdecl optimize-spec 'optimize-declaration-form :optimize-spec optimize-spec)
+ 'optimize optimize-spec))
+ (special
+ (extend-env (var arguments)
+ (mkdecl var 'special-declaration-form :name var)
+ var `(special)))
+ (type
+ (extend-env (var (rest arguments))
+ (make-instance 'type-declaration-form
+ :parent parent
+ :source `(type ,(first arguments) ,var)
+ :name var
+ :type-form (first arguments))
+ var `(type ,(first arguments))))
+ (t
+ (extend-env (var arguments)
+ (make-instance 'type-declaration-form
+ :parent parent
+ :source `(,type ,var)
+ :name var
+ :type-form type)
+ var `(type ,type)))))))
+ (when (null declares)
+ (setq declares (list (make-instance 'declaration-form :parent parent :source declaration))))
+ (values environment declares)))
+
+(defun walk-implict-progn (parent forms env &key docstring declare)
+ (handler-bind ((undefined-reference (lambda (condition)
+ (unless (enclosing-code condition)
+ (setf (enclosing-code condition) `(progn , at forms))))))
+ (multiple-value-bind (body env docstring declarations)
+ (split-body forms env :parent parent :docstring docstring :declare declare)
+ (values (mapcar (lambda (form)
+ (walk-form form parent env))
+ body)
+ docstring
+ declarations))))
+
+;;;; Atoms
+
+(defclass constant-form (form)
+ ((value :accessor value :initarg :value)))
+
+(defclass variable-reference (form)
+ ((name :accessor name :initarg :name)))
+
+(defmethod print-object ((v variable-reference) stream)
+ (print-unreadable-object (v stream :type t :identity t)
+ (format stream "~S" (name v))))
+
+(defclass local-variable-reference (variable-reference)
+ ())
+
+(defclass local-lexical-variable-reference (local-variable-reference)
+ ()
+ (:documentation "A reference to a local variable defined in the
+ lexical environment outside of the form passed to walk-form."))
+
+(defclass free-variable-reference (variable-reference)
+ ())
+
+(defwalker-handler +atom-marker+ (form parent env)
+ (declare (special *macroexpand*))
+ (cond
+ ((not (or (symbolp form) (consp form)))
+ (make-instance 'constant-form :value form
+ :parent parent :source form))
+ ((lookup-walk-env env :let form)
+ (make-instance 'local-variable-reference :name form
+ :parent parent :source form))
+ ((lookup-walk-env env :lexical-let form)
+ (make-instance 'local-lexical-variable-reference :name form
+ :parent parent :source form))
+ ((lookup-walk-env env :symbol-macrolet form)
+ (walk-form (lookup-walk-env env :symbol-macrolet form) parent env))
+ ((nth-value 1 (macroexpand-1 form))
+ ;; a globaly defined symbol-macro
+ (walk-form (macroexpand-1 form) parent env))
+ (t
+ (when (and *warn-undefined*
+ (not (boundp form)))
+ (warn 'undefined-variable-reference :name form))
+ (make-instance 'free-variable-reference :name form
+ :parent parent :source form))))
+
+;;;; Function Applictation
+
+(defclass application-form (form)
+ ((operator :accessor operator :initarg :operator)
+ (arguments :accessor arguments :initarg :arguments)))
+
+(defclass local-application-form (application-form)
+ ((code :accessor code :initarg :code)))
+
+(defclass lexical-application-form (application-form)
+ ())
+
+(defclass free-application-form (application-form)
+ ())
+
+(defclass lambda-application-form (application-form)
+ ())
+
+(defwalker-handler application (form parent env)
+ (block nil
+ (destructuring-bind (op &rest args)
+ form
+ (when (and (consp op)
+ (eq 'cl:lambda (car op)))
+ (return
+ (with-form-object (application lambda-application-form :parent parent :source form)
+ (setf (operator application) (walk-form op application env)
+ (arguments application) (mapcar (lambda (form)
+ (walk-form form application env))
+ args)))))
+ (when (lookup-walk-env env :macrolet op)
+ (return (walk-form (funcall (lookup-walk-env env :macrolet op) form (cdr env)) parent env)))
+ (when (and (symbolp op) (macro-function op))
+ (multiple-value-bind (expansion expanded)
+ (macroexpand-1 form (cdr env))
+ (when expanded
+ (return (walk-form expansion parent env)))))
+ (let ((app (if (lookup-walk-env env :flet op)
+ (make-instance 'local-application-form :code (lookup-walk-env env :flet op))
+ (if (lookup-walk-env env :lexical-flet op)
+ (make-instance 'lexical-application-form)
+ (progn
+ (when (and *warn-undefined*
+ (symbolp op)
+ (not (fboundp op)))
+ (warn 'undefined-function-reference :name op))
+ (make-instance 'free-application-form))))))
+ (setf (operator app) op
+ (parent app) parent
+ (source app) form
+ (arguments app) (mapcar (lambda (form)
+ (walk-form form app env))
+ args))
+ app))))
+
+;;;; Functions
+
+(defclass function-form (form)
+ ())
+
+(defclass lambda-function-form (function-form implicit-progn-with-declare-mixin)
+ ((arguments :accessor arguments :initarg :arguments)))
+
+(defclass function-object-form (form)
+ ((name :accessor name :initarg :name)))
+
+(defclass local-function-object-form (function-object-form)
+ ())
+
+(defclass free-function-object-form (function-object-form)
+ ())
+
+(defclass lexical-function-object-form (function-object-form)
+ ())
+
+(defwalker-handler function (form parent env)
+ (if (and (listp (second form))
+ (eql 'cl:lambda (first (second form))))
+ ;; (function (lambda ...))
+ (walk-lambda (second form) parent env)
+ ;; (function foo)
+ (make-instance (if (lookup-walk-env env :flet (second form))
+ 'local-function-object-form
+ (if (lookup-walk-env env :lexical-flet (second form))
+ 'lexical-function-object-form
+ 'free-function-object-form))
+ :name (second form)
+ :parent parent :source form)))
+
+(defun walk-lambda (form parent env)
+ (with-form-object (func lambda-function-form
+ :parent parent
+ :source form)
+ ;; 1) parse the argument list creating a list of FUNCTION-ARGUMENT-FORM objects
+ (multiple-value-setf ((arguments func) env)
+ (walk-lambda-list (second form) func env))
+ ;; 2) parse the body
+ (multiple-value-setf ((body func) nil (declares func))
+ (walk-implict-progn func (cddr form) env :declare t))
+ ;; all done
+ func))
+
+(defun walk-lambda-list (lambda-list parent env &key allow-specializers macro-p)
+ (flet ((extend-env (argument)
+ (unless (typep argument 'allow-other-keys-function-argument-form)
+ (extend-walk-env env :let (name argument) argument))))
+ (let ((state :required)
+ (arguments '()))
+ (dolist (argument lambda-list)
+ (if (member argument '(&optional &key &rest))
+ (setf state argument)
+ (progn
+ (push (case state
+ (:required
+ (if allow-specializers
+ (walk-specialized-argument-form argument parent env)
+ (walk-required-argument argument parent env)))
+ (&optional (walk-optional-argument argument parent env))
+ (&key
+ (if (eql '&allow-other-keys argument)
+ (make-instance 'allow-other-keys-function-argument-form
+ :parent parent :source argument)
+ (walk-keyword-argument argument parent env)))
+ (&rest (walk-rest-argument argument parent env)))
+ arguments)
+ (extend-env (car arguments)))))
+ (values (nreverse arguments) env))))
+
+(defclass function-argument-form (form)
+ ((name :accessor name :initarg :name)))
+
+(defmethod print-object ((argument function-argument-form) stream)
+ (print-unreadable-object (argument stream :type t :identity t)
+ (if (slot-boundp argument 'name)
+ (format stream "~S" (name argument))
+ (write-string "#<unbound name>" stream))))
+
+(defclass required-function-argument-form (function-argument-form)
+ ())
+
+(defgeneric required-function-argument-form-p (object)
+ (:method ((object t)) nil)
+ (:method ((object required-function-argument-form)) t))
+
+(defun walk-required-argument (form parent env)
+ (declare (ignore env))
+ (make-instance 'required-function-argument-form
+ :name form
+ :parent parent :source form))
+
+(defclass specialized-function-argument-form (required-function-argument-form)
+ ((specializer :accessor specializer :initarg :specializer)))
+
+(defun walk-specialized-argument-form (form parent env)
+ (declare (ignore env))
+ (make-instance 'specialized-function-argument-form
+ :name (if (listp form)
+ (first form)
+ form)
+ :specializer (if (listp form)
+ (second form)
+ 'T)
+ :parent parent
+ :source form))
+
+(defclass optional-function-argument-form (function-argument-form)
+ ((default-value :accessor default-value :initarg :default-value)
+ (supplied-p-parameter :accessor supplied-p-parameter :initarg :supplied-p-parameter)))
+
+(defun walk-optional-argument (form parent env)
+ (destructuring-bind (name &optional default-value supplied-p-parameter)
+ (ensure-list form)
+ (with-form-object (arg optional-function-argument-form
+ :parent parent
+ :source form
+ :name name
+ :supplied-p-parameter supplied-p-parameter)
+ (setf (default-value arg) (walk-form default-value arg env)))))
+
+(defclass keyword-function-argument-form (function-argument-form)
+ ((keyword-name :accessor keyword-name :initarg :keyword-name)
+ (default-value :accessor default-value :initarg :default-value)
+ (supplied-p-parameter :accessor supplied-p-parameter :initarg :supplied-p-parameter)))
+
+(defmethod effective-keyword-name ((k keyword-function-argument-form))
+ (or (keyword-name k)
+ (intern (symbol-name (name k)) :keyword)))
+
+(defun walk-keyword-argument (form parent env)
+ (destructuring-bind (name &optional default-value supplied-p-parameter)
+ (ensure-list form)
+ (let ((name (if (consp name)
+ (second name)
+ name))
+ (keyword (if (consp name)
+ (first name)
+ nil)))
+ (with-form-object (arg keyword-function-argument-form
+ :parent parent
+ :source form
+ :name name
+ :keyword-name keyword
+ :supplied-p-parameter supplied-p-parameter)
+ (setf (default-value arg) (walk-form default-value arg env))))))
+
+(defclass allow-other-keys-function-argument-form (function-argument-form)
+ ())
+
+(defclass rest-function-argument-form (function-argument-form)
+ ())
+
+(defun walk-rest-argument (form parent env)
+ (declare (ignore env))
+ (make-instance 'rest-function-argument-form :name form
+ :parent parent :source form))
+
+;;;; BLOCK/RETURN-FROM
+
+(defclass block-form (form implicit-progn-mixin)
+ ((name :accessor name :initarg :name)))
+
+(defclass return-from-form (form)
+ ((target-block :accessor target-block :initarg :target-block)
+ (result :accessor result :initarg :result)))
+
+(defwalker-handler block (form parent env)
+ (destructuring-bind (block-name &rest body)
+ (cdr form)
+ (with-form-object (block block-form
+ :parent parent :source form
+ :name block-name)
+ (setf (body block) (walk-implict-progn block
+ body
+ (register-walk-env env :block block-name block))))))
+
+(define-condition return-from-unknown-block (error)
+ ((block-name :accessor block-name :initarg :block-name))
+ (:report (lambda (condition stream)
+ (format stream "Unable to return from block named ~S." (block-name condition)))))
+
+(defwalker-handler return-from (form parent env)
+ (destructuring-bind (block-name &optional (value '(values)))
+ (cdr form)
+ (if (lookup-walk-env env :block block-name)
+ (with-form-object (return-from return-from-form :parent parent :source form
+ :target-block (lookup-walk-env env :block block-name))
+ (setf (result return-from) (walk-form value return-from env)))
+ (restart-case
+ (error 'return-from-unknown-block :block-name block-name)
+ (add-block ()
+ :report "Add this block and continue."
+ (walk-form form parent (register-walk-env env :block block-name :unknown-block)))))))
+
+;;;; CATCH/THROW
+
+(defclass catch-form (form implicit-progn-mixin)
+ ((tag :accessor tag :initarg :tag)))
+
+(defclass throw-form (form)
+ ((tag :accessor tag :initarg :tag)
+ (value :accessor value :initarg :value)))
+
+(defwalker-handler catch (form parent env)
+ (destructuring-bind (tag &body body)
+ (cdr form)
+ (with-form-object (catch catch-form :parent parent :source form)
+ (setf (tag catch) (walk-form tag catch env)
+ (body catch) (walk-implict-progn catch body env)))))
+
+(defwalker-handler throw (form parent env)
+ (destructuring-bind (tag &optional (result '(values)))
+ (cdr form)
+ (with-form-object (throw throw-form :parent parent :source form)
+ (setf (tag throw) (walk-form tag throw env)
+ (value throw) (walk-form result throw env)))))
+
+;;;; EVAL-WHEN
+
+(defclass eval-when-form (form implicit-progn-mixin)
+ ((eval-when-times :accessor eval-when-times :initarg :eval-when-times)))
+
+(defwalker-handler eval-when (form parent env)
+ (destructuring-bind (times &body body)
+ (cdr form)
+ (with-form-object (eval-when eval-when-form :parent parent :source form)
+ (setf (eval-when-times eval-when) times
+ (body eval-when) (walk-implict-progn eval-when body env)))))
+
+;;;; IF
+
+(defclass if-form (form)
+ ((consequent :accessor consequent :initarg :consequent)
+ (then :accessor then :initarg :then)
+ (else :accessor else :initarg :else)))
+
+(defwalker-handler if (form parent env)
+ (with-form-object (if if-form :parent parent :source form)
+ (setf (consequent if) (walk-form (second form) if env)
+ (then if) (walk-form (third form) if env)
+ (else if) (walk-form (fourth form) if env))))
+
+;;;; FLET/LABELS
+
+(defclass function-binding-form (form binding-form-mixin implicit-progn-with-declare-mixin)
+ ())
+
+(defclass flet-form (function-binding-form)
+ ())
+
+(defclass labels-form (function-binding-form)
+ ())
+
+(defwalker-handler flet (form parent env)
+ (destructuring-bind (binds &body body)
+ (cdr form)
+ (with-form-object (flet flet-form :parent parent :source form)
+ ;;;; build up the objects for the bindings in the original env
+ (loop
+ for (name args . body) in binds
+ collect (cons name (walk-form `(lambda ,args , at body) flet env)) into bindings
+ finally (setf (binds flet) bindings))
+ ;;;; walk the body in the new env
+ (multiple-value-setf ((body flet) nil (declares flet))
+ (walk-implict-progn flet
+ body
+ (loop
+ with env = env
+ for (name . lambda) in (binds flet)
+ do (extend-walk-env env :flet name lambda)
+ finally (return env))
+ :declare t)))))
+
+(defwalker-handler labels (form parent env)
+ (destructuring-bind (binds &body body)
+ (cdr form)
+ (with-form-object (labels labels-form :parent parent :source form :binds '())
+ ;; we need to walk over the bindings twice. the first pass
+ ;; creates some 'empty' lambda objects in the environment so
+ ;; that local-application-form and local-function-object-form
+ ;; have something to point to. the second pass then walks the
+ ;; actual bodies of the form filling in the previously created
+ ;; objects.
+ (loop
+ for (name arguments . body) in binds
+ for lambda = (make-instance 'lambda-function-form
+ :parent labels
+ :source (list* name arguments body))
+ do (push (cons name lambda) (binds labels))
+ do (extend-walk-env env :flet name lambda))
+ (setf (binds labels) (nreverse (binds labels)))
+ (loop
+ for form in binds
+ for (arguments . body) = (cdr form)
+ for binding in (binds labels)
+ for lambda = (cdr binding)
+ for tmp-lambda = (walk-lambda `(lambda ,arguments , at body) labels env)
+ do (setf (body lambda) (body tmp-lambda)
+ (arguments lambda) (arguments tmp-lambda)
+ (declares lambda) (declares tmp-lambda)))
+ (multiple-value-setf ((body labels) nil (declares labels)) (walk-implict-progn labels body env :declare t)))))
+
+;;;; LET/LET*
+
+(defclass variable-binding-form (form binding-form-mixin implicit-progn-with-declare-mixin)
+ ())
+
+(defclass let-form (variable-binding-form)
+ ())
+
+(defwalker-handler let (form parent env)
+ (with-form-object (let let-form :parent parent :source form)
+ (setf (binds let) (mapcar (lambda (binding)
+ (destructuring-bind (var &optional initial-value)
+ (ensure-list binding)
+ (cons var (walk-form initial-value let env))))
+ (second form)))
+ (multiple-value-bind (b e d declarations)
+ (split-body (cddr form) env :parent let :declare t)
+ (declare (ignore b e d))
+ (dolist* ((var . value) (binds let))
+ (declare (ignore value))
+ (if (not (find-if (lambda (declaration)
+ (and (typep declaration 'special-declaration-form)
+ (eq var (name declaration)))) declarations))
+ (extend-walk-env env :let var :dummy)))
+ (multiple-value-setf ((body let) nil (declares let))
+ (walk-implict-progn let (cddr form) env :declare t)))))
+
+(defclass let*-form (variable-binding-form)
+ ())
+
+(defwalker-handler let* (form parent env)
+ (with-form-object (let* let*-form :parent parent :source form :binds '())
+ (dolist* ((var &optional initial-value) (mapcar #'ensure-list (second form)))
+ (push (cons var (walk-form initial-value let* env)) (binds let*))
+ (extend-walk-env env :let var :dummy))
+ (setf (binds let*) (nreverse (binds let*)))
+ (multiple-value-setf ((body let*) nil (declares let*)) (walk-implict-progn let* (cddr form) env :declare t))))
+
+;;;; LOAD-TIME-VALUE
+
+(defclass load-time-value-form (form)
+ ((value :accessor value)
+ (read-only-p :accessor read-only-p)))
+
+(defwalker-handler load-time-value (form parent env)
+ (with-form-object (load-time-value load-time-value-form
+ :parent parent :source form)
+ (setf (value load-time-value) (walk-form (second form) load-time-value env)
+ (read-only-p load-time-value) (third form))))
+
+;;;; LOCALLY
+
+(defclass locally-form (form implicit-progn-with-declare-mixin)
+ ())
+
+(defwalker-handler locally (form parent env)
+ (with-form-object (locally locally-form :parent parent :source form)
+ (multiple-value-setf ((body locally) nil (declares locally)) (walk-implict-progn locally (cdr form) env :declare t))))
+
+;;;; MACROLET
+
+(defclass macrolet-form (form binding-form-mixin implicit-progn-with-declare-mixin)
+ ())
+
+(defwalker-handler macrolet (form parent env)
+ (with-form-object (macrolet macrolet-form :parent parent :source form
+ :binds '())
+ (dolist* ((name args &body body) (second form))
+ (let ((handler (parse-macro-definition name args body (cdr env))))
+ (extend-walk-env env :macrolet name handler)
+ (push (cons name handler) (binds macrolet))))
+ (setf (binds macrolet) (nreverse (binds macrolet)))
+ (multiple-value-setf ((body macrolet) nil (declares macrolet))
+ (walk-implict-progn macrolet (cddr form) env :declare t))))
+
+;;;; MULTIPLE-VALUE-CALL
+
+(defclass multiple-value-call-form (form)
+ ((func :accessor func :initarg :func)
+ (arguments :accessor arguments :initarg :arguments)))
+
+(defwalker-handler multiple-value-call (form parent env)
+ (with-form-object (m-v-c multiple-value-call-form :parent parent :source form)
+ (setf (func m-v-c) (walk-form (second form) m-v-c env)
+ (arguments m-v-c) (mapcar (lambda (f) (walk-form f m-v-c env))
+ (cddr form)))))
+
+;;;; MULTIPLE-VALUE-PROG1
+
+(defclass multiple-value-prog1-form (form)
+ ((first-form :accessor first-form :initarg :first-form)
+ (other-forms :accessor other-forms :initarg :other-forms)))
+
+(defwalker-handler multiple-value-prog1 (form parent env)
+ (with-form-object (m-v-p1 multiple-value-prog1-form :parent parent :source form)
+ (setf (first-form m-v-p1) (walk-form (second form) m-v-p1 env)
+ (other-forms m-v-p1) (mapcar (lambda (f) (walk-form f m-v-p1 env))
+ (cddr form)))))
+
+;;;; PROGN
+
+(defclass progn-form (form implicit-progn-mixin)
+ ())
+
+(defwalker-handler progn (form parent env)
+ (with-form-object (progn progn-form :parent parent :source form)
+ (setf (body progn) (walk-implict-progn progn (cdr form) env))))
+
+;;;; PROGV
+
+(defclass progv-form (form implicit-progn-mixin)
+ ((vars-form :accessor vars-form :initarg :vars-form)
+ (values-form :accessor values-form :initarg :values-form)))
+
+(defwalker-handler progv (form parent env)
+ (with-form-object (progv progv-form :parent parent :source form)
+ (setf (vars-form progv) (walk-form (cadr form) progv env))
+ (setf (values-form progv) (walk-form (caddr form) progv env))
+ (setf (body progv) (walk-implict-progn progv (cdddr form) env))
+ progv))
+
+;;;; QUOTE
+
+(defwalker-handler quote (form parent env)
+ (make-instance 'constant-form :parent parent :source form :value (second form)))
+
+;;;; SETQ
+
+(defclass setq-form (form)
+ ((var :accessor var :initarg :var)
+ (value :accessor value :initarg :value)))
+
+(defwalker-handler setq (form parent env)
+ ;; the SETQ handler needs to be able to deal with symbol-macrolets
+ ;; which haven't yet been expanded and may expand into something
+ ;; requiring setf and not setq.
+ (let ((effective-code '()))
+ (loop
+ for (name value) on (cdr form) by #'cddr
+ if (lookup-walk-env env :symbol-macrolet name)
+ do (push `(setf ,(lookup-walk-env env :symbol-macrolet name) ,value) effective-code)
+ else
+ do (push `(setq ,name ,value) effective-code))
+ (if (= 1 (length effective-code))
+ ;; only one form, the "simple case"
+ (destructuring-bind (type var value)
+ (first effective-code)
+ (ecase type
+ (setq (with-form-object (setq setq-form :parent parent :source form
+ :var var)
+ (setf (value setq) (walk-form value setq env))))
+ (setf (walk-form (first effective-code) parent env))))
+ ;; multiple forms
+ (with-form-object (progn progn-form :parent parent :source form)
+ (setf (body progn) (walk-implict-progn progn effective-code env))))))
+
+;;;; SYMBOL-MACROLET
+
+(defclass symbol-macrolet-form (form binding-form-mixin implicit-progn-with-declare-mixin)
+ ())
+
+(defwalker-handler symbol-macrolet (form parent env)
+ (with-form-object (symbol-macrolet symbol-macrolet-form :parent parent :source form
+ :binds '())
+ (dolist* ((symbol expansion) (second form))
+ (extend-walk-env env :symbol-macrolet symbol expansion)
+ (push (cons symbol expansion) (binds symbol-macrolet)))
+ (setf (binds symbol-macrolet) (nreverse (binds symbol-macrolet)))
+ (multiple-value-setf ((body symbol-macrolet) nil (declares symbol-macrolet))
+ (walk-implict-progn symbol-macrolet (cddr form) env :declare t))))
+
+;;;; TAGBODY/GO
+
+(defclass tagbody-form (form implicit-progn-mixin)
+ ())
+
+(defclass go-tag-form (form)
+ ((name :accessor name :initarg :name)))
+
+(defgeneric go-tag-form-p (object)
+ (:method ((object go-tag-form)) t)
+ (:method ((object t)) nil))
+
+(defwalker-handler tagbody (form parent env)
+ (with-form-object (tagbody tagbody-form :parent parent :source form :body (cdr form))
+ (extend-walk-env env :tagbody 'enclosing-tagbody tagbody)
+ (flet ((go-tag-p (form)
+ (or (symbolp form) (integerp form))))
+ ;; the loop below destructuivly modifies the body of tagbody,
+ ;; since it's the same object as the source we need to copy it.
+ (setf (body tagbody) (copy-list (body tagbody)))
+ (loop
+ for part on (body tagbody)
+ if (go-tag-p (car part))
+ do (extend-walk-env env :tag (car part) (cdr part)))
+ (loop
+ for part on (body tagbody)
+ if (go-tag-p (car part))
+ do (setf (car part) (make-instance 'go-tag-form :parent tagbody
+ :source (car part)
+ :name (car part)))
+ else
+ do (setf (car part) (walk-form (car part) tagbody env))))))
+
+(defclass go-form (form)
+ ((target-progn :accessor target-progn :initarg :target-progn)
+ (name :accessor name :initarg :name)
+ (enclosing-tagbody :accessor enclosing-tagbody :initarg :enclosing-tagbody)))
+
+(defwalker-handler go (form parent env)
+ (make-instance 'go-form
+ :parent parent
+ :source form
+ :name (second form)
+ :target-progn (lookup-walk-env env :tag (second form))
+ :enclosing-tagbody (lookup-walk-env env :tagbody 'enclosing-tagbody)))
+
+;;;; THE
+
+(defclass the-form (form)
+ ((type-form :accessor type-form :initarg :type-form)
+ (value :accessor value :initarg :value)))
+
+(defwalker-handler the (form parent env)
+ (with-form-object (the the-form :parent parent :source form
+ :type-form (second form))
+ (setf (value the) (walk-form (third form) the env))))
+
+;;;; UNWIND-PROTECT
+
+(defclass unwind-protect-form (form)
+ ((protected-form :accessor protected-form :initarg :protected-form)
+ (cleanup-form :accessor cleanup-form :initarg :cleanup-form)))
+
+(defwalker-handler unwind-protect (form parent env)
+ (with-form-object (unwind-protect unwind-protect-form :parent parent
+ :source form)
+ (setf (protected-form unwind-protect) (walk-form (second form) unwind-protect env)
+ (cleanup-form unwind-protect) (walk-implict-progn unwind-protect (cddr form) env))))
+
+;;;; LOAD-TIME-VALUE
+
+(defclass load-time-value-form (form)
+ ((body :accessor body :initarg :body)
+ (read-only :initform nil :accessor read-only-p :initarg :read-only)
+ (value :accessor value)))
+
+(defmethod initialize-instance :after ((self load-time-value-form) &key)
+ (setf (value self) (eval (body self))))
+
+(defwalker-handler load-time-value (form parent env)
+ (assert (<= (length form) 3))
+ (with-form-object (load-time-value load-time-value-form :parent parent
+ :body form
+ :read-only (third form))
+ (setf (body load-time-value) (second form))))
+
+;;;; ** Implementation specific walkers
+
+;;;; These are for forms which certain compilers treat specially but
+;;;; aren't macros or special-operators.
+
+#+lispworks
+(defwalker-handler compiler::internal-the (form parent env)
+ (walk-form (third form) parent env))
+
+;; Copyright (c) 2005-2006, Edward Marco Baringer
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;; - Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;;
+;; - Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;;
+;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;; of its contributors may be used to endorse or promote products
+;; derived from this software without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Added: branches/trunk-reorg/thirdparty/arnesi/t/accumulation.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/t/accumulation.lisp Mon Feb 11 08:38:43 2008
@@ -0,0 +1,17 @@
+;;;; -*- lisp -*-
+
+(in-package :it.bese.arnesi.test)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (def-suite :it.bese.arnesi.accumulation :in :it.bese.arnesi))
+
+(in-suite :it.bese.arnesi.accumulation)
+
+(test make-reducer
+
+ (let ((r (make-reducer #'+ 0)))
+ (funcall r 0)
+ (funcall r 1 2)
+ (funcall r 1 2 3)
+ (is (= 9 (funcall r)))))
+
Added: branches/trunk-reorg/thirdparty/arnesi/t/call-cc.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/t/call-cc.lisp Mon Feb 11 08:38:43 2008
@@ -0,0 +1,530 @@
+;;;; -*- lisp -*-
+
+(in-package :it.bese.arnesi.test)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (def-suite :it.bese.arnesi.call/cc :in :it.bese.arnesi))
+
+(in-suite :it.bese.arnesi.call/cc)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (setf *call/cc-returns* nil))
+
+(test call/cc-constant
+ (is (= 4 (with-call/cc 4)))
+ (is (eql :a (with-call/cc :a)))
+ (is (eql 'a (with-call/cc 'a)))
+ (is (eql #'+ (with-call/cc #'+))))
+
+(test call/cc-progn
+ (is (null (with-call/cc)))
+ (is (= 1 (with-call/cc 1)))
+ (is (= 2 (with-call/cc 1 2)))
+ (is (= 3 (with-call/cc 1 2 3)))
+ (is (= 4 (with-call/cc 1 2 3 4))))
+
+(test call/cc-progn/cc
+ (is (= 1 (kall (with-call/cc (let/cc k k) 1))))
+ (is (= 1 (kall (with-call/cc (let/cc k k) 0 1)))))
+
+(test call/cc-let
+ (is (= 1 (with-call/cc
+ (let () 1))))
+ (is (= 1 (with-call/cc
+ (let ((a 1)) a))))
+ (is (= 1 (with-call/cc
+ (let ((a 1))
+ (let ((a nil)
+ (b a))
+ (declare (ignore a))
+ b)))))
+ (with-call/cc
+ (let ((a 1))
+ (let ((a 2))
+ (is (= 2 a)))
+ (is (= 1 a))))
+
+ (let ((cont nil))
+ (setf cont
+ (with-call/cc
+ (let ((a (let/cc k k)))
+ (+ a 4))))
+ (is (= 9 (kall cont 5)))
+ (is (= 12 (kall cont 8)))))
+
+(test call/cc-let/cc
+ (let ((k (with-call/cc
+ (let ((a (arnesi::retk)))
+ (+ a 1)))))
+ (is (= 1 (arnesi::kall k 0)))
+ (is (= 2 (arnesi::kall k 1)))))
+
+(test call/cc-setq
+ (is (= 1 (with-call/cc
+ (let ((a nil)) (setq a 1)))))
+ (is (= 2 (with-call/cc
+ (let ((a 1)) (setq a (1+ a)))))))
+
+(test call/cc-let*
+ (with-call/cc
+ (let* ((a 1)
+ (b a))
+ (is (= 1 a))
+ (is (= 1 b))))
+ (with-call/cc
+ (let ((a 0)
+ (b 1))
+ (declare (ignore a))
+ (let* ((a b)
+ (b a))
+ (is (= a 1))
+ (is (= b 1))
+ (setq a 47)
+ (is (= a 47))))))
+
+(test call/cc-apply
+ (is (= 0 (with-call/cc (+))))
+ (is (= 1 (with-call/cc (+ 1))))
+ (is (= 2 (with-call/cc (+ 1 1))))
+ (is (= 3 (with-call/cc (+ 1 (+ 1 (+ 1 (+))))))))
+
+(test call/cc-if
+ (is (= 1 (with-call/cc (if t 1))))
+ (is (= 1 (with-call/cc (if nil 0 1))))
+ (is (null (with-call/cc (if nil 1)))))
+
+(test call/cc-block/return-from
+ (is (= 1
+ (with-call/cc
+ (block foo
+ nil
+ (return-from foo 1)
+ nil))))
+ (is (eql t
+ (with-call/cc
+ (block foo
+ (return-from foo t)
+ nil)))))
+
+(defun reached-unreachable-code ()
+ (fail "Somehow we reached unreachable code in a tagbody."))
+
+(test call/cc-tagbody
+ (with-call/cc
+ (tagbody
+ (go a)
+ (reached-unreachable-code)
+ a
+ (pass)))
+ (with-call/cc
+ (tagbody
+ (go a) (reached-unreachable-code)
+ b
+ (pass)
+ (go c) (reached-unreachable-code)
+ a
+ (pass)
+ (go b) (reached-unreachable-code)
+ c
+ (pass)))
+ (with-call/cc
+ (let ((counter 0))
+ (dotimes (i 5)
+ (incf counter))
+ (is (= 5 counter))))
+ (with-call/cc
+ (let ((i 0))
+ (tagbody
+ a (incf i) (is (= 1 i))
+ b (incf i) (is (= 2 i))
+ c (is (= 2 i))))))
+
+(test call/cc-flet
+ (with-call/cc
+ (flet ((foo () 'x))
+ (is (eql 'x (foo))))
+ (is (= 4 (funcall (let ((a 4))
+ (flet ((foo () a))
+ #'foo)))))
+ (flet ((foo ()
+ 'outer-foo))
+ (flet ((foo ()
+ 'inner-foo)
+ (bar ()
+ (foo)))
+ (is (eql 'outer-foo (bar)))))))
+
+(test call/cc-labels
+ (with-call/cc
+ (labels ((foo () 'x))
+ (is (eql 'x (foo))))
+ (labels ((foo () 'outer-foo))
+ (labels ((bar () (foo))
+ (foo () 'inner-foo))
+ (is (eql 'inner-foo (bar))))))
+ (finishes
+ (with-call/cc
+ (labels ((rec (x) x))
+ #'rec
+ (is (= 1 (funcall #'rec 1)))
+ (is (= 1 (apply #'rec (list 1)))))
+ (flet ((f () 1))
+ (is (= 1 (f)))
+ (is (= 1 (funcall #'f)))
+ (is (= 1 (apply #'f '()))))))
+ (let ((cont (with-call/cc
+ (labels ((rec (n)
+ (if (zerop n)
+ 0
+ (+ (rec (1- n))
+ (let/cc k k)))))
+ (rec 2)))))
+ (is (= 5 (kall (kall cont 2) 3)))))
+
+(let ((value 0))
+ (defun test-funcall.0 ()
+ value)
+ (defun (setf test-funcall.0) (new-value)
+ (setf value new-value)))
+
+(test call/cc-setf-funcall
+ (setf (test-funcall.0) 0)
+ (is (= 0 (with-call/cc (test-funcall.0))))
+ (is (= 1 (with-call/cc (setf (test-funcall.0) 1))))
+ (is (= 2 (with-call/cc (funcall #'(setf test-funcall.0) 2)))))
+
+(test call/cc-lambda-requried-arguments
+ (with-call/cc
+ (is (eql t (funcall (lambda () t))))
+ (is (eql t (funcall (lambda (x) x) t))))
+ (signals error
+ (with-call/cc
+ (funcall (lambda (x) x)))))
+
+(test call/cc-lambda-optional-arguments
+ (with-call/cc
+ (is (eql t (funcall (lambda (&optional a) a) t)))
+ (is (eql t (funcall (lambda (&optional (a t)) a)))))
+
+ (let ((cont (with-call/cc
+ (funcall (lambda (&optional (a (let/cc k k)))
+ (+ a 1))))))
+ (is (= 1 (kall cont 0)))))
+
+(test call/cc-lambda-keyword-arguments
+ (with-call/cc
+ (is (eql 'a (funcall (lambda (&key a) a) :a 'a)))
+ (is (eql 'b (funcall (lambda (&key (a 'b)) a))))
+ (is (eql t (funcall (lambda (&optional a &key (b (not a))) b))))
+ (is (eql nil (funcall (lambda (&optional a &key (b (not a)))
+ b)
+ t)))
+ (is (eql 42 (funcall (lambda (&optional a &key (b (not a)))
+ b)
+ t :b 42)))))
+
+(defun/cc test-defun/cc1 ()
+ (let/cc k k))
+
+(defun/cc test-defun/cc2 (arg1)
+ (let/cc k k)
+ arg1)
+
+(defun/cc test-defun/cc3 (a &key (b 1))
+ (+ a b))
+
+(test call/cc-defun/cc
+ (let ((cont nil))
+ (setf cont (with-call/cc (test-defun/cc1)))
+ (is (eql nil (kall cont nil)))
+
+ (setf cont (with-call/cc (test-defun/cc2 'foo)))
+ (is (eql 'foo (kall cont)))
+ (is (eql 'foo (kall cont nil)))
+
+ (with-call/cc
+ (is (= 1 (test-defun/cc3 0)))
+ (is (= 2 (test-defun/cc3 1))))))
+
+(defgeneric/cc test-generic/cc (a &key v))
+
+(defmethod/cc test-generic/cc ((a symbol) &key (v 3))
+ v)
+
+(defmethod/cc test-generic/cc ((a string) &key (v 5))
+ v)
+
+(test call/cc-defgeneric/cc
+ (with-call/cc
+ (is (= 3 (test-generic/cc 'a)))
+ (is (= 0 (test-generic/cc 'a :v 0)))
+ (is (= 5 (test-generic/cc "a")))
+ (is (= 0 (test-generic/cc "a" :v 0)))))
+
+(defmethod/cc test-generic/cc2 :before (a)
+ (let/cc k 'before))
+
+(defmethod/cc test-generic/cc2 (a)
+ 'primary)
+
+(test test-generic/cc2
+ (with-call/cc
+ (is (eql 'before (test-generic/cc2 t)))))
+
+(defmethod/cc test-generic/cc3 :before (a)
+ (let/cc k (cons 'before k)))
+
+(defmethod/cc test-generic/cc3 :around (a)
+ (let/cc k (cons 'around k))
+ (call-next-method a))
+
+(defmethod/cc test-generic/cc3 (a)
+ (let/cc k (cons 'primary k))
+ a)
+
+(defmethod/cc test-generic/cc3 :after (a)
+ (let/cc k (cons 'after k)))
+
+(test call/cc-defgeneric/cc3
+ (destructuring-bind (value . cont)
+ (with-call/cc (test-generic/cc3 32))
+ (is (eql 'around value))
+ (destructuring-bind (value . cont)
+ (with-call/cc (kall cont))
+ (is (eql 'before value))
+ (destructuring-bind (value . cont)
+ (with-call/cc (kall cont))
+ (is (eql 'primary value))
+ (destructuring-bind (value . cont)
+ (with-call/cc (kall cont))
+ (is (eql 'after value))
+ (is (eql 32 (kall cont))))))))
+
+(test call/cc-loop
+ (let ((cont (with-call/cc
+ (loop
+ repeat 2
+ sum (let/cc k k) into total
+ finally (return (values total total))))))
+ (multiple-value-bind (a b)
+ (kall (kall cont 1) 2)
+ (is (= 3 a))
+ (is (= 3 b))))
+
+ (let ((cont (with-call/cc
+ (block done
+ (loop
+ for how-many = (let/cc k k)
+ do (loop
+ repeat how-many
+ sum (let/cc k k) into total
+ finally (return-from done total)))))))
+ (is (= 26 (kall (kall (kall cont 2) 13) 13)))))
+
+(test common-lisp/cc
+ (let (cont value)
+ (setf cont (with-call/cc (mapcar (lambda (x)
+ (+ x (let/cc k k)))
+ (list 1 2 3))))
+ (setf cont (with-call/cc (kall cont -1))
+ cont (with-call/cc (kall cont -2))
+ value (with-call/cc (kall cont -3)))
+ (is (equal (list 0 0 0) value))))
+
+(defun/cc throw-something (something)
+ (throw 'done something))
+
+(test catch/cc
+ (with-call/cc
+ (is (eql t
+ (catch 'whatever
+ (throw 'whatever t)
+ (throw 'whatever nil)
+ 'something-else)))
+ (is (eql t
+ (catch 'whatever
+ t)))
+ (is (eql t
+ (flet ((throw-it (it)
+ (throw 'done it)))
+ (catch 'done
+ (throw-it t)
+ (throw 'done 'bad-bad-bad)))))
+ (is (eql t
+ (catch 'done
+ (throw-something t)
+ nil)))))
+
+(test multiple-value-call
+ (with-call/cc
+ (is (= 1 (multiple-value-call
+ #'identity
+ (values 1)))))
+ (with-call/cc
+ (is (= 3 (length (multiple-value-call
+ #'list
+ (values 1)
+ (values 1)
+ (values 1))))))
+
+ (with-call/cc
+ (is (= 3 (multiple-value-call
+ (lambda (a b)
+ (+ a b))
+ (values 1 2)))))
+
+ (with-call/cc
+ (is (= 3 (multiple-value-call
+ (lambda (&rest numbers)
+ (reduce #'+ numbers))
+ (values -1 1)
+ (values 1)
+ (values -1)
+ (values 1 2))))))
+
+;;; speical variable handling
+(defun/cc lookup-special-in-defun/cc (stop)
+ (declare (special var))
+ (when stop (let/cc k k))
+ var)
+
+(defun/cc lookup-special-in-let/cc (stop)
+ (let ((normal 0))
+ (declare (special var))
+ (when stop (let/cc k k))
+ var))
+
+(defun/cc lookup-special-in-let*/cc (stop)
+ (let* ((normal 0))
+ (declare (special var))
+ (when stop (let/cc k k))
+ var))
+
+(defun lookup-special-in-lisp ()
+ (declare (special var))
+ var)
+
+(defun/cc define-and-lookup-special-in-defun/cc (stop)
+ (let ((var 1))
+ (declare (special var))
+ (when stop (let/cc k k))
+ var))
+
+(defun/cc export-special-from-let/cc-and-lookup-in-defun/cc (stop)
+ (let ((var 1))
+ (declare (special var))
+ (lookup-special-in-defun/cc stop)))
+
+(defun/cc export-special-from-let/cc-and-lookup-in-let/cc (stop)
+ (let ((var 1))
+ (declare (special var))
+ (lookup-special-in-let/cc stop)))
+
+(defun/cc export-special-from-let/cc-and-lookup-in-let*/cc (stop)
+ (let ((var 1))
+ (declare (special var))
+ (lookup-special-in-let*/cc stop)))
+
+(defun/cc export-special-from-let/cc-and-lookup-in-lisp (stop)
+ (let ((var 1))
+ (declare (special var))
+ (when stop (let/cc k k))
+ (lookup-special-in-lisp)))
+
+(defun/cc export-special-from-let*/cc-and-lookup-in-defun/cc (stop)
+ (let* ((var 1))
+ (declare (special var))
+ (lookup-special-in-defun/cc stop)))
+
+(defun/cc export-special-from-let*/cc-and-lookup-in-let/cc (stop)
+ (let* ((var 1))
+ (declare (special var))
+ (lookup-special-in-let/cc stop)))
+
+(defun/cc export-special-from-let*/cc-and-lookup-in-let*/cc (stop)
+ (let* ((var 1))
+ (declare (special var))
+ (lookup-special-in-let*/cc stop)))
+
+(defun/cc export-special-from-let*/cc-and-lookup-in-lisp (stop)
+ (let* ((var 1))
+ (declare (special var))
+ (when stop (let/cc k k))
+ (lookup-special-in-lisp)))
+
+(defun export-special-from-lisp-and-lookup-in-defun/cc (stop)
+ (let ((var 1))
+ (declare (special var))
+ (with-call/cc
+ (lookup-special-in-defun/cc stop))))
+
+(defun export-special-from-lisp-and-lookup-in-let/cc (stop)
+ (let ((var 1))
+ (declare (special var))
+ (with-call/cc
+ (lookup-special-in-let/cc stop))))
+
+(defun export-special-from-lisp-and-lookup-in-let*/cc (stop)
+ (let ((var 1))
+ (declare (special var))
+ (with-call/cc
+ (lookup-special-in-let*/cc stop))))
+
+(defmacro test-special (name)
+ (let ((body-without-stop `(,name nil))
+ (body-with-stop `(,name t)))
+ `(test ,name
+ (is (= 1 (with-call/cc ,body-without-stop)))
+ (signals unbound-variable
+ (with-call/cc ,body-without-stop (lookup-special-in-lisp)))
+ (signals unbound-variable
+ (with-call/cc ,body-without-stop (lookup-special-in-defun/cc nil)))
+ ;; now stop once
+ (is (= 1 (kall (with-call/cc ,body-with-stop))))
+ (signals unbound-variable
+ (kall (with-call/cc ,body-with-stop (lookup-special-in-lisp))))
+ (signals unbound-variable
+ (kall (with-call/cc ,body-with-stop (lookup-special-in-defun/cc nil)))))))
+
+;; export and lookup in the same lexical environment
+(test-special define-and-lookup-special-in-defun/cc)
+
+;; export and lookup in cc code
+(test-special export-special-from-let/cc-and-lookup-in-defun/cc)
+(test-special export-special-from-let/cc-and-lookup-in-let/cc)
+(test-special export-special-from-let/cc-and-lookup-in-let*/cc)
+(test-special export-special-from-let*/cc-and-lookup-in-defun/cc)
+(test-special export-special-from-let*/cc-and-lookup-in-let/cc)
+(test-special export-special-from-let*/cc-and-lookup-in-let*/cc)
+
+;; export from cc code and lookup in lisp code
+(test-special export-special-from-let/cc-and-lookup-in-lisp)
+(test-special export-special-from-let*/cc-and-lookup-in-lisp)
+
+;; export from lisp code and lookup in cc code
+(test-special export-special-from-lisp-and-lookup-in-defun/cc)
+(test-special export-special-from-lisp-and-lookup-in-let/cc)
+(test-special export-special-from-lisp-and-lookup-in-let*/cc)
+
+;; export in lisp code let it go through some cc code and lookup in lisp code after continuing
+(test export-special-from-lisp-and-lookup-in-lisp
+ (is (= 1
+ (kall (let ((var 1))
+ (declare (special var))
+ (with-call/cc
+ (let () ;; TODO: shouldn't we allow declares within with-call/cc?
+ (declare (special var))
+ (let/cc k k)
+ (lookup-special-in-lisp))))))))
+
+(defvar *special-variable-in-lisp* 42)
+
+(test special-lisp-var-rebound-in/cc
+ (is (= 42
+ (with-call/cc
+ *special-variable-in-lisp*)))
+ (is (= 43
+ (with-call/cc
+ (let ((*special-variable-in-lisp* 43))
+ ;;(declare (special *special-variable-in-lisp*)) ; TODO shouldn't be needed
+ *special-variable-in-lisp*)))))
Added: branches/trunk-reorg/thirdparty/arnesi/t/csv.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/t/csv.lisp Mon Feb 11 08:38:43 2008
@@ -0,0 +1,24 @@
+;;;; -*- lisp -*-
+
+(in-package :it.bese.arnesi.test)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (def-suite :it.bese.arnesi.csv :in :it.bese.arnesi))
+
+(in-suite :it.bese.arnesi.csv)
+
+(test csv.1
+ (is (equal '("1" "2" "3")
+ (arnesi:parse-csv-string "1,2,3")))
+ (is (equal '("1" "2" "3")
+ (arnesi:parse-csv-string "1;2;3" :separator #\;)))
+ (is (equal '("1" "2;" "3")
+ (arnesi:parse-csv-string "1;'2;';3" :separator #\; :quote #\'))))
+
+(test csv.2
+ ;; this corresponds to the quoting used in princ-csv
+ (is (equal '("1" "2'" "3")
+ (arnesi:parse-csv-string "1;'2''';3" :separator #\; :quote #\')))
+ (is (equal '("1" "2'" "3")
+ (arnesi:parse-csv-string "1;'2''';'3'" :separator #\; :quote #\'))))
+
Added: branches/trunk-reorg/thirdparty/arnesi/t/flow-control.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/t/flow-control.lisp Mon Feb 11 08:38:43 2008
@@ -0,0 +1,89 @@
+;;;; -*- lisp -*-
+
+(in-package :it.bese.arnesi.test)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (def-suite :it.bese.arnesi.flow-control :in :it.bese.arnesi))
+
+(in-suite :it.bese.arnesi.flow-control)
+
+(test flow-control
+ (let ((ht (make-hash-table)))
+ (setf (gethash 'a ht) 1)
+ (setf (gethash 'b ht) 'a)
+
+ ;; if-bind and aif
+ (is (= 3 (if-bind var (gethash 'z ht) (1+ var) 3)))
+ (is (= 2 (if-bind var (gethash 'a ht) (1+ var) 3)))
+ (is (= 3 (aif (gethash 'z ht) (1+ it) 3)))
+ (is (= 2 (aif (gethash 'a ht) (1+ it) 3)))
+ ;; when-bind and awhen
+ (let ((result nil))
+ (when-bind var (gethash 'z ht)
+ (setf result (1+ var)))
+ (is (null result))
+ (when-bind var (gethash 'a ht)
+ (setf result (1+ var)))
+ (is (= 2 result))
+ (setf result nil)
+ (awhen (gethash 'z ht)
+ (setf result (1+ it)))
+ (is (null result))
+ (awhen (gethash 'a ht)
+ (setf result (1+ it)))
+ (is (= 2 result)))
+ ;; cond-bind and acond
+ (is (= 99 (cond-bind var
+ ((gethash 'z ht) (1+ var))
+ ((gethash 'y ht) (1+ var))
+ (t 99))))
+ (is (= 2 (cond-bind var
+ ((gethash 'z ht) (1+ var))
+ ((gethash 'a ht) (1+ var))
+ (t 99))))
+ (is (= 1 (cond-bind var
+ ((gethash 'z ht))
+ ((gethash 'y ht))
+ ((gethash 'a ht))
+ (t 99))))
+ (is (= 99 (acond
+ ((gethash 'z ht) (1+ it))
+ ((gethash 'y ht) (1+ it))
+ (t 99))))
+ (is (= 2 (acond
+ ((gethash 'z ht) (1+ it))
+ ((gethash 'a ht) (1+ it))
+ (t 99))))
+ (is (= 2 (acond
+ ((gethash 'z ht))
+ ((gethash 'a ht) (1+ it))
+ (t 99))))
+ ;; and-bind and aand
+ (is-false (and-bind var (gethash 'z ht) (gethash var ht) (1+ var)))
+ (is (= 2 (and-bind var (gethash 'b ht) (gethash var ht) (1+ var))))
+ (is-false (aand (gethash 'z ht) (gethash it ht) (1+ it)))
+ (is (= 2 (aand (gethash 'b ht) (gethash it ht) (1+ it))))
+ ;; whichever
+ (let ((result 0))
+ (is (member (whichever (progn (incf result) 'a)
+ (progn (incf result) 'b)
+ (progn (incf result) 'c))
+ '(a b c)))
+ (is (= 1 result)))
+ ;; xor
+ (let ((result 0))
+ (is (eq 'a (xor (progn (incf result) 'a)
+ (progn (incf result) nil)
+ (progn (incf result) nil))))
+ (is (= 3 result))
+ (setf result 0)
+ (is (eq 'a (xor (progn (incf result) nil)
+ (progn (incf result) 'a)
+ (progn (incf result) nil))))
+ (is (= 3 result))
+ (setf result 0)
+ (is-false (xor (progn (incf result) 'a)
+ (progn (incf result) 'b)
+ (progn (incf result) 'c)))
+ (is (= 2 result)))))
+
Added: branches/trunk-reorg/thirdparty/arnesi/t/http.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/t/http.lisp Mon Feb 11 08:38:43 2008
@@ -0,0 +1,38 @@
+;;;; -*- lisp -*-
+
+(in-package :it.bese.arnesi.test)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (def-suite :it.bese.arnesi.http :in :it.bese.arnesi))
+
+(in-suite :it.bese.arnesi.http)
+
+(test escape-uri
+ (for-all ((uri (gen-string :elements (gen-character :code-limit #16rffff))))
+ (is (string= uri (unescape-as-uri (escape-as-uri uri)))))
+
+ (is (string= (unescape-as-uri "a+b+c")
+ "a b c")))
+
+(defmacro help-test-bad-uri (uri expected-error)
+ `(progn
+ (signals ,expected-error
+ (unescape-as-uri ,uri))
+ (finishes
+ (unescape-as-uri-non-strict ,uri))
+ (let ((returned (unescape-as-uri-non-strict ,uri)))
+ (is (> (length returned) (* 0.5 (length ,uri)))) ; a big chunk should be returned
+ (is (string= (subseq returned 0 8) ; that is looking like a proper url
+ (subseq ,uri 0 8))))))
+
+(test unescape-uri/iso8859-1-instead-of-utf8
+ (help-test-bad-uri "http://router.advertising.se/?&CHANNEL_ID=1&SITE_KEY=Webbhotell%20f%F6r%20att%20placera%20en%20Tower%20server?&SITE_ALT_KEY=&SITE_URL=http%3A%2F%2Fwww.webmasternetwork.se%2Ff13t11622.html&REF=http%3A%2F%2Fwww.webmasternetwork.se%2Ff13.html"
+ error))
+
+(test unescape-uri/wrong-percentage-quoting
+ (help-test-bad-uri "http://ad.doubleclick.net/adi/N763.business_week_online/B1803870.12;sz=468x60;ord=%%REALREAND%%?"
+ expected-digit-uri-parse-error))
+
+(test unescape-uri/percentage-at-end
+ (help-test-bad-uri "http://groups.google.com/groups/adfetch?adid=zMKqMREAAAAwVvp0Nmmxmm2KqccSr5KzFSRgCP-avRN4YT0eROC0jw&hl=en&sabc=%23eeeeee&sabcg=239&siphc=%23999999&siphfc=%23ffffff&w=100%"
+ uri-parse-error))
Added: branches/trunk-reorg/thirdparty/arnesi/t/list.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/t/list.lisp Mon Feb 11 08:38:43 2008
@@ -0,0 +1,34 @@
+;;;; -*- lisp -*-
+
+(in-package :it.bese.arnesi.test)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (def-suite :it.bese.arnesi.list :in :it.bese.arnesi))
+
+(in-suite :it.bese.arnesi.list)
+
+(test proper-list-p
+ (is-true (proper-list-p '()))
+ (is-true (proper-list-p '(nil)))
+ (is-true (proper-list-p '(nil nil)))
+ (is-true (proper-list-p '(nil nil nil)))
+ (is-true (proper-list-p '(nil . nil)))
+ (is-true (proper-list-p '(nil nil . nil)))
+ (is-true (proper-list-p '(nil nil nil . nil)))
+ (is-false (proper-list-p 1))
+ (is-false (proper-list-p '(a . b)))
+ (let ((a (cons nil nil)))
+ (setf (cdr a) a)
+ (is-false (proper-list-p a)))
+ (let ((a (list nil nil)))
+ (setf (cdr (last a)) a)
+ (is-false (proper-list-p a)))
+ (let ((a (list nil nil nil nil nil)))
+ (setf (cdr (last a)) a)
+ (is-false (proper-list-p a)))
+ (let ((a (list nil nil nil nil nil)))
+ (setf (first a) a
+ (car (last a)) a
+ (cdr (last a)) a)
+ (is-false (proper-list-p a))))
+
Added: branches/trunk-reorg/thirdparty/arnesi/t/log.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/t/log.lisp Mon Feb 11 08:38:43 2008
@@ -0,0 +1,39 @@
+;;;; -*- lisp -*-
+
+(in-package :it.bese.arnesi.test)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (def-suite :it.bese.arnesi.log :in :it.bese.arnesi))
+
+(in-suite :it.bese.arnesi.log)
+
+#|
+(defparameter a-handler (make-instance 'collecting-log-handler))
+
+(deflogger log-a ()
+ :appender a-handler
+ :level +dribble+)
+
+(deflogger log-b (log-a))
+
+(deflogger log-c (log-a))
+
+(deflogger log-d (log-c))
+
+(test log1
+ (log-a.dribble "FOO")
+ (is (string= "FOO" (car (slot-value (car (appenders (get-logger 'log-a))) 'messages))))
+
+ (setf (log.level (get-logger 'log-a)) +warn+)
+ (is (= +warn+ (log.level (get-logger 'log-d))))
+
+ (setf (log.level (get-logger 'log-d)) +dribble+)
+ (is (= +dribble+ (log.level (get-logger 'log-d))))
+ (is (= +warn+ (log.level (get-logger 'log-b))))
+ (is (= +warn+ (log.level (get-logger 'log-c))))
+
+ (is (enabled-p (get-logger 'log-d) +warn+))
+ (is (enabled-p (get-logger 'log-a) +warn+))
+ (is (not (enabled-p (get-logger 'log-a) +dribble+))))
+
+|#
\ No newline at end of file
Added: branches/trunk-reorg/thirdparty/arnesi/t/matcher.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/t/matcher.lisp Mon Feb 11 08:38:43 2008
@@ -0,0 +1,99 @@
+;;;; -*- lisp -*-
+
+(in-package :it.bese.arnesi.test)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (def-suite :it.bese.arnesi.matcher :in :it.bese.arnesi))
+
+(in-suite :it.bese.arnesi.matcher)
+
+(test eql
+ (is-true (match '(:EQL 1) 1))
+ (is-false (match `(:EQL ,(gensym)) (gensym)))
+ (let ((sym (gensym)))
+ (is-true (match `(:EQL ,sym) sym))))
+
+(test cons
+ (is-true (match '(:CONS (:EQL NIL) (:EQL NIL)) (cons nil nil)))
+ (is-true (match '(:CONS 'a 'b) (cons 'a'b))))
+
+(test list
+ (is-true (match '(:LIST 'A) '(a)))
+ (is-true (match '(:LIST 'A NIL) '(a nil)))
+ (is-true (match '(:LIST 'A 'B) '(a b)))
+ (is-true (match '(:LIST 'A 'B :ANYTHING) '(a b c)))
+ (is-true (match '(:LIST* 'A 'B :ANYTHING) '(a b)))
+ (is-true (match '(:LIST* 'A 'B :ANYTHING) '(a b . 444)))
+ (is-true (match '(:LIST* 'A 'B :ANYTHING) '(a b 444 555 666))))
+
+(test alt
+ (is-true (match `(:ALTERNATION (:EQL a) (:EQL b)) 'a))
+ (is-true (match `(:ALTERNATION (:EQL a) (:EQL b)) 'b))
+ (is-false (match `(:ALTERNATION (:EQL a) (:EQL b)) 'c))
+ (is-true (match `(:ALT (:EQL a) (:EQL b) (:EQL c)) 'a))
+ (is-true (match `(:ALT (:EQL a) (:EQL b) (:EQL c)) 'b))
+ (is-true (match `(:ALT (:EQL a) (:EQL b) (:EQL c)) 'c))
+ (is-false (match `(:ALT (:EQL a) (:EQL b) (:EQL c)) 'd)))
+
+(test bind/ref
+ (is-true (match `(:CONS (:BIND :ANYTHING $1) (:REF $1)) (cons 1 1)))
+ (is-false (match `(:CONS (:BIND :ANYTHING $1) (:REF $1)) (cons 1 2)))
+ (is-true (match `(:CONS (:BIND (:ALT (:EQL a) (:EQL b)) $1) (:REF $1)) (cons 'a 'a)))
+ (is-true (match `(:CONS (:BIND (:ALT (:EQL a) (:EQL b)) $1) (:REF $1)) (cons 'b 'b)))
+ (is-false (match `(:CONS (:BIND (:ALT (:EQL a) (:EQL b)) $1) (:REF $1)) (cons 'b 'a)))
+ (is-false (match `(:CONS (:BIND (:ALT (:EQL a) (:EQL b)) $1) (:REF $1)) (cons 'a 'b)))
+ (is-false (match `(:CONS (:BIND (:ALT (:EQL a) (:EQL b)) $1) (:REF $1)) (cons 1 1)))
+ (is-true (match `(:CONS (:BIND (:EQUALP "AAA") aaa) (:REF aaa :test equalp)) (cons "AAA" "aaa"))))
+
+(test sym-group
+ (is-true (match `(:CONS a (:REF a)) (cons 1 1)))
+ (is-false (match `(:CONS a (:NOT (:REF a))) (cons 1 1)))
+ (is-true (match `(:CONS a (:NOT (:REF a))) (cons 1 2))))
+
+(test match-case
+ (match-case '(1 . 1)
+ ((:CONS (:BIND (:EQL 1) a) (:REF a)) (is (= 1 a)))
+ (:ANYTHING (fail)))
+ (match-case '(1 . 2)
+ ((:CONS a b) (is (= 1 a)) (is (= 2 b)))
+ (:ANYTHING (fail "For some odd reason we didn't match")))
+ (match-case '(1 . 2)
+ ((:LIST* (:BIND :ANYTHING a) (:BIND :ANYTHING b)) (is (= 1 a)) (is (= 2 b)))))
+
+(test and
+ (match-case 3
+ ((:AND (:TEST numberp) (:TEST oddp))
+ (pass))
+ (:ANYTHING (fail)))
+ (match-case 2
+ ((:AND (:TEST numberp) (:TEST oddp))
+ (fail))
+ (:ANYTHING (pass))))
+
+(defclass foo ()
+ ((x :initarg :x :accessor x)
+ (z :initarg :z :accessor z)))
+
+(test accessors
+ (match-case (make-instance 'foo :x 1 :z 2)
+ ((:ACCESSORS foo x x z z)
+ (is (= 1 x))
+ (is (= 2 z)))
+ (:ANYTHING (fail)))
+ (match-case (make-instance 'foo :x 1 :z 2)
+ ((:ACCESSORS standard-object x a z b)
+ (is (= 1 a))
+ (is (= 2 b)))
+ (:ANYTHING (fail)))
+ (match-case (make-instance 'foo :x 1 :z 2)
+ ((:ACCESSORS cons x a z b)
+ a b ; we won't need them...
+ (fail))
+ (:ANYTHING (pass))))
+
+(test plist
+ (match-case '(:b 2 :a 1)
+ ((:PLIST :a a :b b)
+ (is (= 1 a))
+ (is (= 2 b)))
+ (:ANYTHING (fail))))
Added: branches/trunk-reorg/thirdparty/arnesi/t/numbers.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/t/numbers.lisp Mon Feb 11 08:38:43 2008
@@ -0,0 +1,43 @@
+;;;; -*- lisp -*-
+
+(in-package :it.bese.arnesi.test)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (def-suite :it.bese.arnesi.numbers :in :it.bese.arnesi))
+
+(in-suite :it.bese.arnesi.numbers)
+
+(test mulf
+ (let ((a 0))
+ (is (= 0 (mulf a 10)))
+ (is (= 0 a)))
+ (for-all ((a (gen-integer))
+ (b (gen-integer)))
+ (let ((orig-a a))
+ (mulf a b)
+ (is (= a (* orig-a b)))))
+
+ (let ((a 1))
+ (is (= 4 (mulf a 4)))
+ (is (= 1 (mulf a (/ 4))))
+ (is (= 1 a))))
+
+(test minf
+ (let ((a 10))
+ (is (= 5 (minf a 5)))
+ (is (= 5 a)))
+
+ (let ((a 0))
+ (is (= 0 (minf a 10)))
+ (is (= 0 a))))
+
+(test parse-float
+ (is (= 0 (parse-float "0")))
+ (is (= -1 (parse-float "-1")))
+ (is (= 1 (parse-float "1")))
+
+ (dolist (type '(short-float single-float double-float long-float))
+ (for-all ((float (gen-float :type type :bound 1000)))
+ (let* ((*print-base* 10)
+ (*print-radix* nil))
+ (is (= float (parse-float (princ-to-string float) :type type)))))))
Added: branches/trunk-reorg/thirdparty/arnesi/t/queue.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/t/queue.lisp Mon Feb 11 08:38:43 2008
@@ -0,0 +1,80 @@
+;;;; -*- lisp -*-
+
+(in-package :it.bese.arnesi.test)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (def-suite :it.bese.arnesi.queue :in :it.bese.arnesi))
+
+(in-suite :it.bese.arnesi.queue)
+
+(test make-queue
+ (is (queue-empty-p (make-instance 'queue)))
+ (is (eql 'empty (dequeue (make-instance 'queue) 'empty))))
+
+(test queue-not-full-no-wrapping
+ (let ((q (make-instance 'queue)))
+ (enqueue q 1)
+ (is (= 1 (dequeue q)))
+ (enqueue q 1)
+ (enqueue q 2)
+ (is (= 1 (dequeue q)))
+ (is (= 2 (dequeue q)))))
+
+(test queue-full-not-wrapping
+ (let ((q (make-instance 'queue :size 2)))
+ (enqueue q 1)
+ (enqueue q 2) ;; this causes the size to grow to 2
+ (enqueue q 3) ;; this causes the size to grow to 4
+ (enqueue q 4) ;; this doesn't affect the size
+ (enqueue q 5) ;; this couses the size to grow to 8
+ (is (= 1 (dequeue q)))
+ (is (= 2 (dequeue q)))
+ (is (= 3 (dequeue q)))
+ (is (= 4 (dequeue q)))
+ (is (= 5 (dequeue q)))))
+
+(test queue-not-full-wrapping
+ (let ((q (make-instance 'queue :size 2)))
+ (enqueue q 1)
+ (is (= 1 (queue-count q)))
+ (is (= 1 (dequeue q)))
+ (enqueue q 1)
+ (is (= 1 (queue-count q)))
+ (is (= 1 (dequeue q)))))
+
+(test queue-full-wrapping
+ (let ((q (make-instance 'queue :size 2)))
+ (setf (arnesi::head-index q) 2
+ (arnesi::tail-index q) 1
+ (arnesi::buffer q) #(0 1))
+ q
+ (enqueue q 2)
+ (is (= 1 (dequeue q)))
+ (is (= 2 (dequeue q)))))
+
+(test queue
+ (for-all ((item (gen-integer :min -10 :max 10)))
+ (let ((q (make-instance 'queue)))
+ (enqueue q item)
+ (is (= item (dequeue q)))
+ (is (= 0 (queue-count q)))))
+ (for-all ((one (gen-list :length (gen-integer :min 2 :max 3)
+ :elements (gen-integer :min -10 :max 10)))
+ (two (gen-list :length (gen-integer :min 2 :max 3)
+ :elements (gen-integer :min -10 :max 10)))
+ (three (gen-list :length (gen-integer :min 2 :max 3)
+ :elements (gen-integer :min -10 :max 10))))
+ (let ((q (make-instance 'queue :size (1- (+ (length one)
+ (length two)
+ (length three))))))
+ (flet ((enqueue-all (list)
+ (loop for e in list do (enqueue q e)))
+ (dequeue-all (list)
+ (loop for e in list do (is (= e (dequeue q))))))
+ (enqueue-all one)
+ (enqueue-all two)
+ (dequeue-all one)
+ (enqueue-all three)
+ (dequeue-all two)
+ (dequeue-all three))
+ (is (queue-empty-p q)))))
Added: branches/trunk-reorg/thirdparty/arnesi/t/read-macros.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/t/read-macros.lisp Mon Feb 11 08:38:43 2008
@@ -0,0 +1,18 @@
+;;;; -*- lisp -*-
+
+(in-package :it.bese.arnesi.test)
+
+(in-suite :it.bese.arnesi)
+
+(test bracket-reader
+ (enable-bracket-syntax)
+ (is (= 7 (read-from-string "{(constantly 7)}")))
+ (destructuring-bind (progn a b c)
+ (let ((*package* (find-package :common-lisp-user)))
+ (read-from-string "{(arnesi::with-package :arnesi) a b c}"))
+ (is (eql 'cl:progn progn))
+ (is (eql 'arnesi::a a))
+ (is (eql 'arnesi::b b))
+ (is (eql 'arnesi::c c))))
+
+
Added: branches/trunk-reorg/thirdparty/arnesi/t/sequence.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/t/sequence.lisp Mon Feb 11 08:38:43 2008
@@ -0,0 +1,20 @@
+;;;; -*- lisp -*-
+
+(in-package :it.bese.arnesi.test)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (def-suite :it.bese.arnesi.sequence :in :it.bese.arnesi))
+
+(in-suite :it.bese.arnesi.sequence)
+
+(test levenshtein-distance
+ (is (= 4 (levenshtein-distance "aaaa" "")))
+ (is (= 4 (levenshtein-distance "" "aaaa")))
+ (is (= 0 (levenshtein-distance "" "")))
+ (is (= 0 (levenshtein-distance "a" "a")))
+ (is (= 2 (levenshtein-distance "aa" "cc")))
+ (is (= 1 (levenshtein-distance "a" "aa")))
+ (is (= 1 (levenshtein-distance "ab" "aa")))
+ (is (= 1 (levenshtein-distance "test" "tent"))))
+
+
Added: branches/trunk-reorg/thirdparty/arnesi/t/sharpl.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/t/sharpl.lisp Mon Feb 11 08:38:43 2008
@@ -0,0 +1,93 @@
+(in-package :it.bese.arnesi.test)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (def-suite :it.bese.arnesi.sharpl :in :it.bese.arnesi))
+
+(in-suite :it.bese.arnesi.sharpl)
+
+(enable-sharp-l-syntax)
+
+(test sharpl-simple
+ (is (eql 42 (funcall #L42))))
+
+(test sharpl-mb-example
+ (is (eql 6 (funcall #L(block !2 (return-from !2 !1)) 6))))
+
+(test sharpl-finds-variables
+ (is (eql 111 (funcall #L(+ !1 !2) 42 69))))
+
+(test sharpl-no-variable-in-quote
+ (is (eq (funcall #L'!1) '!1)))
+
+(test sharpl-not-captures-outer-bang
+ (let ((!1 42))
+ (declare (ignore !1))
+ (is (eql 69 (funcall #L!1 69)))))
+
+(test sharpl-nested-simple
+ (is (eql 1 (funcall (funcall #L#L1)))))
+
+(test sharpl-nested-arg
+ (is (eql 42 (funcall (funcall #L#L!1) 42))))
+
+(test sharpl-nested-complex
+ (is (eql 3 (funcall
+ (funcall #L(let ((a !1))
+ #L(+ !1 a))
+ 1)
+ 2))))
+
+(test sharpl-symbol-macrolet-1
+ (is (eql 3 (symbol-macrolet ((sym !1)) (funcall #Lsym 3)))))
+
+(test sharpl-symbol-macrolet-2
+ (is (eql 3 (funcall (symbol-macrolet ((sym !1))
+ #Lsym)
+ 3))))
+
+(test sharpl-macrolet-1
+ (is (eql 15 (macrolet ((mac (arg) `(+ !1 ,arg)))
+ (funcall #L(mac 10) 5)))))
+
+(test sharpl-macrolet-2
+ (is (eql 15 (funcall (macrolet ((mac (arg) `(+ !1 ,arg)))
+ #L(mac 10))
+ 5))))
+
+(test sharpl-inner-macrolet
+ (is (eql 15 (funcall
+ #L(macrolet ((!2 () '!1)) (!2))
+ 15))))
+
+(test sharpl-inner-symbol-macrolet
+ (is (eql 15 (funcall
+ #L(symbol-macrolet ((!2 !1)) (+ !2 10))
+ 5))))
+
+(test sharpl-bang-binds-to-innermost
+ (is (eql 10 (funcall
+ (funcall #L(let ((a !1))
+ #L(+ a !1))
+ 6)
+ 4))))
+
+(test sharpl-interposed-macrolet
+ (is (eql 6 (funcall
+ (funcall #L(macrolet ((mac () '!1))
+ #L(mac)))
+ 6))))
+
+(test sharpl-nested-macrolet
+ (is (eql 21 (funcall
+ (funcall
+ #L(macrolet ((return-bang () ''!1))
+ (macrolet ((multiply-first-bang (arg) `(* ,arg ,(return-bang))))
+ #L(+ (multiply-first-bang 2) 1))))
+ 10))))
+
+(test sharpl-interposed-symbol-macrolet
+ (is (eql 'result (funcall
+ (funcall #L(symbol-macrolet ((mac !1))
+ #Lmac))
+ 'result))))
+
Added: branches/trunk-reorg/thirdparty/arnesi/t/string.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/t/string.lisp Mon Feb 11 08:38:43 2008
@@ -0,0 +1,9 @@
+;;;; -*- lisp -*-
+
+(in-package :it.bese.arnesi.test)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (def-suite :it.bese.arnesi.string :in :it.bese.arnesi))
+
+(in-suite :it.bese.arnesi.string)
+
Added: branches/trunk-reorg/thirdparty/arnesi/t/suite.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/t/suite.lisp Mon Feb 11 08:38:43 2008
@@ -0,0 +1,13 @@
+;;;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+(defpackage :it.bese.arnesi.test
+ (:use :common-lisp
+ :it.bese.arnesi
+ :it.bese.FiveAM))
+
+(unless (5am:get-test :it.bese)
+ (5am:def-suite :it.bese))
+
+(5am:def-suite :it.bese.arnesi :in :it.bese)
Added: branches/trunk-reorg/thirdparty/arnesi/t/walk.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/t/walk.lisp Mon Feb 11 08:38:43 2008
@@ -0,0 +1,195 @@
+;;;; -*- lisp -*-
+
+(in-package :it.bese.arnesi.test)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (def-suite :it.bese.arnesi.walk :in :it.bese.arnesi))
+
+(in-suite :it.bese.arnesi.walk)
+
+(defun test-walk (form)
+ (values (equal (unwalk-form (walk-form form)) form)
+ (unwalk-form (walk-form form))
+ form))
+
+(test walk-constant
+ (is (test-walk 1))
+ (is (test-walk ''a))
+ (is (test-walk "a"))
+ (is (test-walk '(1 2 3)))
+ (is (test-walk '#(1 2 3))))
+
+(test walk-variable
+ (is (test-walk 'var)))
+
+(test walk-application
+ (is (test-walk '(* 2 3)))
+ (is (test-walk '(+ (* 3 3) (* 4 4)))))
+
+(test walk-lambda-application
+ (is (test-walk '((lambda (x) (x x)) #'(lambda (x) (x x)))))
+ (is (test-walk '((lambda (x k) (k x)) (if p x y) id))))
+
+(test walk-lambda-function
+ (is (test-walk '#'(lambda (x y) (y x))))
+ (is (test-walk '#'(lambda (x &key y z) (z (y x)))))
+ (is (test-walk '#'(lambda (&optional port) (close port))))
+ (is (test-walk '#'(lambda (x &rest args) (apply x args))))
+ (is (test-walk '#'(lambda (object &key a &allow-other-keys) (values))))
+ ;; Unwalking argument lists is lax.
+ (is (test-walk '#'(lambda (&rest args &key a b &optional x &allow-other-keys) 2))))
+
+(test walk-block
+ (is (test-walk '(block label (get-up) (eat-food) (go-to-sleep))))
+ (is (test-walk '(block label ((lambda (f x) (f (f x))) #'car))))
+ (is (test-walk '(block label (reachable) (return-from label 'done) (unreachable)))))
+
+(test walk-catch
+ (is (test-walk '(catch 'done (with-call/cc* (* 2 3)))))
+ (is (test-walk '(catch 'scheduler
+ (tagbody start
+ (funcall thunk)
+ (if (done-p) (throw 'scheduler 'done) (go start))))))
+ (is (test-walk '(catch 'c
+ (flet ((c1 () (throw 'c 1)))
+ (catch 'c (c1) (print 'unreachable))
+ 2)))))
+
+(test walk-if
+ (is (test-walk '(if p x y)))
+ (is (test-walk '(if (pred x) (f x) (f-tail y #(1 2 3))))))
+
+(test walk-flet
+ (is (test-walk '(flet ((sq (x)
+ (* x x)))
+ (+ (sq 3) (sq 4)))))
+ (is (test-walk '(flet ((prline (s)
+ (princ s)
+ (terpri)))
+ (prline "hello")
+ (prline "world")))))
+
+(test walk-labels
+ (is (test-walk '(labels ((fac-acc (n acc)
+ (if (zerop n)
+ (land acc)
+ (bounce
+ (fac-acc (1- n) (* n acc))))))
+ (fac-acc (fac-acc 10 1) 1))))
+ (is (test-walk '(labels ((evenp (n)
+ (if (zerop n) t (oddp (1- n))))
+ (oddp (n)
+ (if (zerop n) nil (evenp (1- n)))))
+ (oddp 666)))))
+
+(test walk-let
+ (is (test-walk '(let ((a 2) (b 3) (c 4))
+ (+ (- a b) (- b c) (- c a)))))
+ (is (test-walk '(let ((a b) (b a)) (format t "side-effect~%") (f a b)))))
+
+(test walk-let*
+ (is (test-walk '(let* ((a (random 100)) (b (* a a))) (- b a))))
+ (is (test-walk '(let* ((a b) (b a)) (equal a b)))))
+
+(test walk-load-time-value
+ (is (test-walk '(load-time-value *load-pathname* nil))))
+
+(test walk-locally
+ (is (test-walk '(locally (setq *global* (whoops))))))
+
+(test walk-macrolet
+ (is (unwalk-form
+ (walk-form
+ '(macrolet ((+ (&body body)
+ (reverse body)))
+ (+ 1 2 3 -))))
+ '(locally (- 3 2 1)))
+ (is (unwalk-form
+ (walk-form
+ '(macrolet ())))
+ '(locally ()))
+ (is (unwalk-form
+ (walk-form
+ '(macrolet ((+ (&body body)
+ (reverse body)))
+ (princ "1111")
+ (+ 1 2 3 -))))
+ '(locally
+ (princ "1111")
+ (- 3 2 1))))
+
+(test walk-multiple-value-call
+ (is (test-walk '(multiple-value-call #'list 1 '/ (values 2 3) '/ (values) '/ (floor 2.5))))
+ (is (test-walk '(multiple-value-call #'+ (floor 5 3) (floor 19 4)))))
+
+(test walk-multiple-value-prog1
+ (is (test-walk '(multiple-value-prog1
+ (values-list temp)
+ (setq temp nil)
+ (values-list temp)))))
+
+(test walk-progn
+ (is (test-walk '(progn (f a) (f-tail b) c)))
+ (is (test-walk '(progn #'(lambda (x) (x x)) 2 'a))))
+
+(test walk-progv
+ (is (test-walk '(progv '(*x*) '(2) *x*))))
+
+(test walk-setq
+ (is (test-walk '(setq x '(2 #(3 5 7) 11 "13" '17))))
+ (is (test-walk '(setq *global* 'symbol))))
+
+(test walk-symbol-macrolet
+ (is (unwalk-form
+ (walk-form
+ '(symbol-macrolet ((a (slot-value obj 'a))
+ (b (slot-value obj 'b)))
+ (+ a b))))
+ '(locally
+ (+ (slot-value obj 'a) (slot-value obj 'b))))
+ (is (unwalk-form
+ (walk-form
+ '(symbol-macrolet ())))
+ '(locally))
+ (is (unwalk-form
+ (walk-form
+ '(symbol-macrolet ((a (slot-value obj 'a)))
+ (double! a)
+ (/ a 2))))
+ '(locally
+ (double! (slot-value obj 'a))
+ (/ (slot-value obj 'a) 2))))
+
+(test walk-tagbody
+ (is (test-walk '(tagbody
+ (setq val 1)
+ (go point-a)
+ (setq val (+ val 16))
+ point-c
+ (setq val (+ val 4))
+ (go point-b)
+ (setq val (+ val 32))
+ point-a
+ (setq val (+ val 2))
+ (go point-c)
+ (setq val (+ val 64))
+ point-b
+ (setq val (+ val 8)))))
+ (is (test-walk '(tagbody
+ (setq n (f2 flag #'(lambda () (go out))))
+ out
+ (prin1 n)))))
+
+(test walk-the
+ (is (test-walk '(the number (reverse "naoh"))))
+ (is (test-walk '(the string 1))))
+
+(test walk-unwind-protect
+ (is (test-walk '(unwind-protect
+ (progn (setq count (+ count 1))
+ (perform-access))
+ (setq count (- count 1)))))
+ (is (test-walk '(unwind-protect
+ (progn (with-call/cc* (walk-the-plank))
+ (pushed-off-the-plank))
+ (save-life)))))
More information about the Bknr-cvs
mailing list