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@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)))) + ,@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)))) + ,@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) ,@body)) + `(progn ,@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 ,@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 ,@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 + ,@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 ,@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 ,@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 ,@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) ,@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 () + ,@body))) + (valuep `(lambda (&optional ,value &rest ,other-values) + (declare (ignore ,other-values)) + (lambda () + ,@body))) + (t `(lambda (&optional ,value &rest ,other-values) + (declare (ignore ,value ,other-values)) + (lambda () + ,@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 "~%") ,@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 ,@args)) + (klambda ,k-args + (when *debug-evaluate/cc* + (format *debug-io* "~&(~S~{~^ ~S~}) Got (values~{~^ ~S~}).~%" ',name (list ,@args) (list ,@k-args))) + ,@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 ,@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*)) + ,@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) + ,@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)) + ,@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 ,@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 ,@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 ,@others))) + nil)) + +(defmacro acond (&rest clauses) + "Just like cond-bind except the var is automatically IT." + `(cond-bind it ,@clauses)) + +(defmacro aand (&rest forms) + `(and-bind it ,@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 ,@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 ,@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 ,@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)) + ,@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) + ,@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) + ,@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 #< "&lt;") + (add-mapping #> "&gt;") + (add-mapping #& "&amp;") + (add-mapping #" "&quot;") + (add-mapping #\space "&nbsp;") + (add-mapping "a`" "&#224;") + (add-mapping "a'" "&#225;") + (add-mapping "e`" "&#232;") + (add-mapping "e'" "&#233;") + (add-mapping "i'" "&#236;") + (add-mapping "i`" "&#237;") + (add-mapping "o`" "&#242;") + (add-mapping "o'" "&#243;") + (add-mapping "u`" "&#249;") + (add-mapping "u'" "&#250;")) + 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 "&nbsp;" 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))) + ,@args) + ,@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))) + ,@args) + ,@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))))) + ,@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 ,@body)) + (,name ,@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 (,@whole-list ,form-name ,@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 + ,@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))) + ,@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))) + ,@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 ,@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 ,@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/829940550... + +;; 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 + ,@body))) + `(dolist (,iterator ,list ,return-value) + (let ((,iterator ,iterator)) + ,@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)) + ,@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)) + ,@progn) + (acond2 ,@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))) + ,@progn) + (list-match-case ,tgt ,@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 + ,@body) + `(progn + ,@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 ,@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"))) + ,@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 ,@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 ,@appenders)) + :ancestors (list ,@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 ,@body)) + ',name)) + +(defmacro def-matcher-macro (name args &body body) + `(progn (setf (get-match-handler ',name) + (lambda ,args + (%make-matcher (progn ,@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) + ,@body) + (match-case ,form-sym ,@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* ,@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 ,@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@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) + ,@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@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 (,,@temps) + ,,@body)))))) + +(defmacro rebind (bindings &body body) + `(let ,(loop + for symbol-name in bindings + collect (list symbol-name symbol-name)) + ,@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 + ,@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 ,@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) + ,@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)) + ,@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@bese.it. + +;;;; ** COPYRIGHT + +;;;; Copyright (c) 2002-2006, Edward Marco Baringer +;;;; Copyright (c) 2006 Luca Capello http://luca.pca.it luca@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 ,@args ,end))))) + +;;;; http://groups.google.com/group/comp.lang.lisp/browse_thread/thread/1a86740db... + +;; 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@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) + ,@body)) + (let ((index (gensym "do-all-elements-index-"))) + `(call-for-all-elements-with-index ,queue + (lambda (,element ,index) + (declare (ignore ,index)) + ,@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) + ,@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 ,@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))) + ,@body)) + (defmacro ,binder* (requested-vars &body body) + (check-required ',name ',vars (mapcar #'car requested-vars)) + `(let* ,requested-vars + (declare (special ,@(mapcar #'car requested-vars))) + ,@body)) + (defmacro ,accessor (requested-vars &body body) + (check-required ',name ',vars requested-vars) + `(locally (declare (special ,@requested-vars)) + ,@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 + ,@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 ,@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)) + ,@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 ,@initargs))) + ,@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 + ,@ignores + ,@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) ,@rest)) + (extend-env ((var list) newdeclare &rest datum) + `(dolist (,var ,list) + (when ,newdeclare (push ,newdeclare declares)) + (extend-walk-env environment :declare ,@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 ,@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 ,@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 ,@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%..." + error)) + +(test unescape-uri/wrong-percentage-quoting + (help-test-bad-uri "http://ad.doubleclick.net/adi/N763.business_week_online/B1803870.12;sz=468x6..." + expected-digit-uri-parse-error)) + +(test unescape-uri/percentage-at-end + (help-test-bad-uri "http://groups.google.com/groups/adfetch?adid=zMKqMREAAAAwVvp0Nmmxmm2KqccSr5K..." + 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)))))