summaryrefslogtreecommitdiff
path: root/Sacla
diff options
context:
space:
mode:
Diffstat (limited to 'Sacla')
-rw-r--r--Sacla/array.lisp137
-rw-r--r--Sacla/character.lisp152
-rw-r--r--Sacla/clos.lisp2539
-rw-r--r--Sacla/condition.lisp437
-rw-r--r--Sacla/cons.lisp993
-rw-r--r--Sacla/core.lisp726
-rw-r--r--Sacla/data-and-control.lisp388
-rw-r--r--Sacla/do.lisp85
-rw-r--r--Sacla/eval.lisp46
-rw-r--r--Sacla/hash-table.lisp248
-rwxr-xr-xSacla/init.lisp55
-rw-r--r--Sacla/loop.lisp1142
-rw-r--r--Sacla/package.lisp633
-rw-r--r--Sacla/printer.lisp582
-rw-r--r--Sacla/reader.lisp797
-rw-r--r--Sacla/sequence.lisp677
-rw-r--r--Sacla/share.lisp184
-rw-r--r--Sacla/stand-in.lisp44
-rw-r--r--Sacla/stream.lisp106
-rw-r--r--Sacla/string.lisp323
-rw-r--r--Sacla/symbol.lisp102
-rw-r--r--Sacla/testbed.lisp217
-rw-r--r--Sacla/tests/ansi-tests.lisp89
-rw-r--r--Sacla/tests/desirable-printer.lisp223
-rw-r--r--Sacla/tests/must-array.lisp2297
-rw-r--r--Sacla/tests/must-character.lisp537
-rw-r--r--Sacla/tests/must-condition.lisp898
-rw-r--r--Sacla/tests/must-cons.lisp2309
-rw-r--r--Sacla/tests/must-data-and-control.lisp1660
-rw-r--r--Sacla/tests/must-do.lisp451
-rw-r--r--Sacla/tests/must-eval.lisp44
-rw-r--r--Sacla/tests/must-eval.patch15
-rw-r--r--Sacla/tests/must-hash-table.lisp696
-rw-r--r--Sacla/tests/must-hash-table.patch55
-rw-r--r--Sacla/tests/must-loop.lisp3605
-rw-r--r--Sacla/tests/must-loop.patch13
-rw-r--r--Sacla/tests/must-package.lisp2266
-rw-r--r--Sacla/tests/must-package.patch12
-rw-r--r--Sacla/tests/must-printer.lisp1610
-rw-r--r--Sacla/tests/must-printer.patch13
-rw-r--r--Sacla/tests/must-reader.lisp3052
-rw-r--r--Sacla/tests/must-reader.patch26
-rw-r--r--Sacla/tests/must-sequence.lisp10165
-rw-r--r--Sacla/tests/must-sequence.patch26
-rw-r--r--Sacla/tests/must-string.lisp608
-rw-r--r--Sacla/tests/must-symbol.lisp459
-rw-r--r--Sacla/tests/should-array.lisp229
-rw-r--r--Sacla/tests/should-array.patch32
-rw-r--r--Sacla/tests/should-character.lisp252
-rw-r--r--Sacla/tests/should-cons.lisp631
-rw-r--r--Sacla/tests/should-data-and-control.lisp49
-rw-r--r--Sacla/tests/should-eval.lisp40
-rw-r--r--Sacla/tests/should-hash-table.lisp48
-rw-r--r--Sacla/tests/should-package.lisp53
-rw-r--r--Sacla/tests/should-sequence.lisp375
-rw-r--r--Sacla/tests/should-string.lisp28
-rw-r--r--Sacla/tests/should-symbol.lisp227
-rw-r--r--Sacla/tests/x-sequence.lisp300
58 files changed, 44006 insertions, 0 deletions
diff --git a/Sacla/array.lisp b/Sacla/array.lisp
new file mode 100644
index 0000000..4fd0147
--- /dev/null
+++ b/Sacla/array.lisp
@@ -0,0 +1,137 @@
+;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
+;; ALL RIGHTS RESERVED.
+;;
+;; $Id: array.lisp,v 1.4 2004/02/20 07:12:10 yuji Exp $
+;;
+;; 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.
+;;
+;; 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.
+
+
+(defun aref (array &rest subscripts)
+ "Access an element of ARRAY specified by SUBSCRIPTS."
+ (row-major-aref array (apply #'array-row-major-index array subscripts)))
+
+(defsetf aref (array &rest subscripts) (value)
+ "Set VALUE onto the element of ARRAY specified by SUBSCRIPTS."
+ `(setf (row-major-aref ,array (array-row-major-index ,array ,@subscripts))
+ ,value))
+
+(defun array-dimension (array axis-number)
+ "Return AXIS-NUMBER dimension of ARRAY."
+ (nth axis-number (array-dimensions array)))
+
+(defun array-in-bounds-p (array &rest subscripts)
+ "Return true if SUBSCRIPTS are all in bounds for ARRAY, otherwise false."
+ (and (not (some #'minusp subscripts))
+ (every #'< subscripts (array-dimensions array))))
+
+(defun array-rank (array)
+ "Return the number of dimensions of ARRAY."
+ (length (array-dimensions array)))
+
+(defun array-row-major-index (array &rest subscripts)
+ "Compute the row-major index of the element of ARRAY specified by SUBSCRIPTS."
+ (assert (apply #'array-in-bounds-p array subscripts))
+ (apply #'+ (maplist #'(lambda (x y)
+ (* (car x) (apply #'* (cdr y))))
+ subscripts
+ (array-dimensions array))))
+
+(defun array-total-size (array)
+ "Return the total number of elements in ARRAY."
+ (apply #'* (array-dimensions array)))
+
+
+(defun vector (&rest objects)
+ "Create a fresh simple general vector whose elements are OBJECTS."
+ (make-array (length objects)
+ :element-type t
+ :initial-contents objects))
+
+(defun vector-pop (vector)
+ "Decrease the fill pointer of VECTOR by one and return the top element."
+ (check-type vector vector)
+ (assert (and (array-has-fill-pointer-p vector)
+ (plusp (fill-pointer vector))))
+ (aref vector (setf (fill-pointer vector) (1- (fill-pointer vector)))))
+
+(defun vector-push (new-element vector)
+ "Try to store NEW-ELEMENT in VECTOR's element designated by the fill pointer."
+ (let ((fill-pointer (fill-pointer vector)))
+ (when (< fill-pointer (array-dimension vector 0))
+ (setf (aref vector fill-pointer) new-element)
+ (setf (fill-pointer vector) (1+ fill-pointer))
+ fill-pointer)))
+
+(defun vector-push-extend (new-element vector &optional
+ (extension (1+ (length vector))))
+ "Do the same thing as vector-push but extend VECTOR when space is lacking."
+ (when (>= (fill-pointer vector) (array-dimension vector 0))
+ (assert (adjustable-array-p vector))
+ (adjust-array vector (+ (fill-pointer vector) extension)))
+ (vector-push new-element vector))
+
+(defun vectorp (object)
+ "Return true if OBJECT is of type vector; otherwise, return false."
+ (and (arrayp object)
+ (eql (array-rank object) 1)))
+
+
+(defun bit-andc1 (bit-array1 bit-array2 &optional opt-arg)
+ "And complement of BIT-ARRAY1 with BIT-ARRAY2."
+ (bit-and (bit-not bit-array1 opt-arg) bit-array2 opt-arg))
+
+(defun bit-andc2 (bit-array1 bit-array2 &optional opt-arg)
+ "And BIT-ARRAY1 with complement of BIT-ARRAY2."
+ (bit-and bit-array1 (bit-not bit-array2) opt-arg))
+
+(defun bit-eqv (bit-array1 bit-array2 &optional opt-arg)
+ "Exclusive nor (equivalence) between BIT-ARRAY1 and BIT-ARRAY2."
+ (bit-not (bit-xor bit-array1 bit-array2 opt-arg) opt-arg))
+
+(defun bit-nand (bit-array1 bit-array2 &optional opt-arg)
+ "Complement of BIT-ARRAY1 and BIT-ARRAY2."
+ (bit-not (bit-and bit-array1 bit-array2 opt-arg) opt-arg))
+
+(defun bit-nor (bit-array1 bit-array2 &optional opt-arg)
+ "Complement of BIT-ARRAY1 or BIT-ARRAY2."
+ (bit-not (bit-ior bit-array1 bit-array2 opt-arg) opt-arg))
+
+(defun bit-orc1 (bit-array1 bit-array2 &optional opt-arg)
+ "Or complement of BIT-ARRAY1 with BIT-ARRAY2."
+ (bit-ior (bit-not bit-array1 opt-arg) bit-array2 opt-arg))
+
+(defun bit-orc2 (bit-array1 bit-array2 &optional opt-arg)
+ "Or BIT-ARRAY1 with complement of BIT-ARRAY2."
+ (bit-ior bit-array1 (bit-not bit-array2) opt-arg))
+
+
+(defun bit-vector-p (object)
+ "Return true if OBJECT is of type bit-vector; otherwise, return false."
+ (and (vectorp object)
+ (eq (array-element-type object) 'bit)))
+
+(defun simple-bit-vector-p (object)
+ "Return true if OBJECT is of type simple-bit-vector; otherwise, return false."
+ (and (bit-vector-p object)
+ (typep object 'simple-array)))
diff --git a/Sacla/character.lisp b/Sacla/character.lisp
new file mode 100644
index 0000000..9a7e34c
--- /dev/null
+++ b/Sacla/character.lisp
@@ -0,0 +1,152 @@
+;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
+;; ALL RIGHTS RESERVED.
+;;
+;; $Id: character.lisp,v 1.6 2004/02/20 07:23:42 yuji Exp $
+;;
+;; 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.
+;;
+;; 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.
+
+(defun char/= (character &rest more-characters)
+ "Return true if all characters are different; otherwise, return false."
+ (do ((c character)
+ (list more-characters (cdr list)))
+ ((atom list) t)
+ (when (member c list :test #'char=)
+ (return nil))
+ (setq c (car list))))
+
+(defun char> (character &rest more-characters)
+ "Return true if the characters are monotonically decreasing."
+ (do ((c character)
+ (list more-characters (cdr list)))
+ ((atom list) t)
+ (when (or (char= c (car list)) (char< c (car list)))
+ (return nil))
+ (setq c (car list))))
+
+(defun char<= (character &rest more-characters)
+ "Return true if the characters are monotonically nondecreasing;"
+ (do ((c character)
+ (list more-characters (cdr list)))
+ ((atom list) t)
+ (when (char> c (car list))
+ (return nil))
+ (setq c (car list))))
+
+(defun char>= (character &rest more-characters)
+ "Return true if the characters are monotonically nonincreasing."
+ (do ((c character)
+ (list more-characters (cdr list)))
+ ((atom list) t)
+ (when (char< c (car list))
+ (return nil))
+ (setq c (car list))))
+
+(defun char-equal (character &rest more-characters)
+ "Return true if all characters are the same when ignoring the case."
+ (do ((c character)
+ (list more-characters (cdr list)))
+ ((atom list) t)
+ (unless (char= (char-upcase c) (char-upcase (car list)))
+ (return nil))
+ (setq c (car list))))
+
+(defun char-not-equal (character &rest more-characters)
+ "Return true if all characters are different when ignoring the case."
+ (do ((c character)
+ (list more-characters (cdr list)))
+ ((atom list) t)
+ (when (member c list :test #'char-equal)
+ (return nil))
+ (setq c (car list))))
+
+(defun char-lessp (character &rest more-characters)
+ "Return true if the chars are monotonically increasing when ignoring the case."
+ (do ((c character)
+ (list more-characters (cdr list)))
+ ((atom list) t)
+ (unless (char< (char-upcase c) (char-upcase (car list)))
+ (return nil))
+ (setq c (car list))))
+
+(defun char-greaterp (character &rest more-characters)
+ "Return true if the chars are monotonically decreasing when ignoring the case."
+ (do ((c character)
+ (list more-characters (cdr list)))
+ ((atom list) t)
+ (unless (char> (char-upcase c) (char-upcase (car list)))
+ (return nil))
+ (setq c (car list))))
+
+(defun char-not-greaterp (character &rest more-characters)
+ "Return true if the chars are monotonically nondecreasing when ignoring the case."
+ (do ((c character)
+ (list more-characters (cdr list)))
+ ((atom list) t)
+ (when (char-greaterp c (car list))
+ (return nil))
+ (setq c (car list))))
+
+
+(defun char-not-lessp (character &rest more-characters)
+ "Return true if the characters are monotonically nonincreasing."
+ (do ((c character)
+ (list more-characters (cdr list)))
+ ((atom list) t)
+ (when (char-lessp c (car list))
+ (return nil))
+ (setq c (car list))))
+
+
+(defun character (designator)
+ "Return the character denoted by the character designator CHARACTER."
+ (etypecase designator
+ (character designator)
+ ((string 1) (char designator 0))
+ (character-designator-simbol (char (symbol-name designator) 0))))
+
+
+(defun digit-char (weight &optional (radix 10))
+ "Return a character which has WEIGHT when considered as a digit in RADIX."
+ (check-type radix (integer 2 36))
+ (if (>= weight radix)
+ nil
+ (schar "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" weight)))
+
+(defun digit-char-p (char &optional (radix 10))
+ "Test whether CHAR is a digit in RADIX. If it is, return its weight."
+ (check-type radix (integer 2 36))
+ (position (char-upcase char)
+ "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"
+ :end radix))
+
+(defconstant standard-chars
+ " !\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_'abcdefghijklmnopqrstuvwxyz{|}~
+"
+ "Standard characters")
+
+(defun standard-char-p (character)
+ "Return true if CHARACTER is of type standard-char; otherwise, return false."
+ (check-type character character)
+ (find character standard-chars :test #'char=))
+
diff --git a/Sacla/clos.lisp b/Sacla/clos.lisp
new file mode 100644
index 0000000..5805a87
--- /dev/null
+++ b/Sacla/clos.lisp
@@ -0,0 +1,2539 @@
+;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
+;; ALL RIGHTS RESERVED.
+;;
+;; $Id: clos.lisp,v 1.28 2004/09/24 07:31:33 yuji Exp $
+;;
+;; 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.
+;;
+;; 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.
+
+;; Non conformance points to CLOS.
+;; * (defmethod allocate-instance ((class structure-class) &rest initargs))
+;; is not implemented.
+;;
+;; Non conformance points to MOP.
+;; *
+;;
+
+
+(defparameter *mop-working-p* nil)
+(defparameter *symbol-function-is-funcallable-object-p* t)
+
+
+
+(defstruct %standard-object
+ class
+ (version nil)
+ storage)
+
+(defun swap-%standard-object (a b)
+ (rotatef (%standard-object-class a) (%standard-object-class b))
+ (rotatef (%standard-object-version a) (%standard-object-version b))
+ (rotatef (%standard-object-storage a) (%standard-object-storage b)))
+
+
+
+(defparameter *classes* (make-hash-table)
+ "The hash table of all classes in CLOS system.")
+(defun find-class (symbol &optional errorp environment) ; clos
+ "Return the class object named by SYMBOL in ENVIRONMENT."
+ (declare (ignore environment))
+ (multiple-value-bind (class presentp) (gethash symbol *classes*)
+ (if presentp
+ class
+ (when errorp (error "Class ~S does not exist." symbol)))))
+(defun (setf find-class) (new-class symbol &optional errorp environment) ; clos
+ "Set the name of NEW-CLASS to SYMBOL in ENVIRONMENT."
+ (declare (ignore environment))
+ (if new-class
+ (setf (gethash symbol *classes*) new-class)
+ (remhash symbol *classes*))
+ new-class)
+
+
+
+(defun plist-member (key plist)
+ (loop for rest on plist by #'cddr
+ if (eq key (car rest)) return rest))
+
+(defun plist-keys (plist) (loop for key in plist by #'cddr collect key))
+
+
+
+;; AMOP 5.4.2 The defclass Macro http://www.lisp.org/mop/concepts.html#defclass
+;; > The relationship between the arguments to the defclass macro and
+;; > the arguments received by ensure-generic-function is defined.
+
+(defun qt? (object)
+ "Return a quoted form of OBJECT or OBJECT itself if it's self-evaluating."
+ (flet ((self-evaluating-object-p (object)
+ (typecase object
+ ((or number character array) t)
+ (symbol (or (keywordp object) (member object '(t nil))))
+ (t nil))))
+ (if (self-evaluating-object-p object)
+ object
+ `(quote ,object))))
+
+(defun check-direct-slot-spec-options (slot-spec)
+ (let ((reserved-keys '(:name :initargs :initfunction :readers :writers))
+ (multiple-keys '(:initarg :reader :writer :accessor))
+ (keys '())
+ (name (car slot-spec)))
+ (dolist (key (plist-keys (cdr slot-spec)))
+ (cond
+ ((member key reserved-keys)
+ (error "Reserved option ~S is wrongly given in slot ~S ." key name))
+ ((and (member key keys) (not (member key multiple-keys)))
+ (error "Option ~S is given more than once in slot ~S." key name))
+ (t (push key keys))))))
+
+(defun direct-slot-initargs-form (slot-spec)
+ ;; direct-slot-initargs is a canonicalized slot specification described in
+ ;; http://www.lisp.org/mop/concepts.html#defclass .
+ (flet ((specified-more-than-once-p (key)
+ (< 1 (count key (plist-keys (cdr slot-spec)))))
+ (quote-keys (plist)
+ (loop for (key value) on plist by #'cddr nconc `(,(qt? key) ,value))))
+ (check-direct-slot-spec-options slot-spec)
+ (loop for (key value) on (cdr slot-spec) by #'cddr
+ if (eq key :initform)
+ nconc `(:initform ',value :initfunction #'(lambda () ,value))
+ into plist
+ else if (eq key :initarg) collect value into initargs
+ else if (eq key :reader) collect value into readers
+ else if (eq key :writer) collect value into writers
+ else if (eq key :accessor) collect value into readers and
+ collect `(setf ,value) into writers
+ else if (specified-more-than-once-p key)
+ if (getf plist key)
+ do (setf (cdr (last (getf plist key))) `((quote ,value)))
+ else
+ nconc `(,key (list ',value)) into plist end
+ else nconc `(,key ',value) into plist
+ finally
+ (return `(list :name ',(car slot-spec) :initargs ',initargs
+ :readers ',readers :writers ',writers
+ ,@(quote-keys `(,@plist :initform 'nil :initfunction 'nil
+ :documentation 'nil)))))))
+
+(defun class-initargs-form (options)
+ ;; See http://www.lisp.org/mop/concepts.html#defclass
+ (labels ((check-options (alist)
+ (let ((reserved-keys '(:name :direct-default-initargs))
+ (keys '()))
+ (dolist (key (mapcar #'first alist))
+ (cond
+ ((member key reserved-keys)
+ (error "Reserved option ~S is wrongly given." key))
+ ((member key keys)
+ (error "Option ~S is given more than once." key))
+ (t (push key keys))))))
+ (direct-default-initargs-form (initargs)
+ (loop for (key form) on initargs by #'cddr
+ collect `(list ',key ',form #'(lambda () ,form)) into result
+ finally (return `(list ,@result))))
+ (value-form (key rest)
+ (case key
+ (:direct-default-initargs (direct-default-initargs-form rest))
+ (:direct-slots `(list ,@(mapcar #'direct-slot-initargs-form rest)))
+ ((:metaclass :documentation)
+ (destructuring-bind (value) rest (qt? value)))
+ (t (qt? rest)))))
+ (check-options options)
+ (loop for (key . rest) in options
+ when (eq key :default-initargs) do (setq key :direct-default-initargs)
+ nconc `(,(qt? key) ,(value-form key rest)) into result
+ finally (return `(list ,@result)))))
+
+(defun <ensure-class> (name &rest initargs)
+ (apply (if *mop-working-p* #'ensure-class #'ensure-system-class)
+ name initargs))
+
+(defmacro defclass (name direct-superclasses direct-slots &rest options) ; clos
+ "Define a new class named NAME which is a subclass of DIRECT-SUPERCLASSES."
+ (let* ((*message-prefix* (format nil "DEFCLASS ~S: " name)))
+ `(let ((*message-prefix* ,*message-prefix*))
+ (apply #'<ensure-class>
+ ',name
+ ,(class-initargs-form `((:direct-superclasses ,@direct-superclasses)
+ (:direct-slots ,@direct-slots)
+ ,@options))))))
+
+
+
+(defun class-of (object) ; clos
+ "Return the class of which OBJECT is a direct instance."
+ ;; 4.3.7 Integrating Types and Classes
+ ;; http://www.lispworks.com/reference/HyperSpec/Body/04_cg.htm
+ (cond
+ ((%standard-object-p object) (%standard-object-class object))
+ ((functionp object) (let ((gf (find-generic-function object)))
+ (if gf
+ (class-of gf)
+ (find-class 'function))))
+ (t (let ((type (type-of object)))
+ (or (and (symbolp type) (find-class type))
+ (typecase object
+ ((and symbol (not null)) (find-class 'symbol))
+ (character (find-class 'character))
+ (hash-table (find-class 'hash-table))
+ (sequence (class-of-sequence object))
+ ((and array (not vector)) (find-class 'array))
+ (number (class-of-number object))
+ (stream (class-of-stream object))
+ (pathname (typecase object
+ (logical-pathname (find-class 'logical-pathname))
+ (t (find-class 'pathname))))
+ (package (find-class 'package))
+ (random-state (find-class 'random-state))
+ (readtable (find-class 'readtable))
+ (restart (find-class 'restart))
+ (condition (class-of-condition object))
+ (t (find-class 't))))))))
+
+(defun frozen-class-instance-p (object)
+ (and (%standard-object-p object) (null (%standard-object-version object))))
+
+(defconstant +unbound-state+ (gensym "UNBOUND-STATE-"))
+
+(defun slot-value (object slot-name) ; clos
+ "Return the value of the slot named SLOT-NAME in OBJECT."
+ (flet ((slot-is-missing ()
+ (slot-missing (class-of object) object slot-name 'slot-value))
+ (slot-is-unbound ()
+ (slot-unbound (class-of object) object slot-name)))
+ (if (frozen-class-instance-p object)
+ (let ((binding (assoc slot-name (%standard-object-storage object))))
+ (if binding
+ (let ((value (second binding)))
+ (if (not (eq value +unbound-state+))
+ value
+ (values (slot-is-unbound))))
+ (values (slot-is-missing))))
+ (let* ((class (class-of object))
+ (slot (find-slot class slot-name)))
+ (if slot
+ (slot-value-using-class class object slot)
+ (values (slot-is-missing)))))))
+
+(defun (setf slot-value) (new-value object slot-name) ; clos
+ "Set the value of the slot named SLOT-NAME in OBJECT to NEW-VALUE."
+ (flet ((slot-is-missing ()
+ (slot-missing (class-of object) object slot-name 'setf new-value)))
+ (if (frozen-class-instance-p object)
+ (let ((binding (assoc slot-name (%standard-object-storage object))))
+ (if binding
+ (progn
+ (assert (typep new-value (third binding)))
+ (setf (second binding) new-value))
+ (slot-is-missing)))
+ (let* ((class (class-of object))
+ (slot (find-slot class slot-name)))
+ (assert (typep new-value (slot-definition-type slot)))
+ (if slot
+ (setf (slot-value-using-class class object slot) new-value)
+ (slot-is-missing))))
+ new-value))
+
+(defun slot-boundp (instance slot-name) ; clos
+ "Return true if the slot named SLOT-NAME in INSTANCE is bound."
+ (flet ((slot-is-missing ()
+ (slot-missing (class-of instance) instance slot-name 'slot-value)))
+ (if (frozen-class-instance-p instance)
+ (let ((binding (assoc slot-name (%standard-object-storage instance))))
+ (if binding
+ (not (eq (second binding) +unbound-state+))
+ (values (slot-is-missing))))
+ (let* ((class (class-of instance))
+ (slot (find-slot class slot-name)))
+ (if slot
+ (slot-boundp-using-class class instance slot)
+ (values (slot-is-missing)))))))
+(defun find-slot (class slot-name)
+ (find slot-name (slot-value class 'slots)
+ :key #'(lambda (slot) (slot-value slot 'name))))
+(defun local-slot-p (slot) (eq (slot-value slot 'allocation) :instance))
+
+
+
+;; for debug
+(defmethod print-object ((object %standard-object) stream)
+ (flet ((slot (object name)
+ (second (assoc name (%standard-object-storage object)))))
+ (let ((class (class-of object)))
+ (cond
+ ((and (%standard-object-p class)
+ (assoc 'name (%standard-object-storage class)))
+ (if (assoc 'name (%standard-object-storage object))
+ (format stream "#<~S:(~S)>" (slot class 'name) (slot object 'name))
+ (format stream "#<~S:>" (slot class 'name))))
+ ((assoc 'name (%standard-object-storage object))
+ (format stream "#<:(~S)>" (slot object 'name)))
+ (t
+ (format stream "#<(CLOS object)>"))))))
+
+
+
+;; 7.1.3 Defaulting of Initialization Arguments
+;; http://www.lispworks.com/reference/HyperSpec/Body/07_ac.htm
+;; 7.1.4 Rules for Initialization Arguments
+;; http://www.lispworks.com/reference/HyperSpec/Body/07_ad.htm
+(defun compute-standard-default-initargs (class)
+ (flet ((default-initargs (class)
+ (mapappend #'(lambda (class)
+ (slot-value class 'direct-default-initargs))
+ (slot-value class 'precedence-list))))
+ (loop for initarg in (default-initargs class) with args = '()
+ for name = (car initarg)
+ unless (member name args)
+ collect initarg and do (push name args))))
+
+(defun defaulted-initargs (class initargs)
+ (append initargs
+ (loop for (key form func) in (slot-value class 'default-initargs)
+ ;; each key is unique throughout the iteration.
+ unless (plist-member key initargs)
+ nconc `(,key ,(funcall func)))))
+
+
+
+(defun finalized-p (class)
+ (flet ((defclassed-p (class)
+ (and (%standard-object-p class) (%standard-object-storage class))))
+ (when (symbolp class) (setq class (find-class class)))
+ (and (defclassed-p class) (slot-value class 'finalized-p))))
+
+(defun canonicalize-instance (instance)
+ (let* ((class (class-of instance))
+ (initargs (mapcan #'(lambda (binding)
+ (list (%keyword (first binding)) (second binding)))
+ (%standard-object-storage instance)))
+ (defaulted-initargs (defaulted-initargs class initargs))
+ (dummy (make-%standard-object
+ :class class
+ :storage (allocate-standard-instance-storage class))))
+ (standard-shared-initialize dummy t defaulted-initargs)
+ (swap-%standard-object instance dummy))
+ instance)
+
+(defun make-system-instance (class &rest initargs)
+ (flet ((alist-storage (plist)
+ (loop for (key value) on plist by #'cddr
+ collect (list (intern (string key)) value 't))))
+ (let ((instance (make-%standard-object
+ :class class
+ :version nil
+ :storage (alist-storage initargs))))
+ (when (finalized-p class)
+ (canonicalize-instance instance))
+ instance)))
+
+(defun ensure-class-object (name &rest initargs)
+ (let ((metaclass (let ((metaclass-name (getf initargs :metaclass)))
+ (when metaclass-name
+ (ensure-class-object metaclass-name))))
+ (class (find-class name)))
+ (if class
+ (when initargs
+ (let* ((dummy (apply #'make-system-instance metaclass initargs)))
+ (swap-%standard-object class dummy)))
+ (setf (find-class name)
+ (apply #'make-system-instance metaclass initargs)))
+ (find-class name)))
+
+
+
+(defun allocate-standard-instance-storage (class)
+ (let* ((slots (slot-value class 'slots))
+ (local-slots (sort (mapcan #'(lambda (slot)
+ (when (local-slot-p slot)
+ (list slot)))
+ slots)
+ #'<
+ :key #'(lambda (slot) (slot-value slot 'location))))
+ (shared-slots (mapcan #'(lambda (slot)
+ (when (not (local-slot-p slot))
+ (list slot)))
+ slots)))
+ (if (frozen-class-instance-p class)
+ (let ((local-alist (loop for slot in local-slots
+ for name = (slot-value slot 'name)
+ for type = (slot-value slot 'type)
+ collect `(,name ,+unbound-state+ ,type)))
+ (shared-alist (loop for slot in shared-slots
+ for name = (slot-value slot 'name)
+ for binding = (slot-value slot 'shared-binding)
+ collect (cons name binding))))
+ (nconc local-alist shared-alist))
+ (make-array (length local-slots) :initial-element +unbound-state+))))
+
+(defun class-slot-names (class)
+ (mapcar #'(lambda (slot) (slot-value slot 'name)) (slot-value class 'slots)))
+
+(defun standard-shared-initialize (instance slot-names initargs)
+ (when (eq slot-names 't)
+ (setq slot-names (class-slot-names (class-of instance))))
+ (mapc #'(lambda (slot)
+ (let ((name (slot-value slot 'name)))
+ (multiple-value-bind (key value tail)
+ (get-properties initargs (slot-value slot 'initargs))
+ (declare (ignore key))
+ (if tail
+ (setf (slot-value instance name) value)
+ (when (and (member name slot-names)
+ (not (slot-boundp instance name))
+ (slot-value slot 'initfunction))
+ (setf (slot-value instance name)
+ (funcall (slot-value slot 'initfunction))))))))
+ (slot-value (class-of instance) 'slots)))
+
+
+
+;; 4.3.5 Determining the Class Precedence List
+;; http://www.lispworks.com/reference/HyperSpec/Body/04_ce.htm
+(defun topological-sort (classes pairs)
+ (do (next
+ (unordered classes (remove next unordered))
+ (pairs pairs (remove-if #'(lambda (pair) (eq (first pair) next)) pairs))
+ (result nil (cons next result)))
+ ((null unordered) (nreverse result))
+ (setq next (let ((candidates (remove-if #'(lambda (class)
+ (find class pairs :key #'second))
+ unordered)))
+ (assert (not (null candidates)))
+ (if (endp (cdr candidates))
+ (car candidates)
+ (block picker
+ (dolist (class result)
+ (dolist (super (slot-value class 'direct-superclasses))
+ (when (find super candidates)
+ (return-from picker super))))))))))
+
+
+(defun compute-standard-class-precedence-list (class)
+ (labels ((direct-supers (class) (slot-value class 'direct-superclasses))
+ (superclasses (class)
+ (labels ((supers (class)
+ (unless (eq class (find-class 't 'errorp))
+ (let ((directs (direct-supers class)))
+ (append directs (mapappend #'supers directs))))))
+ (remove-duplicates (supers class))))
+ (local-precedence-order-pairs (class)
+ (unless (eq class (find-class 't 'errorp))
+ (let ((directs (direct-supers class)))
+ (mapcar #'list (cons class directs) directs))))
+ (pairs (classes)
+ (delete-duplicates (mapcan #'local-precedence-order-pairs classes)
+ :test #'equal)))
+ (let ((classes (cons class (superclasses class))))
+ (topological-sort classes (pairs classes)))))
+
+(defun class-precedence-names (class) ; for debug
+ (when (symbolp class) (setq class (find-class class 'errorp)))
+ (mapcar #'(lambda (class) (slot-value class 'name))
+ (slot-value class 'precedence-list)))
+
+
+
+;; 7.5.3 Inheritance of Slots and Slot Options
+;; http://www.lispworks.com/reference/HyperSpec/Body/07_ec.htm
+(defun and-types (types)
+ (labels ((type-eq (a b) (and (subtypep a b) (subtypep b a)))
+ (proper-subtype-p (subtype type)
+ (and (not (type-eq subtype type)) (subtypep subtype type))))
+ (let ((types (mapcan #'(lambda (type)
+ (when (notany #'(lambda (t1)
+ (proper-subtype-p t1 type))
+ types)
+ (list type)))
+ (remove-duplicates types :test #'type-eq))))
+ (if (endp (cdr types))
+ (car types)
+ `(and ,@types)))))
+
+(defun effective-slot-initargs (class name direct-slots)
+ (declare (ignorable class))
+ (assert (not (null direct-slots)))
+ (let* ((most-specific-slot (first direct-slots))
+ (allocation (slot-value most-specific-slot 'allocation))
+ (type (and-types (mapcar #'(lambda (slot) (slot-value slot 'type))
+ direct-slots)))
+ (shared-binding (slot-value most-specific-slot 'shared-binding)))
+ `(:name ,name
+ :allocation ,allocation
+ ,@(or (loop for slot in direct-slots
+ for initfunction = (slot-value slot 'initfunction)
+ if initfunction
+ return `(:initform ,(slot-value slot 'initform)
+ :initfunction ,(slot-value slot 'initfunction)))
+ '(:initform nil :initfunction nil))
+ :type ,type
+ :initargs ,(remove-duplicates
+ (mapappend #'(lambda (slot)
+ (slot-value slot 'initargs))
+ direct-slots))
+ :documentation ,(loop for slot in direct-slots
+ for documentation = (slot-value slot 'documentation)
+ if documentation return it)
+ :location nil
+ :shared-binding ,(prog1 shared-binding
+ (when shared-binding
+ (setf (cdr shared-binding) (list type)))))))
+
+(defun effective-slot-specs (class)
+ ;; effective-slot-spec::= (name ([[direct-slot-object*]]))
+ (let* ((direct-slots (mapappend #'(lambda (class)
+ (slot-value class 'direct-slots))
+ (slot-value class 'precedence-list)))
+ (names (remove-duplicates (mapcar #'(lambda (slot)
+ (slot-value slot 'name))
+ direct-slots))))
+ (mapcar #'(lambda (name)
+ (list name (loop for slot in direct-slots
+ if (eq name (slot-value slot 'name))
+ collect slot)))
+ names)))
+
+(defun standard-direct-slot-definition (slot-spec)
+ (setq slot-spec `(:shared-binding ,(when (eq :class
+ (getf slot-spec :allocation))
+ (list +unbound-state+))
+ ,@slot-spec :allocation :instance :type t))
+ (let ((class (ensure-class-object 'standard-direct-slot-definition)))
+ (apply #'make-system-instance class slot-spec)))
+
+(defun assign-slots-locations (slots)
+ (loop for slot in slots with location = 0
+ if (local-slot-p slot)
+ do (setf (slot-value slot 'location) location)
+ (incf location))
+ slots)
+
+(defun compute-system-class-slots (class)
+ (let* ((slot-class (ensure-class-object 'standard-effective-slot-definition))
+ (slots (mapcar #'(lambda (initargs)
+ (apply #'make-system-instance slot-class initargs))
+ (mapcar #'(lambda (spec)
+ (apply #'effective-slot-initargs class spec))
+ (effective-slot-specs class)))))
+ (assign-slots-locations slots)
+ slots))
+
+(defconstant +funcallable-instance-function-slot-name+
+ (gensym "FUNCALLABLE-INSTANCE-FUNCTION-SLOT-NAME-"))
+(defconstant +funcallable-instance-function-slot-spec+
+ (let ((name +funcallable-instance-function-slot-name+))
+ (eval (direct-slot-initargs-form `(,name :initarg ,name)))))
+
+(defun canonicalize-system-class-initargs (name &rest initargs &key
+ (metaclass 'standard-class)
+ direct-slots direct-superclasses
+ &allow-other-keys)
+ (when (eq metaclass 'funcallable-standard-class)
+ (push +funcallable-instance-function-slot-spec+ direct-slots))
+ (assert (not (null direct-superclasses)))
+ (setq direct-superclasses (mapcar #'ensure-class-object direct-superclasses)
+ direct-slots (mapcar #'standard-direct-slot-definition direct-slots))
+ `(:name ,name :version nil :slots nil :precedence-list nil
+ :default-initargs nil :finalized-p nil :direct-subclasses nil
+ :direct-superclasses ,direct-superclasses :direct-slots ,direct-slots
+ :direct-default-initargs nil :metaclass ,metaclass ,@initargs))
+
+(defun subclassp (subclass class)
+ (when (symbolp subclass) (setq subclass (find-class subclass 'errorp)))
+ (when (symbolp class) (setq class (find-class class 'errorp)))
+ (member class (slot-value subclass 'precedence-list)))
+(defun instancep (object class) (subclassp (class-of object) class))
+
+(defun canonicalize-system-instances (new-class)
+ (let ((name (slot-value new-class 'name)))
+ (cond
+ ((subclassp new-class (ensure-class-object 'base-class))
+ (loop for class being the hash-values of *classes*
+ do (when (eq (class-of class) new-class)
+ (canonicalize-instance class))))
+ ((eq name 'standard-direct-slot-definition)
+ (loop for class being the hash-values of *classes*
+ do (when (finalized-p class)
+ (dolist (slot (slot-value class 'direct-slots))
+ (canonicalize-instance slot)))))
+ ((eq name 'standard-effective-slot-definition)
+ (loop for class being the hash-values of *classes*
+ do (when (finalized-p class)
+ (dolist (slot (slot-value class 'slots))
+ (canonicalize-instance slot))))))))
+
+(defun finalize-system-class-inheritance (class)
+ (setf (slot-value class 'precedence-list)
+ (compute-standard-class-precedence-list class))
+ (setf (slot-value class 'slots)
+ (compute-system-class-slots class))
+ (setf (slot-value class 'default-initargs)
+ (compute-standard-default-initargs class))
+ (setf (slot-value class 'finalized-p) t)
+ (dolist (super (slot-value class 'direct-superclasses))
+ (pushnew class (slot-value super 'direct-subclasses)))
+
+ (canonicalize-system-instances class))
+
+(defun ensure-system-class (name &rest initargs)
+ (format t "~&ensure-system-class: class name = ~S~%" name)
+ (let* ((initargs (apply #'canonicalize-system-class-initargs name initargs))
+ (class (apply #'ensure-class-object name initargs)))
+ (finalize-system-class-inheritance class)
+ class))
+
+
+;;; Inheritance Structure of Metaobject Classes specified by MOP
+;; http://www.lisp.org/mop/concepts.html#inherit-struct-figure
+;;
+;; t-+- standard-object
+;; | +- a class defined by DEFCLASS
+;; | +- *metaobject -+- *specializer
+;; | | | +- *class -+- standard-class
+;; | | | | +- funcallable-standard-class
+;; | | | | +- forward-referenced-class
+;; | | | | +- structure-class
+;; | | | | +- built-in-class
+;; | | | +- eql-specializer
+;; | | +- *method - standard-method
+;; | | | +- *standard-accessor-method
+;; | | | + standard-reader-method
+;; | | | + standard-writer-method
+;; | | +- *method-combination
+;; | | +- *slot-definition
+;; | | | +- *effective-slot-definition ---------+
+;; | | | +- *direct-slot-definition --------+ |
+;; | +------+ | +- *standard-slot-definition | |
+;; | | | + standard-direct-slot-definition |
+;; | | | + standard-effective-slot-definition
+;; | | |
+;; | | +----------+
+;; +- function | |
+;; | | | |
+;; | funcallable-standard-object |
+;; | | |
+;; | | +-------------------+
+;; | | |
+;; | *generic-function
+;; | |
+;; | standard-generic-function
+;; |
+;; +- structure-object
+;; | |
+;; | +- a structure defined by DEFSTRUCT
+;;
+;; Each class marked with a ``*'' is an abstract class and is not
+;; intended to be instantiated. The results are undefined if an attempt
+;; is made to make an instance of one of these classes with make-instance.
+
+;; Current build time DEFCLASS limitations.
+;; * superclasses must be defclassed before their subclasses.
+;; * shared slots are not supported (partially implemented).
+
+(defclass t (t) ()
+ (:documentation "A superclass of every class, including itself.")
+ (:metaclass built-in-class))
+(defclass standard-object (t) ()
+ (:documentation "A superclass of every class that is an instance of standard-class except itself."))
+(defclass metaobject (standard-object) ()) ; mop abstract
+(defclass specializer (metaobject) ; mop abstract
+ ((direct-methods :reader specializer-direct-methods
+ :initarg :direct-methods :initform nil)
+ (direct-generic-functions :reader specializer-direct-generic-functions
+ :initarg :direct-generic-functions :initform nil)))
+
+
+(defclass class (specializer) ; clos abstract
+ ((name :accessor class-name :initarg :name :initform nil)))
+(defclass base-class (class)
+ ((version :accessor class-version :initarg :version :initform nil)
+ (slots :reader class-slots :initarg :slots :initform nil)
+ (direct-slots :reader class-direct-slots :initarg :direct-slots :initform nil)
+ (precedence-list :reader class-precedence-list
+ :initarg :precedence-list :initform nil)
+ (direct-superclasses :accessor class-direct-superclasses
+ :initarg :direct-superclasses :initform nil)
+ (direct-subclasses :accessor class-direct-subclasses
+ :initarg :direct-subclasses :initform nil)
+ (default-initargs :reader class-default-initargs
+ :initarg :default-initargs :initform nil)
+ (direct-default-initargs :reader class-direct-default-initargs
+ :initarg :direct-default-initargs :initform nil)
+ (finalized-p :reader class-finalized-p :initarg :finalized-p :initform nil)
+ (documentation :initform nil :initarg :documentation)))
+(defclass standard-base-class (base-class)
+ ((version :initform 0)
+ (old-classes :reader class-old-classes
+ :initform (make-array 1 :adjustable t :fill-pointer 0))
+ (dependents :initform nil)))
+(defclass standard-class (standard-base-class) ()) ; clos
+(defclass funcallable-standard-class (standard-base-class) ; mop
+ ((direct-superclasses
+ :initform (list (find-class 'funcallable-standard-object)))))
+(defclass forward-referenced-class (class) ; mop
+ ((direct-subclasses :accessor class-direct-subclasses :initform nil)))
+(defclass structure-class (base-class) ; clos
+ ()
+ (:metaclass structure-class))
+(defclass built-in-class (base-class) ()) ; clos
+(defclass old-class (class)
+ ((version :reader class-version)
+ (slots :reader class-slots)))
+
+
+(defvar *eql-specializers* (make-hash-table))
+(defclass eql-specializer (specializer) ; mop
+ ((object :initarg :object)))
+(defun eql-specializer-object (eql-specializer) ; mop
+ (slot-value eql-specializer 'object))
+(defun find-eql-specializer (object) (gethash object *eql-specializers*))
+(defun intern-eql-specializer (object) ; mop
+ (or (find-eql-specializer object)
+ (setf (gethash object *eql-specializers*)
+ (make-instance 'eql-specializer :object object))))
+
+
+(defclass slot-definition (metaobject) ()) ; mop abstract
+(defclass standard-slot-definition (slot-definition) ; mop abstract
+ ((name :reader slot-definition-name :initarg :name)
+ (type :reader slot-definition-type :initarg :type :initform 't)
+ (allocation :reader slot-definition-allocation
+ :initarg :allocation :initform :instance)
+ (initargs :reader slot-definition-initargs :initarg :initargs)
+ (initform :reader slot-definition-initform :initarg :initform)
+ (initfunction :reader slot-definition-initfunction
+ :initarg :initfunction)
+ (shared-binding :reader slot-definition-shared-binding
+ :initarg :shared-binding)
+ (documentation :initarg :documentation))
+ (:default-initargs :name (error "Slot name must be specified.")))
+(defclass direct-slot-definition (slot-definition) ; mop abstract
+ ((readers :reader slot-definition-readers :initarg :readers)
+ (writers :reader slot-definition-writers :initarg :writers)))
+(defclass effective-slot-definition (slot-definition) ; mop abstract
+ ((location :reader slot-definition-location :initarg :location)))
+(defclass standard-direct-slot-definition (standard-slot-definition
+ direct-slot-definition) ; mop
+ ())
+(defclass standard-effective-slot-definition (standard-slot-definition
+ effective-slot-definition) ; mop
+ ())
+
+
+(defclass method (metaobject) ()) ; clos abstract
+(defclass standard-method (method) ; clos
+ ((function :reader method-function :initarg :function)
+ (qualifiers :reader method-qualifiers :initarg :qualifiers)
+ (specializers :reader method-specializers :initarg :specializers)
+ (specialized-lambda-list :reader method-specialized-lambda-list
+ :initarg :specialized-lambda-list)
+ (lambda-list :reader method-lambda-list :initarg :lambda-list)
+ (generic-function :reader method-generic-function
+ :initarg :generic-function)
+ ))
+(defclass standard-accessor-method (standard-method) ()) ; mop abstract
+(defclass standard-reader-method (standard-accessor-method) ; mop
+ ())
+(defclass standard-writer-method (standard-accessor-method) ; mop
+ ())
+
+
+(defclass function (t) () (:metaclass built-in-class))
+(defclass funcallable-standard-object (standard-object function) ; mop
+ ()
+ (:metaclass funcallable-standard-class))
+(defun funcallable-instance-function (funcallable-instance)
+ (slot-value funcallable-instance +funcallable-instance-function-slot-name+))
+
+(defun set-funcallable-instance-function (funcallable-instance function) ; mop
+ (setf (slot-value funcallable-instance
+ +funcallable-instance-function-slot-name+)
+ function))
+(defclass generic-function (metaobject funcallable-standard-object) ()
+ ;; clos abstract
+ (:metaclass funcallable-standard-class))
+(defclass standard-generic-function (generic-function) ; clos
+ ((name :reader generic-function-name :initarg :name)
+ (lambda-list :reader generic-function-lambda-list
+ :initarg :lambda-list)
+ (argument-precedence-order :reader generic-function-argument-precedence-order
+ :initarg :argument-precedence-order)
+ (declarations :reader generic-function-declarations
+ :initarg :declarations)
+ (method-class :reader generic-function-method-class
+ :initarg :method-class)
+ (method-combination :reader generic-function-method-combination
+ :initarg :method-combination)
+ (methods :reader generic-function-methods :initarg :methods)
+
+ (number-of-required-args :reader number-of-required-args
+ :initarg :number-of-required-args)
+ (applicable-methods :reader generic-function-applicable-methods
+ :initform (make-hash-table))
+ (effective-methods :reader generic-function-effective-methods
+ :initform (make-hash-table :test #'equal))
+ (dependents :initform nil)))
+
+
+(defclass structure-object (t) ()
+ (:documentation "A superclass of every class that is an instance of structure-class except itself.")
+ (:metaclass structure-class))
+
+
+;; Classes that correspond to pre-defined type specifiers
+;; http://www.lispworks.com/reference/HyperSpec/Body/04_cg.htm#classtypecorrespondence
+(defclass symbol (t) () (:metaclass built-in-class))
+(defclass character (t) () (:metaclass built-in-class))
+(defclass hash-table (t) () (:metaclass built-in-class))
+
+(defclass sequence (t) () (:metaclass built-in-class))
+(defclass list (sequence) () (:metaclass built-in-class))
+(defclass cons (list) () (:metaclass built-in-class))
+(defclass null (symbol list) () (:metaclass built-in-class))
+(defclass array (t) () (:metaclass built-in-class))
+(defclass vector (array sequence) () (:metaclass built-in-class))
+(defclass bit-vector (vector) () (:metaclass built-in-class))
+(defclass string (vector) () (:metaclass built-in-class))
+
+(defclass number (t) () (:metaclass built-in-class))
+(defclass complex (number) () (:metaclass built-in-class))
+(defclass real (number) () (:metaclass built-in-class))
+(defclass float (real) () (:metaclass built-in-class))
+(defclass rational (real) () (:metaclass built-in-class))
+(defclass ratio (rational) () (:metaclass built-in-class))
+(defclass integer (rational) () (:metaclass built-in-class))
+
+(defclass stream (t) () (:metaclass built-in-class))
+(defclass broadcast-stream (stream) () (:metaclass built-in-class))
+(defclass concatenated-stream (stream) () (:metaclass built-in-class))
+(defclass string-stream (stream) () (:metaclass built-in-class))
+(defclass echo-stream (stream) () (:metaclass built-in-class))
+(defclass synonym-stream (stream) () (:metaclass built-in-class))
+(defclass file-stream (stream) () (:metaclass built-in-class))
+(defclass two-way-stream (stream) () (:metaclass built-in-class))
+
+(defclass pathname (t) () (:metaclass built-in-class))
+(defclass logical-pathname (pathname) () (:metaclass built-in-class))
+
+(defclass package (t) () (:metaclass built-in-class))
+(defclass random-state (t) () (:metaclass built-in-class))
+(defclass readtable (t) () (:metaclass built-in-class))
+(defclass restart (t) () (:metaclass built-in-class))
+
+
+
+(defclass method-combination (metaobject) ()) ; clos
+(defstruct method-combination-type
+ (name)
+ (lambda-list)
+ (group-specifiers)
+ (args-lambda-list)
+ (generic-function-symbol)
+ (documentation)
+ (function)
+ (short-form-options))
+(defclass standard-method-combination (method-combination) ; clos
+ ((type :reader method-combination-type :initarg :type)
+ (arguments :reader method-combination-arguments :initarg :arguments)))
+
+(defparameter *method-combination-types* (make-hash-table))
+
+(defun define-method-combination-type (name &rest initargs)
+ (let ((combination-type (apply #'make-method-combination-type
+ :allow-other-keys t :name name initargs)))
+ (setf (gethash name *method-combination-types*) combination-type)))
+
+(defun method-group-p (selecter qualifiers)
+ ;; selecter::= qualifier-pattern | predicate
+ (etypecase selecter
+ (list (or (equal selecter qualifiers)
+ (let ((last (last selecter)))
+ (when (eq '* (cdr last))
+ (let* ((prefix `(,@(butlast selecter) ,(car last)))
+ (pos (mismatch prefix qualifiers)))
+ (or (null pos) (= pos (length prefix))))))))
+ ((eql *) t)
+ (symbol (funcall (symbol-function selecter) qualifiers))))
+
+(defun check-variable-name (name)
+ (flet ((valid-variable-name-p (name)
+ (and (symbolp name) (not (constantp name)))))
+ (assert (valid-variable-name-p name))))
+
+(defun canonicalize-method-group-spec (spec)
+ ;; spec ::= (name {qualifier-pattern+ | predicate} [[long-form-option]])
+ ;; long-form-option::= :description description | :order order |
+ ;; :required required-p
+ ;; a canonicalized-spec is a simple plist.
+ (let* ((rest spec)
+ (name (prog2 (check-variable-name (car rest))
+ (car rest)
+ (setq rest (cdr rest))))
+ (option-names '(:description :order :required))
+ (selecters (let ((end (or (position-if #'(lambda (it)
+ (member it option-names))
+ rest)
+ (length rest))))
+ (prog1 (subseq rest 0 end)
+ (setq rest (subseq rest end)))))
+ (description (getf rest :description ""))
+ (order (getf rest :order :most-specific-first))
+ (required-p (getf rest :required)))
+ `(:name ,name
+ :predicate #'(lambda (qualifiers)
+ (loop for item in ',selecters
+ thereis (method-group-p item qualifiers)))
+ :description ,description
+ :order ,order
+ :required ,required-p)))
+
+(defconstant +gf-args-variable+ (gensym "GF-ARGS-VARIABLE-")
+ "A Variable name whose value is a list of all arguments to a generic function.")
+
+(defun extract-required-part (lambda-list)
+ (flet ((skip (key lambda-list)
+ (if (eq (first lambda-list) key)
+ (cddr lambda-list)
+ lambda-list)))
+ (ldiff (skip '&environment (skip '&whole lambda-list))
+ (member-if #'(lambda (it) (member it lambda-list-keywords))
+ lambda-list))))
+
+(defun extract-specified-part (key lambda-list)
+ (case key
+ ((&eval &whole)
+ (list (second (member key lambda-list))))
+ (t
+ (let ((here (cdr (member key lambda-list))))
+ (ldiff here
+ (member-if #'(lambda (it) (member it lambda-list-keywords))
+ here))))))
+
+(defun extract-optional-part (lambda-list)
+ (extract-specified-part '&optional lambda-list))
+
+(defun parse-define-method-combination-arguments-lambda-list (lambda-list)
+ ;; Define-method-combination Arguments Lambda Lists
+ ;; http://www.lispworks.com/reference/HyperSpec/Body/03_dj.htm
+ (let ((required (extract-required-part lambda-list))
+ (whole (extract-specified-part '&whole lambda-list))
+ (optional (extract-specified-part '&optional lambda-list))
+ (rest (extract-specified-part '&rest lambda-list))
+ (keys (extract-specified-part '&key lambda-list))
+ (aux (extract-specified-part '&aux lambda-list)))
+ (values (first whole)
+ required
+ (mapcar #'(lambda (spec)
+ (if (consp spec)
+ `(,(first spec) ,(second spec) ,@(cddr spec))
+ `(,spec nil)))
+ optional)
+ (first rest)
+ (mapcar #'(lambda (spec)
+ (let ((key (if (consp spec) (car spec) spec))
+ (rest (when (consp spec) (rest spec))))
+ `(,(if (consp key) key `(,(%keyword key) ,key))
+ ,(car rest)
+ ,@(cdr rest))))
+ keys)
+ (mapcar #'(lambda (spec)
+ (if (consp spec)
+ `(,(first spec) ,(second spec))
+ `(,spec nil)))
+ aux))))
+
+(defmacro getk (plist key init-form)
+ "Similar to getf except eval and return INIT-FORM if KEY has no value in PLIST."
+ (let ((not-exist (gensym))
+ (value (gensym)))
+ `(let ((,value (getf ,plist ,key ,not-exist)))
+ (if (eq ,not-exist ,value) ,init-form ,value))))
+
+(defmacro with-args-lambda-list (args-lambda-list generic-function-symbol
+ &body forms)
+ (let ((gf-lambda-list (gensym))
+ (nrequired (gensym))
+ (noptional (gensym))
+ (rest-args (gensym)))
+ (multiple-value-bind (whole required optional rest keys aux)
+ (parse-define-method-combination-arguments-lambda-list args-lambda-list)
+ `(let* ((,gf-lambda-list (slot-value ,generic-function-symbol 'lambda-list))
+ (,nrequired (length (extract-required-part ,gf-lambda-list)))
+ (,noptional (length (extract-optional-part ,gf-lambda-list)))
+ (,rest-args (subseq ,+gf-args-variable+ (+ ,nrequired ,noptional)))
+ ,@(when whole `((,whole ,+gf-args-variable+)))
+ ,@(loop for var in required and i upfrom 0
+ collect `(,var (when (< ,i ,nrequired)
+ (nth ,i ,+gf-args-variable+))))
+ ,@(loop for (var init-form) in optional and i upfrom 0
+ collect
+ `(,var (if (< ,i ,noptional)
+ (nth (+ ,nrequired ,i) ,+gf-args-variable+)
+ ,init-form)))
+ ,@(when rest `((,rest ,rest-args)))
+ ,@(loop for ((key var) init-form) in keys and i upfrom 0
+ collect `(,var (getk ,rest-args ',key ,init-form)))
+ ,@(loop for (var init-form) in aux and i upfrom 0
+ collect `(,var ,init-form)))
+ ,@forms))))
+
+(defun invalid-method-error (method format-control &rest args)
+ (declare (ignorable method))
+ (apply #'error format-control args))
+
+(defun method-combination-error (format-control &rest args)
+ (apply #'error format-control args))
+
+(defmacro with-method-groups (method-group-specs methods-form &body forms)
+ (flet ((grouping-form (spec methods-var)
+ (let ((predicate (getf spec :predicate))
+ (group (gensym))
+ (leftovers (gensym))
+ (method (gensym)))
+ `(let ((,group '())
+ (,leftovers '()))
+ (dolist (,method ,methods-var)
+ (if (funcall ,predicate (slot-value ,method 'qualifiers))
+ (push ,method ,group)
+ (push ,method ,leftovers)))
+ (ecase ,(getf spec :order)
+ (:most-specific-last )
+ (:most-specific-first (setq ,group (nreverse ,group))))
+ ,@(when (getf spec :required)
+ `((when (null ,group)
+ (error "Method group ~S must not be empty."
+ ',(getf spec :name)))))
+ (setq ,methods-var (nreverse ,leftovers))
+ ,group))))
+ (let ((rest (gensym))
+ (method (gensym)))
+ `(let* ((,rest ,methods-form)
+ ,@(mapcar #'(lambda (spec)
+ `(,(getf spec :name) ,(grouping-form spec rest)))
+ method-group-specs))
+ (dolist (,method ,rest)
+ (invalid-method-error ,method
+ "Method ~S with qualifiers ~S does not~ belong ~
+ to any method group."
+ ,method (slot-value ,method 'qualifiers)))
+ ,@forms))))
+
+(defun method-combination-type-lambda
+ (&key name lambda-list args-lambda-list generic-function-symbol
+ method-group-specs declarations forms &allow-other-keys)
+ (let ((methods (gensym)))
+ `(lambda (,generic-function-symbol ,methods ,@lambda-list)
+ ,@declarations
+ (let ((*message-prefix* ,(format nil "METHOD COMBINATION TYPE ~S: " name)))
+ (with-method-groups ,method-group-specs
+ ,methods
+ ,@(if (null args-lambda-list)
+ forms
+ `((with-args-lambda-list ,args-lambda-list
+ ,generic-function-symbol
+ ,@forms))))))))
+
+(defun long-form-method-combination-args (args)
+ ;; define-method-combination name lambda-list (method-group-specifier*) args
+ ;; args ::= [(:arguments . args-lambda-list)]
+ ;; [(:generic-function generic-function-symbol)]
+ ;; [[declaration* | documentation]] form*
+ (let ((rest args))
+ (labels ((nextp (key) (and (consp (car rest)) (eq key (caar rest))))
+ (args-lambda-list ()
+ (when (nextp :arguments)
+ (prog1 (cdr (car rest)) (setq rest (cdr rest)))))
+ (generic-function-symbol ()
+ (if (nextp :generic-function)
+ (prog1 (second (car rest)) (setq rest (cdr rest)))
+ (gensym)))
+ (declaration* ()
+ (let ((end (position-if-not #'declarationp rest)))
+ (when end
+ (prog1 (subseq rest 0 end) (setq rest (nthcdr end rest))))))
+ (documentation? ()
+ (when (stringp (car rest))
+ (prog1 (car rest) (setq rest (cdr rest)))))
+ (form* () rest))
+ (let ((declarations '()))
+ `(:args-lambda-list ,(args-lambda-list)
+ :generic-function-symbol ,(generic-function-symbol)
+ :documentation ,(prog2 (setq declarations (declaration*))
+ (documentation?))
+ :declarations (,@declarations ,@(declaration*))
+ :forms ,(form*))))))
+
+(defun define-long-form-method-combination (name lambda-list method-group-specs
+ &rest args)
+ (let* ((initargs `(:name ,name
+ :lambda-list ,lambda-list
+ :method-group-specs
+ ,(mapcar #'canonicalize-method-group-spec method-group-specs)
+ ,@(long-form-method-combination-args args)))
+ (lambda-expression (apply #'method-combination-type-lambda initargs)))
+ ;;(format t "~&~S~%" lambda-expression)
+ (apply #'define-method-combination-type name
+ `(,@initargs
+ :function ,(compile nil lambda-expression)
+ :short-form-options nil))))
+
+(defun define-short-form-method-combination
+ (name &key identity-with-one-argument (documentation "") (operator name))
+ (define-long-form-method-combination name
+ '(&optional (order :most-specific-first))
+ `((around (:around))
+ (primary (,name) :order order :required t))
+ documentation
+ `(let ((form (if (and ,identity-with-one-argument (null (rest primary)))
+ `(call-method ,(first primary))
+ (cons ',operator (mapcar #'(lambda (method)
+ `(call-method ,method))
+ primary)))))
+ (if around
+ `(call-method ,(first around) (,@(rest around) (make-method ,form)))
+ form)))
+ (let ((combination-type (gethash name *method-combination-types*)))
+ (setf (method-combination-type-short-form-options combination-type)
+ `(:documentation ,documentation
+ :operator ,operator
+ :identity-with-one-argument ,identity-with-one-argument)))
+ name)
+
+(defmacro define-method-combination (name &rest args) ; clos
+ "Define new types of method combination."
+ (format t "~&define-method-combination: ~S~%" name)
+ `(let ((*message-prefix*
+ ,(format nil "DEFINE-METHOD-COMBINATION ~S: " name)))
+ (apply #',(if (listp (first args))
+ 'define-long-form-method-combination
+ 'define-short-form-method-combination) ',name ',args)))
+
+
+;; 7.6.6.4 Built-in Method Combination Types
+;; http://www.lispworks.com/reference/HyperSpec/Body/07_ffd.htm
+(define-method-combination + :identity-with-one-argument t)
+(define-method-combination and :identity-with-one-argument t)
+(define-method-combination append :identity-with-one-argument t)
+(define-method-combination list :identity-with-one-argument t)
+(define-method-combination max :identity-with-one-argument t)
+(define-method-combination min :identity-with-one-argument t)
+(define-method-combination nconc :identity-with-one-argument t)
+(define-method-combination or :identity-with-one-argument t)
+(define-method-combination progn :identity-with-one-argument t)
+(define-method-combination standard ()
+ ((around (:around))
+ (before (:before))
+ (primary () :required t)
+ (after (:after)))
+ (flet ((call-methods (methods)
+ (mapcar #'(lambda (method)
+ `(call-method ,method))
+ methods)))
+ (let ((form (if (or before after (rest primary))
+ `(multiple-value-prog1
+ (progn ,@(call-methods before)
+ (call-method ,(first primary)
+ ,(rest primary)))
+ ,@(call-methods (reverse after)))
+ `(call-method ,(first primary)))))
+ (if around
+ `(call-method ,(first around)
+ (,@(rest around)
+ (make-method ,form)))
+ form))))
+
+
+;;;;
+;#|
+
+;; AMOP 5.4.5 The defgeneric Macro
+;; http://www.lisp.org/mop/concepts.html#defgeneric
+;;
+;; AMOP 5.4.3 The defmethod Macro
+;; http://www.lisp.org/mop/concepts.html#defmethod
+;; AMOP 5.4.4 Processing Method Bodies
+;; http://www.lisp.org/mop/concepts.html#processing-method-bodies
+
+(defvar *generic-functions* (make-hash-table))
+(defun find-generic-function (symbol &optional errorp)
+ (let ((symbol-function function))
+ (if (instancep function 'generic-function)
+ function
+ (multiple-value-bind (generic-function presentp)
+ (gethash discriminating-function *generic-functions*)
+ (if presentp
+ generic-function
+ (when errorp
+ (error "Generic function ~S does not exist." symbol)))))))
+(defun install-generic-function (symbol gf)
+ (let (discriminating-function (compute-discriminating-function gf))
+ (if *symbol-function-is-funcallable-object-p*
+ (when symbol (setf (symbol-function symbol) gf))
+ (progn
+ (remhash (funcallable-instance-function gf) *generic-functions*)
+ (setf (gethash discriminating-function *generic-functions*) gf)
+ (when symbol (setf (symbol-function symbol) discriminating-function))))
+ (set-funcallable-instance-function gf discriminating-function)
+ gf))
+
+
+(defun method-spec (method-description)
+ ;; method-description::= (:method method-qualifier* specialized-lambda-list
+ ;; [[declaration* | documentation]] form*)
+ (let ((rest (progn
+ (assert (eq :method (car method-description)))
+ (cdr method-description))))
+ (flet ((qualifier* ()
+ (let* ((end (or (position-if #'consp rest)
+ (error "No specialized lambda list found in ~S."
+ method-description)))
+ (method-qualifiers (subseq rest 0 end)))
+ (assert (notany #'listp method-qualifiers))
+ (prog1 method-qualifiers (setq rest (nthcdr end rest)))))
+ (lambda-list1 ()
+ (let ((specialized-lambda-list (car rest)))
+ (validate-specialized-lambda-list specialized-lambda-list)
+ (prog1 specialized-lambda-list (setq rest (cdr rest)))))
+ (declaration* ()
+ (let ((end (position-if-not #'declarationp rest)))
+ (when end
+ (prog1 (subseq rest 0 end) (setq rest (nthcdr end rest))))))
+ (documentation? ()
+ (when (stringp (car rest))
+ (prog1 (car rest) (setq rest (cdr rest)))))
+ (form* () rest))
+ `(:qualifiers ,(qualifier*)
+ :specialized-lambda-list ,(lambda-list1)
+ ,@(let ((decls (declaration*)))
+ `(:documentation ,(documentation?)
+ :declarations ,(mapappend #'cdr `(,@decls ,@(declaration*)))))
+ :forms ,(form*)))))
+
+(defun method-spec-to-ensure-generic-function-form (name spec env)
+ (let* ((lambda-list (extract-lambda-list (getf spec :specialized-lambda-list)))
+ (options (canonicalize-defgeneric-options lambda-list '())))
+ `(ensure-generic-function ,name :environment ,env ,@options)))
+
+(defun allow-other-keys (lambda-list)
+ (if (and (member '&key lambda-list)
+ (not (member '&allow-other-keys lambda-list)))
+ (let* ((key-end (or (position &aux lambda-list) (length lambda-list)))
+ (aux-part (subseq lambda-list key-end)))
+ `(,@(subseq lambda-list 0 key-end) &allow-other-keys ,@aux-part))
+ lambda-list))
+
+(defun make-system-method-lambda ()
+ )
+
+(defun <make-method-lambda>
+ (generic-function method lambda-expression environment)
+ (funcall (if *mop-working-p* #'make-method-lambda #'make-system-method-lambda)
+ generic-function method lambda-expression environment))
+
+(defun <class-prototype> (class)
+ (funcall (if *mop-working-p* #'class-prototype #'make-system-instance)
+ class))
+
+(defun method-initargs-form (gf-form environment &key initial-method-p
+ null-lexical-environment-p specialized-lambda-list
+ qualifiers documentation declarations forms)
+ (let* ((lambda-list (extract-lambda-list specialized-lambda-list))
+ (specializer-names (extract-specializer-names specialized-lambda-list))
+ (gf (gensym))
+ (methods (gensym)) ;; used by make-method-lambda
+ (lambda-expression (gensym))
+ (initargs (gensym)))
+ `(let* ((,gf ,gf-form)
+ (,method-class (slot-value ,gf 'method-class)))
+ (multiple-value-bind (,lambda-expression ,initargs)
+ (<make-method-lambda> ,gf
+ (<class-prototype> ,method-class)
+ '(lambda (,+gf-args-variable+ ,methods)
+ (apply #'(lambda ,(allow-other-keys lambda-list)
+ (declare ,@declarations)
+ ,@forms)
+ ,+gf-args-variable+))
+ ,environment)
+ (append ,initargs
+ (list
+ :qualifiers ',qualifiers
+ :specialized-lambda-list ',specialized-lambda-list
+ :lambda-list ',lambda-list
+ :specializers (mapcar #'find-class ,specializer-names)
+ :documentation ',documentation
+ :function (compile nil ,(if null-lexical-environment-p
+ `(eval ,lambda-expression)
+ 'lambda-expression))
+ :initial-method-p ,initial-method-p)))))))
+
+
+(defun check-defgeneric-declarations (declarations)
+
+ )
+
+(defun check-singleton-options (options valid-option-names)
+ (flet ((redundant-option-error (option-name)
+ (error 'simple-program-error
+ :format-control "~AOption ~S is given more than once."
+ :format-arguments (list *message-prefix* option-name)))
+ (invalid-option-error (option-name)
+ (error 'simple-program-error
+ :format-control "~AInvalid option ~S is given."
+ :format-arguments (list *message-prefix* option-name))))
+ (loop for (key . rest) in options with processed = '()
+ when (member key processed) do (redundant-option-error key)
+ when (not (member key valid-option-names)) do (invalid-option-error key)
+ do (push key processed)))
+
+(defvar generic-function-initarg-names
+ '(:argument-precedence-order :declare :documentation :environment
+ :generic-function-class :lambda-list :method-class :method-combination))
+
+(defun generic-function-initargs-form (options)
+ (check-singleton-options options generic-function-initarg-names)
+ (flet ((value-form (key rest)
+ (case key
+ ((:documentation :environment :generic-function-class
+ :method-class :lambda-list)
+ (destructuring-bind (value) rest (qt? value)))
+ (t (qt? rest)))))
+ (loop for (key . rest) in options
+ when (eq key :declare) do (setq key :declarations)
+ nconc `(,(qt? key) ,(value-form key rest)) into result
+ finally (return `(list ,@result)))))
+
+(defun ensure-system-generic-function (name &rest initargs)
+
+ )
+
+(defun add-system-method (generic-function method)
+ )
+
+(defun <ensure-generic-function> (name &rest initargs)
+ (apply (if *mop-working-p*
+ #'ensure-generic-function
+ #'ensure-system-generic-function)
+ name initargs))
+
+(defun <make-instance> (name &rest initargs)
+ (apply (if *mop-working-p* #'make-instance #'make-system-instance)
+ name initargs))
+
+(defun <add-method> (generic-function method)
+ (funcall (if *mop-working-p* #'add-method #'add-system-method)
+ generic-function method))
+
+(defmacro defgeneric (name lambda-list &body args &environment env) ; clos
+ "Define a generic function named NAME."
+ (let* ((*message-prefix* (format nil "DEFGENERIC ~S: " name))
+ (method-descriptions (loop for spec in args
+ if (eq (first spec) :method) collect spec))
+ (declarations (loop for spec in args
+ if (eq (first spec) 'declare) append (rest spec)))
+ (options `((:lambda-list ,lambda-list)
+ (:environment ,env)
+ ,@(when declarations `((:declare ,@declarations)))
+ ,@(loop for spec in args
+ unless (member (first spec) '(:method declare))
+ collect spec)))
+ (gf (gensym))
+ (method-class (gensym))
+ (methods (gensym)))
+ (check-defgeneric-declarations declarations)
+ `(let* ((*message-prefix* ,*message-prefix*)
+ (,gf (apply #'<ensure-generic-function> ',name
+ ,(generic-function-initargs-form options)))
+ (,method-class (generic-function-method-class ,gf))
+ (,methods (list ,@(mapcar
+ #'(lambda (spec)
+ `(apply #'<make-instance> ,method-class
+ :initial-method-p t
+ ,(apply #'method-initargs-form gf env spec)))
+ (mapcar #'method-spec method-descriptions)))))
+ (mapc #'(lambda (method) (<add-method> ,gf method)) ,methods)
+ ,gf)))))
+
+(defmacro defmethod (name &rest args &environment env) ; clos
+ "Define a method named NAME."
+ (let ((spec (method-spec `(:method ,@args)))
+ (gf (gensym))
+ (method (gensym)))
+ `(let* ((,gf (or (find-generic-function name)
+ ,(method-spec-to-ensure-generic-function-form
+ name spec env)))
+ (,method (apply #'<make-instance>
+ (generic-function-method-class ,gf)
+ (method-initargs-form ,gf ,env ,@spec))))
+ (<add-method> ,gf ,method)
+ ,method)))
+
+(defgeneric ensure-class-using-class (class name &key direct-default-initargs direct-slots direct-superclasses metaclass &allow-other-keys)) ; mop
+
+(defmethod ensure-class-using-class ((class class) name &key (metaclass 'standard-class) direct-superclasses &allow-other-keys)
+ (check-type class metaclass)
+ (apply #'reinitialize-instance class initargs))
+
+(defmethod ensure-class-using-class ((class forward-referenced-class) name &rest initargs &key (metaclass 'standard-class) direct-superclasses &allow-other-keys)
+ (apply #'change-class class metaclass initargs))
+
+(defmethod ensure-class-using-class ((class null) name &rest initargs
+ &key (metaclass 'standard-class)
+ direct-superclasses &allow-other-keys)
+ (setf (find-class name) (apply #'make-instance metaclass initargs)))
+
+(defun ensure-class (name &rest args &key &allow-other-keys) ; mop
+ (apply #'ensure-class-using-class (find-class name) name args))
+
+
+
+(defgeneric compute-class-precedence-list (class)) ; mop
+(defmethod compute-class-precedence-list ((class class))
+ (compute-standard-class-precedence-list class))
+
+
+(defgeneric compute-default-initargs (class)) ; mop
+(defmethod compute-default-initargs ((class standard-base-class))
+ (compute-standard-default-initargs class))
+
+
+(defgeneric effective-slot-definition-class (class &rest initargs)) ; mop
+(defmethod effective-slot-definition-class ((class standard-base-class)
+ &rest initargs)
+ (find-class 'standard-effective-slot-definition))
+(defgeneric compute-effective-slot-definition
+ (class name direct-slot-definitions)) ; mop
+(defmethod compute-effective-slot-definition ((class standard-base-class)
+ name direct-slot-definitions)
+ (apply #'make-instance
+ (apply #'effective-slot-definition-class class initargs)
+ (effective-slot-initargs class name direct-slot-definitions)))
+(defgeneric compute-slots (class)) ; mop
+(defmethod compute-slots :around ((class standard-base-class))
+ (let ((slots (call-next-method)))
+ (assign-slots-locations slots)
+ slots))
+(defmethod compute-slots ((class standard-base-class))
+ (loop for (name direct-slots) in (effective-slot-specs class)
+ collect (compute-effective-slot-definition class name direct-slots)))
+
+
+(defgeneric finalize-inheritance (class)) ; mop
+(defmethod finalize-inheritance ((class standard-base-class))
+ ;; see "Class Finalization Protocol"
+ ;; http://www.lisp.org/mop/concepts.html#class-finalization-protocol
+ (setf (slot-value class 'precedence-list) (compute-class-precedence-list class))
+ (setf (slot-value class 'default-initargs) (compute-default-initargs class))
+ (setf (slot-value class 'slots) (compute-slots class))
+ (setf (slot-value class 'finalized-p) t)
+
+ class)
+(defmethod finalize-inheritance ((class forward-referenced-class))
+ (error "Cannot finalize inheritance for forward-referenced-class object."))
+;; ! write an after method which computes a hash-table of slot-names and
+;; slot-definition objects which will be used in find-slot.
+
+
+(defgeneric allocate-instance (class &rest initargs &key &allow-other-keys)
+ (:documentation ;; clos
+ "Create and return a new instance of CLASS, without initializing it."))
+(defmethod allocate-instance ((class standard-base-class) &rest initargs)
+ (make-%standard-object :class class
+ :version (slot-value class 'version)
+ :storage (allocate-standard-instance-storage class)))
+(defmethod allocate-instance ((class structure-class) &rest initargs)
+ (error "allocate-instance specialized for structure-class is not implemented."))
+(defmethod allocate-instance ((class built-in-class) &rest initargs)
+ (error "`allocate-instance' is not applicable to built-in-class."))
+
+(defgeneric validate-superclass (class superclass)) ; mop
+(defmethod validate-superclass ((class class) (superclass class))
+ (let ((class-of-class (class-of class-of))
+ (class-of-superclass (class-of superclass))
+ (standard-class (find-class 'standard-class))
+ (funcallable-standard-class (find-class 'funcallable-standard-class)))
+ ;; http://www.lisp.org/mop/dictionary.html#validate-superclass
+ (or (eq superclass (find-class 't))
+ ;; (i) If the superclass argument is the class named t,
+ (eq class-of-superclass class-of-class)
+ ;; (ii) if the class of the class argument is the same as
+ ;; the class of the superclass argument or
+ (and (eq class-of-class standard-class)
+ (eq class-of-superclass funcallable-standard-class))
+ (and (eq class-of-class funcallable-standard-class)
+ (eq class-of-superclass standard-class))
+ ;; (iii) if the classes one of the arguments is standard-class and
+ ;; the class of the other is funcallable-standard-class.
+ )))
+
+(defun canonicalize-direct-superclasses (class direct-superclasses)
+ (flet ((superclass (designator)
+ (etypecase designator
+ (symbol (or (find-class designator)
+ (ensure-class designator
+ :metaclass 'forward-referenced-class)))
+ (class designator))))
+ (mapcar #'(lambda (designator)
+ (let ((superclass (superclass designator)))
+ (unless (validate-superclass class superclass)
+ (error "~S cannot be a superclass of ~S"
+ superclass class))
+ superclass))
+ direct-superclasses)))
+
+(defgeneric shared-initialize (instance slot-names &rest initargs
+ &key &allow-other-keys)
+ (:documentation ;; clos
+ "Fill the slots of INSTANCE using INITARGS and :initform forms."))
+
+(defmethod shared-initialize ((instance standard-object) slot-names
+ &rest initargs)
+ (standard-shared-initialize instance slot-names initargs))
+
+(defgeneric check-initargs (instance gf-args-pairs initargs))
+(defmethod check-initargs ((instance standard-object) gf-args-pairs initargs)
+ (unless (getf initargs :allow-other-keys)
+ (let* ((class (class-of instance))
+ (valid-keys
+ (remove-duplicates
+ (nconc (mapappend #'function-keywords
+ (mapappend #'(lambda (gf-args-pair)
+ (apply #'applicable-methods
+ gs-args-pair))
+ gf-args-pairs))
+ (mapappend #'slot-definition-initargs (class-slots class))
+ '(:allow-other-keys))))
+ (keys (remove-duplicates (plist-keys initargs)))
+ (invalid-keys (set-difference keys valid-keys)))
+ (when invalid-keys
+ (error "Invalid initialization argument keyword~P: ~S"
+ (length invalid-keys) invalid-keys)))))
+(defmethod check-initargs ((instance standard-slot-definition)
+ gf-args-pairs initargs)
+ (let ((initform-supplied-p (plist-member :initform initargs))
+ (initfunction-supplied-p (plist-member :initfunction initargs)))
+ (assert (or (and initform-supplied-p initfunction-supplied-p)
+ (and (not initform-supplied-p) (not initfunction-supplied-p))))
+ (when (and (not initform-supplied-p) (not initfunction-supplied-p))
+ (setq initargs `(:initform nil :initfunction nil ,@initargs)))
+ (call-next-method instance gf-args-pairs initargs)))
+
+;; ... more check-initargs methods
+
+
+(defmethod shared-initialize ((instance standard-base-class) slot-names
+ &rest initargs
+ &key (direct-slots "never used" direct-slots-p))
+ (flet ((direct-slot (class spec)
+ (apply #'make-instance
+ (apply #'direct-slot-definition-class class spec)
+ spec)))
+ (when direct-slots-p
+ (setq initargs
+ `(:direct-slots ,(mapcar #'(lambda (spec) (direct-slot instance spec))
+ direct-slots)
+ ,@initargs)))
+ (apply #'call-next-method instance slot-names initargs)
+ ;; define readers & writers here using reader-method-class & writer-method-class !
+ ))
+
+(defmethod shared-initialize ((instance standard-class) slot-names &rest initargs &key (direct-superclasses "never used" direct-superclasses-p) (metaclass 'standard-class))
+ ;; http://www.lispworks.com/reference/HyperSpec/Body/m_defcla.htm
+ ;; If the superclass list is empty, then the superclass defaults
+ ;; depending on the metaclass, with standard-object being the default
+ ;; for standard-class.
+ (when direct-superclasses-p
+ (setq initargs
+ `(:direct-superclasses
+ ,(canonicalize-direct-superclasses
+ instance (or direct-superclasses (list 'standard-object)))
+ ,@initargs)))
+ (apply #'call-next-method instance slot-names initargs))
+
+(defmethod shared-initialize ((instance funcallable-standard-class) slot-names &rest initargs &key (direct-superclasses "never used" direct-superclasses-p) (metaclass 'funcallable-standard-class))
+ ;; http://www.lisp.org/mop/dictionary.html#class-mo-init
+ ;; if the class is an instance of funcallable-standard-class
+ ;; or one of its subclasses the default value is list of the class
+ ;; funcallable-standard-object.
+ (when direct-superclasses-p
+ (setq initargs
+ `(:direct-superclasses
+ ,(canonicalize-direct-superclasses
+ instance
+ (or direct-superclasses (list 'funcallable-standard-object)))
+ ,@initargs)))
+
+ (apply #'call-next-method instance slot-names initargs)
+
+ (let ((name (getf initargs :name (generic-function-name instance))))
+ (install-generic-function name instance))
+
+ instance)
+
+
+(defgeneric add-direct-subclass (superclass subclass)) ; mop
+(defmethod add-direct-subclass ((superclass class) (subclass class))
+ (pushnew subclass (class-direct-subclasses superclass)))
+
+(defgeneric remove-direct-subclass (superclass subclass)) ; mop
+(defmethod remove-direct-subclass ((superclass class) (subclass class))
+ (setf (class-direct-subclasses superclass)
+ (remove subclass (class-direct-subclasses superclass))))
+
+(defgeneric reinitialize-instance (instance &rest initargs
+ &key &allow-other-keys)
+ (:documentation ;; clos
+ "Change the values of local slots of INSTANCE according to INITARGS."))
+(defmethod reinitialize-instance ((instance standard-object) &rest initargs)
+ ;; http://www.lispworks.com/reference/HyperSpec/Body/f_reinit.htm
+ ;; The system-supplied primary method for reinitialize-instance checks
+ ;; the validity of initargs and signals an error if an initarg is supplied
+ ;; that is not declared as valid. The method then calls the generic function
+ ;; shared-initialize with the following arguments: the instance, nil
+ ;; (which means no slots should be initialized according to their initforms),
+ ;; and the initargs it received.
+ (check-initargs instance
+ `((,#'reinitialize-instance (,instance ,@initargs))
+ (,#'shared-initialize (,instance nil ,@initargs)))
+ initargs)
+ (apply #'shared-initialize instance nil initargs))
+
+(defmethod reinitialize-instance :after ((instance standard-generic-function)
+ &rest initargs)
+ (map-dependents instance
+ #'(lambda (dependent)
+ (apply #'update-dependent instance dependent initargs))))
+
+(defgeneric make-instances-obsolete (class) ; clos
+ (:documentation "Initiate the process of updating the instances of CLASS."))
+(defmethod make-instances-obsolete ((class standard-base-class))
+ (vector-push-extend (make-instance 'old-class :current-class class)
+ (class-old-classes class))
+ (setf (slot-value class 'finalized-p) nil)
+ (incf (slot-value class 'version))
+ (mapc #'(lambda (gf) (clear-gf-cache gf))
+ (specializer-direct-generic-functions class))
+ (mapc #'(lambda (child)
+ (when (class-finalized-p child) (make-instances-obsolete child)))
+ (class-direct-subclasses class))
+ class)
+(defmethod make-instances-obsolete ((class symbol))
+ (apply #'make-instances-obsolete (find-class class)))
+
+(defmethod reinitialize-instance ((instance standard-base-class) &rest initargs)
+ (let ((finalizedp (class-finalized-p instance))
+ (previous (class-direct-superclasses instance)))
+ (when finalizedp
+ (make-instances-obsolete instance))
+ (call-next-method)
+ (let ((current (class-direct-superclasses instance)))
+ (mapc #'(lambda (super) (remove-direct-subclass super instance))
+ (set-difference previous current))
+ (mapc #'(lambda (super) (add-direct-subclass super instance))
+ (set-difference current previous)))
+ (when finalizedp
+ (finalize-inheritance instance)
+ (map-dependents instance
+ #'(lambda (dependent)
+ (apply #'update-dependent
+ instance dependent initargs))))
+ instance))
+
+
+(defgeneric update-instance-for-different-class (previous current &rest initargs &key &allow-other-keys)
+ (:documentation ;; clos
+ "Called only by change-class. Programmers may write methods for it."))
+(defmethod update-instance-for-different-class ((previous standard-object) (current standard-object) &rest initargs)
+ ;; http://www.lispworks.com/reference/HyperSpec/Body/f_update.htm
+ ;; The system-supplied primary method on update-instance-for-different-class
+ ;; checks the validity of initargs and signals an error if an initarg is
+ ;; supplied that is not declared as valid. This method then initializes slots
+ ;; with values according to the initargs, and initializes the newly added
+ ;; slots with values according to their :initform forms. It does this by
+ ;; calling the generic function shared-initialize with the following
+ ;; arguments: the instance (current), a list of names of the newly added
+ ;; slots, and the initargs it received. Newly added slots are those local
+ ;; slots for which no slot of the same name exists in the previous class.
+ (let ((added-local-slots (set-difference
+ (mapcan #'(lambda (slot)
+ (when (local-slot-p slot)
+ (list (slot-definition-name slot))))
+ (class-slots (class-of current)))
+ (class-slot-names (class-of previous)))))
+ (check-initargs current
+ `((,#'update-instance-for-different-class (,previous
+ ,current
+ ,@initargs))
+ (,#'shared-initialize (,current
+ ,added-local-slots
+ ,@initargs)))
+ initargs)
+ (apply #'shared-initialize current added-local-slots initargs)))
+(defmethod update-instance-for-different-class :after ((previous forward-referenced-class) (current standard-base-class) &rest initargs)
+ (mapc #'(lambda (super) (add-direct-subclass super current))
+ (class-direct-superclasses current)))
+
+(defgeneric change-class (instance new-class &key &allow-other-keys)
+ (:documentation ;; clos
+ "Change the class of INSTANCE to NEW-CLASS destructively."))
+(defmethod change-class ((instance t) (new-class symbol) &rest initargs)
+ (apply #'change-class instance (find-class new-class) initargs))
+(defmethod change-class ((instance standard-object) (new-class standard-class) &rest initargs)
+ (let ((previous (allocate-instance new-class)))
+ (swap-%standard-object instance previous)
+ (loop with prev-slot-names = (class-slot-names (class-of previous))
+ slot in (mapcan #'(lambda (slot)
+ (when (and (local-slot-p slot)
+ (member (slot-definition-name slot)
+ prev-slot-names))
+ (list slot)))
+ (class-slots new-class))
+ name = (slot-definition-name slot)
+ if (slot-boundp previous name) do (slot-makunbound instance name)
+ else do (setf (slot-value instance name) (slot-value previous name)))
+ (apply #'update-instance-for-different-class previous instance initargs)))
+
+
+(defgeneric update-instance-for-redefined-class (instance added-slots discarded-slots property-list &rest initargs &key &allow-other-keys)
+ (:documentation ;; clos
+ "Called by the mechanism activated by make-instances-obsolete."))
+(defmethod update-instance-for-redefined-class ((instance standard-object) added-slots discarded-slots property-list &rest initargs)
+ ;; http://www.lispworks.com/reference/HyperSpec/Body/f_upda_1.htm
+ ;; The system-supplied primary method on
+ ;; update-instance-for-redefined-class checks the validity of initargs
+ ;; and signals an error if an initarg is supplied that is not declared as
+ ;; valid. This method then initializes slots with values according to the
+ ;; initargs, and initializes the newly added-slots with values according
+ ;; to their :initform forms. It does this by calling the generic function
+ ;; shared-initialize with the following arguments: the instance, a list
+ ;; of names of the newly added-slots to instance, and the initargs it
+ ;; received. Newly added-slots are those local slots for which no slot of
+ ;; the same name exists in the old version of the class.
+ (let* ((class (class-of instance))
+ (added-local-slots (mapcan #'(lambda (name)
+ (if (local-slot-p (find-slot class name))
+ (list name)
+ nil))
+ added-slots)))
+ (check-initargs instance
+ `((,#'update-instance-for-redefined-class (,instance
+ ,added-slots
+ ,discarded-slots
+ ,property-list
+ ,@initargs))
+ (,#'shared-initialize (,instance ,added-local-slots
+ ,@initargs)))
+ initargs)
+ (apply #'shared-initialize instance added-local-slots initargs)))
+
+(defun obsolete-instance-p (instance)
+ (/= (%standard-object-version instance)
+ (class-version (class-of instance))))
+
+(defun update-obsolete-instance (instance)
+ (let* ((class (class-of instance))
+ (old-class (aref (class-old-classes class)
+ (%standard-object-version instance)))
+ (old-instance (allocate-instance class)))
+ (swap-%standard-object instance old-instance)
+ (setf (%standard-object-class old-instance) old-class)
+ (let* ((old (class-slot-names old-class))
+ (new (class-slot-names class))
+ (common (intersection old new))
+ (discarded (set-difference old new))
+ (added (set-difference new old)))
+ (mapc #'(lambda (name)
+ ;; slots of the same name
+ ;; old current slot value/unbound state
+ ;; local shared discarded
+ ;; shared shared retained
+ ;; local local retained
+ ;; shared local retained
+ (if (and (local-slot-p (find-slot old-class name))
+ (not (local-slot-p (find-slot class name))))
+ (push name discarded)
+ (if (slot-boundp old-instance name)
+ (setf (slot-value instance name)
+ (slot-value old-instance name))
+ (slot-makunbound instance name))))
+ common)
+ (let ((plist (loop for name in discarded
+ when (slot-boundp old-instance name)
+ nconc `(,name ,(slot-value old-instance name)))))
+ (update-instance-for-redefined-class instance added discarded plist)))))
+
+(defun update-instance-if-obsolete (instance)
+ (when (obsolete-instance-p object) (update-obsolete-instance object)))
+
+
+
+(defgeneric initialize-instance (instance &key &allow-other-keys)) ; clos
+(defmethod initialize-instance ((instance standard-object) &rest initargs)
+ (apply #'shared-initialize instance t initargs))
+(defmethod initialize-instance :after ((instance class) &rest initargs)
+ (mapc #'(lambda (super) (add-direct-subclass super instance))
+ (class-direct-superclasses instance)))
+
+
+(defgeneric make-instance (class &rest initargs &key &allow-other-keys)
+ (:documentation "Create and return a new instance of CLASS.")) ; clos
+(defmethod make-instance ((class symbol) &rest initargs)
+ (apply #'make-instance (find-class class) initargs))
+(defmethod make-instance ((class funcallable-standard-class) &rest initargs)
+ (push +funcallable-instance-function-slot-spec+ (getf initargs :direct-slots))
+ (apply #'call-next-method class ,@initargs))
+(defmethod make-instance ((class standard-base-class) &rest initargs)
+ (let ((instance (apply #'allocate-instance class initargs))
+ (defaulted-initargs (defaulted-initargs class initargs)))
+ (check-initargs instance
+ `((,#'allocate-instance (,class ,@defaulted-initargs))
+ (,#'initialize-instance (,instance ,@defaulted-initargs))
+ (,#'shared-initialize (,instance t ,@defaulted-initargs)))
+ defaulted-initargs)
+ (apply #'initialize-instance instance defaulted-initargs)))
+(defmethod make-instance ((class old-class) &rest initargs
+ &key (current-class (required-argument)))
+ (let ((instance (apply #'allocate-instance class initargs)))
+ (check-initargs initargs `(,#'make-instance (,class ,@initargs) initargs))
+ (setf (slot-value instance 'name) (slot-value current-class 'name))
+ (setf (slot-value instance 'version) (slot-value current-class 'version))
+ (setf (slot-value instance 'slots) (copy-seq (slot-value current-class
+ 'slots)))
+ instance))
+
+
+(defgeneric class-name (class) ; clos
+ (:documentation "Return the name of CLASS."))
+(defgeneric (setf class-name) (name class) ; clos
+ (:documentation "Set the name of CLASS to NAME."))
+(defgeneric class-direct-slots (class)) ; mop
+(defgeneric class-direct-default-initargs (class)) ; mop
+(defgeneric class-direct-superclasses (class)) ; mop
+(defgeneric class-direct-subclasses (class)) ; mop
+(defgeneric class-precedence-list (class)) ; mop
+(defgeneric class-default-initargs (class)) ; mop
+(defgeneric class-default-initfuncs (class))
+(defgeneric class-slots (class)) ; mop
+(defgeneric class-finalized-p (class)) ; mop
+(defgeneric class-prototype (class)) ; mop
+
+(defmethod class-precedence-list :before ((class standard-base-class))
+ (unless (class-finalized-p class) (finalize-inheritance class)))
+(defmethod class-slots :before ((class standard-base-class))
+ (unless (class-finalized-p class) (finalize-inheritance class)))
+(defmethod class-default-initargs :before ((class standard-base-class))
+ (unless (class-finalized-p class) (finalize-inheritance class)))
+(defmethod class-default-initfuncs :before ((class standard-base-class))
+ (unless (class-finalized-p class) (finalize-inheritance class)))
+
+
+
+
+(defmethod documentation ((x standard-base-class) (doc-type (eql 't)))
+ (slot-value x 'documentation))
+(defmethod documentation ((x standard-base-class) (doc-type (eql 'type)))
+ (slot-value x 'documentation))
+
+
+
+
+(defgeneric direct-slot-definition-class (class &rest initargs)) ; mop
+(defmethod direct-slot-definition-class ((class standard-base-class) &rest initargs)
+ (find-class 'standard-direct-slot-definition))
+
+
+
+(defgeneric specializer-direct-methods (specializer)) ; mop
+(defgeneric specializer-direct-generic-functions (specializer)) ; mop
+
+
+(defgeneric add-direct-method (specializer method)) ; mop
+(defmethod add-direct-method ((specializer specializer) (method method))
+ (pushnew method (slot-value specializer 'direct-methods))
+ (pushnew (method-generic-function method)
+ (slot-value specializer 'direct-generic-functions)))
+
+(defgeneric remove-direct-method (specializer method)) ; mop
+(defmethod remove-direct-method ((specializer specializer) (method method))
+ (setf (slot-value specializer 'direct-methods)
+ (remove method (specializer-direct-methods specializer)))
+ (let ((gf (method-generic-function method)))
+ (unless (member gf (mapcar #'method-generic-function
+ (specializer-direct-methods specializer)))
+ (setf (slot-value specializer 'direct-generic-functions)
+ (remove gf (specializer-direct-generic-functions))))))
+
+
+(defgeneric reader-method-class (class direct-slot &rest initargs)) ; mop
+(defmethod reader-method-class ((class standard-base-class) (direct-slot standard-direct-slot-definition) &rest initargs)
+ (find-class 'standard-reader-method))
+
+(defgeneric writer-method-class (class direct-slot &rest initargs)) ; mop
+(defmethod writer-method-class ((class standard-base-class) (direct-slot standard-direct-slot-definition) &rest initargs)
+ (find-class 'standard-writer-method))
+
+
+(defgeneric add-dependent (metaobject dependent)) ; mop
+(defmethod add-dependent ((class standard-base-class) dependent)
+ (pushnew dependent (slot-value class 'dependents)))
+(defmethod add-dependent ((generic-function standard-generic-function) dependent)
+ (pushnew dependent (slot-value generic-function 'dependents)))
+(defgeneric remove-dependent (metaobject dependent)) ; mop
+(defmethod remove-dependent ((class standard-base-class) dependent)
+ (setf (slot-value class 'dependents)
+ (remove dependent (slot-value class 'dependents))))
+(defmethod remove-dependent
+ ((generic-function standard-generic-function) dependent)
+ (setf (slot-value generic-function 'dependents)
+ (remove dependent (slot-value generic-function 'dependents))))
+
+(defgeneric map-dependents (metaobject function)) ; mop
+(defmethod map-dependents ((metaobject standard-base-class) function)
+ (mapc function (slot-value metaobject 'dependents)))
+(defmethod map-dependents ((metaobject standard-generic-function) function)
+ (mapc function (slot-value metaobject 'dependents)))
+(defgeneric update-dependent (metaobject dependent &rest initargs)) ; mop
+
+
+
+(defgeneric make-load-form (object &optional environment)
+ (:documentation ;; clos
+ "Return forms to enable load to construct an object equivalent to OBJECT."))
+(defmethod make-load-form ((object standard-object) &optional environment)
+ )
+(defmethod make-load-form ((object structure-object) &optional environment)
+ )
+(defmethod make-load-form ((object condition) &optional environment)
+ )
+(defmethod make-load-form ((object class) &optional environment)
+ )
+
+(defun make-load-form-saving-slots (object &key slot-names environment) ; clos
+ "Return forms that will construct an object equivalent to OBJECT."
+ )
+
+
+
+
+
+
+(defmacro with-accessors (slot-entries instance &body body) ; clos
+ "Make slots accessible like variables through specified accessors."
+ (let ((instance (gensym)))
+ `(let ((,instance ,instance-form))
+ (symbol-macrolet (,@(mapcar
+ #'(lambda (entry)
+ `(,(first entry) (,(second entry) ,instance)))
+ slot-entries))
+ ,@body))))
+
+(defmacro with-slots (slot-entries instance-form &body body) ; clos
+ "Create a lexical environment where slots are accessible like variables."
+ (let ((instance (gensym)))
+ `(let ((,instance ,instance-form))
+ (symbol-macrolet (,@(mapcar
+ #'(lambda (entry)
+ (if (symbolp entry)
+ `(,entry (slot-value ,instance ',entry))
+ `(,(first entry)
+ (slot-value ,instance ',(second entry)))))
+ slot-entries))
+ ,@body))))
+
+
+(defun standard-instance-access (instance location) ; mop
+ (let ((storage (%standard-object-storage instance)))
+ (if (frozen-class-instance-p instance)
+ (second (nth location storage))
+ (aref storage location))))
+
+(defun funcallable-standard-instance-access (instance location)
+ (standard-instance-access instance location))
+
+(defun refer-slot-using-class (class object slot)
+ (update-instance-if-obsolete object)
+ (if (local-slot-p slot)
+ (let (location (slot-definition-location slot))
+ (aref (%standard-object-storage object) location))
+ (car (slot-definition-shared-binding slot))))
+
+(defgeneric slot-value-using-class (class object slot)) ; mop
+(defmethod slot-value-using-class ((class standard-base-class) object
+ (slot standard-effective-slot-definition))
+ (let* ((value (refer-slot-using-class class object slot)))
+ (if (eq value +unbound-state+)
+ (values (slot-unbound class object (slot-definition-name slot)))
+ value)))
+(defmethod slot-value-using-class ((class built-in-class) object slot)
+ (error "slot-value-using-class cannot be used for a built-in-class object."))
+
+
+
+(defgeneric (setf slot-value-using-class) (new-value class object slot)) ; mop
+(defmethod (setf slot-value-using-class) (new-value (class standard-base-class) object (slot standard-effective-slot-definition))
+ (update-instance-if-obsolete object)
+ (if (local-slot-p slot)
+ (let ((location (slot-definition-location slot)))
+ (setf (aref (%standard-object-storage object) location) new-value))
+ (setf (car (slot-definition-shared-binding slot)) new-value)))
+(defmethod (setf slot-value-using-class)
+ (new-value (class built-in-class) object slot)
+ (error "(setf slot-value-using-class) cannot be used for ~
+ a built-in-class object."))
+
+
+
+(defgeneric slot-exists-p-using-class (class object slot-name)) ; mop?
+(defmethod slot-exists-p-using-class ((class standard-base-class)
+ object slot-name)
+ (find-slot class slot-name))
+(defun slot-exists-p (object slot-name) ; clos
+ "Return true if OBJECT has a slot named SLOT-NAME."
+ (slot-exists-p-using-class (class-of object) object slot-name))
+
+
+
+
+
+(defgeneric slot-boundp-using-class (class object slot)) ; mop
+(defmethod slot-boundp-using-class ((class standard-base-class) object (slot standard-effective-slot-definition))
+ (not (eq (refer-slot-using-class class object slot) +unbound-state+)))
+
+(defmethod slot-boundp-using-class ((class built-in-class) object slot)
+ (error "slot-boundp-using-class cannot be used for a built-in-class object."))
+
+
+(defun directly-accessible-slot-p (slot)
+ ;; http://www.lisp.org/mop/concepts.html#instance-structure-protocol
+ ;; > In particular, portable programs can control the implementation
+ ;; > of, and obtain direct access to, slots with allocation :instance and
+ ;; > type t. These are called directly accessible slots.
+ (and (eq (slot-definition-allocation slot) :instance)
+ (eq (slot-definition-type slot) 't)))
+
+
+(defgeneric slot-makunbound-using-class (class object slot)) ; mop
+(defmethod slot-makunbound-using-class ((class standard-base-class) object (slot standard-effective-slot-definition))
+ (setf (slot-value-using-class class object slot) +unbound-state+))
+(defmethod slot-makunbound-using-class ((class built-in-class) object slot)
+ (error
+ "slot-makunbound-using-class cannot be used for a built-in-class object."))
+(defun slot-makunbound (instance slot-name) ; clos
+ "Restore a slot of the name SLOT-NAME in INSTANCE to the unbound state."
+ (let* ((class (class-of instance))
+ (slot (find-slot class slot-name)))
+ (if slot
+ (slot-makunbound-using-class class instance slot)
+ (slot-missing class instance slot-name 'slot-makunbound))
+ instance))
+
+(defgeneric slot-missing (class object slot-name operation &optional new-value)
+ (:documentation ;; clos
+ "Invoked when a slot not defined in CLASS is accessed by SLOT-NAME."))
+(defmethod slot-missing ((class t) object slot-name operation &optional new-value)
+ (error "The slot ~S is missing in the class ~S."
+ slot-name
+ (etypecase class (symbol class) (class (class-name class)))))
+
+(defgeneric slot-unbound (class instance slot-name)
+ (:documentation ;; clos
+ "Called when an unbound slot named SLOT-NAME is read in INSTANCE of CLASS."))
+(defmethod slot-unbound ((class t) instance slot-name)
+ (error 'unbound-slot :instance instance :name slot-name))
+
+
+
+
+
+
+(defgeneric ensure-generic-function-using-class (generic-function function-name &key argument-precedence-order declarations documentation generic-function-class lambda-list method-class method-combination name &allow-other-keys)) ; mop
+(defmethod ensure-generic-function-using-class ((generic-function generic-function) function-name &rest initargs &key generic-function-class &allow-other-keys)
+ (apply #'reinitialize-instance generic-function initargs))
+(defmethod ensure-generic-function-using-class ((generic-function null) function-name &rest initargs &key generic-function-class &allow-other-keys)
+ (apply #'make-instance generic-function-class initargs))
+
+(defun ensure-generic-function (function-name &rest initargs
+ &key argument-precedence-order declare
+ documentation environment generic-function-class
+ lambda-list method-class method-combination)
+ "Define a globally named generic function with no methods." ; clos
+ (let ((fdefinition (fdefinition function-name)))
+ (when (and fdefinition (not (instancep fdefinition 'generic-function)))
+ (error "~S already names an ordinary function or a macro." function-name))
+ (loop initially (setq initargs (copy-list initargs))
+ while (remf initargs :declare))
+ (apply #'ensure-generic-function-using-class fdefinition
+ `(:declarations ,declare ,@initargs))))
+
+
+(defun (setf generic-function-name) (new-name generic-function)
+ )
+
+
+
+(defun clear-gf-cache (gf)
+ (clrhash (generic-function-applicable-methods gf))
+ (clrhash (generic-function-effective-methods gf)))
+
+
+(defgeneric method-qualifiers (method) ; clos
+ (:documentation "Return a list of the qualifiers of METHOD."))
+
+
+
+
+(defun check-specialized-lambda-list (specialized-lambda-list)
+ (let ((required-part (extract-required-part specialized-lambda-list)))
+ (assert (plusp (length required-part)))
+ (dolist (var-spec required-part)
+ (etypecase var-spec
+ (symbol (check-variable-name var-speck))
+ (cons (let ((variable-name (first var-spec))
+ (parameter-specializer-name (second var-spec)))
+ (check-variable-name variable-name)
+ (assert (or (symbolp parameter-specializer-name)
+ (eq (car parameter-specializer-name) 'eql)))))))))
+
+(defun extract-lambda-list (specialized-lambda-list) ; mop
+ (check-specialized-lambda-list specialized-lambda-list)
+ (loop for rest on specialized-lambda-list
+ for item = (car rest)
+ if (member item '(&optional &rest &key &aux))
+ append rest and do (loop-finish)
+ else collect (if (consp item) (car item) item)))
+
+(defun extract-specializer-names (specialized-lambda-list) ; mop
+ (check-specialized-lambda-list specialized-lambda-list)
+ (loop for item in specialized-lambda-list
+ if (member item '(&optional &rest &key &aux)) do (loop-finish)
+ else collect (if (consp item) (second item) 't)))
+
+(defun extract-keyword-names (specialized-lambda-list)
+ (check-specialized-lambda-list specialized-lambda-list)
+ (let ((allow-other-keys-p nil))
+ (values (loop for item in (rest (member '&key specialized-lambda-list))
+ if (eq item '&allow-other-keys)
+ do (setq allow-other-keys-p t) (loop-finish)
+ else if (eq item '&aux) do (loop-finish)
+ else collect (if (consp item)
+ (if (consp (car item))
+ (caar item)
+ (%keyword (car item)))
+ (%keyword item)))
+ allow-other-keys-p)))
+
+(defgeneric function-keywords (method) ; clos
+ (:documentation "Return the keyword parameter specifiers for METHOD."))
+(defmethod function-keywords ((method standard-method))
+ (extract-keyword-names (method-specialized-lambda-list method)))
+
+(defgeneric no-applicable-method (generic-function &rest function-arguments)
+ (:documentation ;; clos
+ "Called when GENERIC-FUNCTION is invoked and no method is applicable."))
+(defmethod no-applicable-method ((generic-function t) &rest function-arguments)
+ )
+
+(defgeneric no-next-method (generic-function method &rest args) ; clos
+ (:documentation "Called by call-next-method when there is no next method."))
+(defmethod no-next-method ((generic-function standard-generic-function) (method standard-method) &rest args)
+ )
+
+
+
+(defgeneric find-method-combination ; mop
+ (generic-function method-combination-type-name method-combination-arguments))
+(defmethod find-method-combination
+ ((gf standard-generic-function) method-combination-type combination-options)
+ (multiple-value-bind (type presentp)
+ (gethash method-combination-type *method-combination-types*)
+ (if presentp
+ (make-instance 'standard-method-combination
+ :type type :arguments method-combination-arguments)
+ (error "Method combination ~S does not exist." method-combination-type))))
+
+(defun make-method-form-p (object)
+ (and (consp object) (eq 'make-method (first object))))
+
+(defun make-method-description (gf form)
+ `(:method 'make-method ,(generic-function-lambda-list gf)
+ (with-call-method ,gf ,form)))
+
+;; Local Macro CALL-METHOD, MAKE-METHOD
+(defmacro with-call-method (gf &body body)
+ `(macrolet
+ ((call-method (method next-methods &environment env)
+ (flet ((method-form (form)
+ (apply #'<make-instance>
+ (generic-function-method-class ,gf)
+ (method-initargs-form
+ ',gf env :null-lexical-environment-p t
+ (method-spec (make-method-description ,gf form))))))
+ (when (make-method-form-p method)
+ (setq method (method-form (second method))))
+ (setq next-methods
+ (mapcar #'(lambda (method)
+ (if (make-method-form-p method)
+ (method-form (second method))
+ `(quote ,method)))
+ next-methods)))
+ `(funcall (method-function ,method)
+ ,+gf-args-variable+ (list ,@next-methods))))
+ ,@body))
+
+(defgeneric compute-effective-method (generic-function
+ method-combination methods)) ; mop
+(defmethod compute-effective-method ((generic-function standard-generic-function)
+ method-combination methods)
+ (let* ((type (method-combination-type method-combination))
+ (type-function (method-combination-type-function type))
+ (arguments (method-combination-arguments method-combination))
+ (effective-method
+ (apply type-function generic-function methods arguments)))
+ (values `(with-call-method ,generic-function
+ ,effective-method)
+ `(:arguments ,(method-combination-type-args-lambda-list type)
+ :generic-function
+ ,(method-combination-type-generic-function-symbol type)))))
+
+
+;; Local Function NEXT-METHOD-P
+;; Local Function CALL-NEXT-METHOD
+(defgeneric make-method-lambda
+ (generic-function method lambda-expression environment)) ; mop
+(defmethod make-method-lambda ((generic-function standard-generic-function)
+ (method standard-method)
+ lambda-expression environment)
+ (let* ((lambda-list (second lambda-expression))
+ (gf-args (first lambda-list))
+ (next-methods (second lambda-list))
+ (name (generic-function-name generic-function))
+ (args (gensym)))
+ (multiple-value-bind (decls forms)
+ (declarations-and-forms (cddr lambda-expression))
+ `(lambda ,lambda-list
+ ,@decls
+ (block ,(if (symbolp name) name (second name))
+ (labels ((next-method-p () ,next-methods)
+ (call-next-method (&rest ,args)
+ (unless ,args (setq ,args ,gf-args))
+ (if (next-method-p)
+ (funcall (method-function (car ,next-methods))
+ ,args (cdr ,next-methods))
+ (apply #'no-next-method ,generic-function ,method
+ ,(first lambda-list)))))
+ ,@forms))))))
+
+
+(defgeneric specializer-satisfied-p (specifier arg))
+(defmethod specializer-satisfied-p ((specializer class) arg)
+ (member (class-of arg) (class-precedence-list specializer)))
+(defmethod specializer-satisfied-p ((specializer eql-specializer) arg)
+ (eql arg (eql-specializer-object specializer)))
+
+(defun applicable-method-p (method args)
+ (every #'specializer-satisfied-p (method-specializers method) args))
+
+(defun eql-specializer-p (specializer)
+ (eq (class-of specializer) (find-class 'eql-specializer)))
+
+(defun more-specific-specializer-p (a b arg)
+ (cond
+ ((eql-specializer-p a) (not (eql-specializer-p b)))
+ ((eql-specializer-p b) nil)
+ (t (let ((list (class-precedence-list (class-of arg))))
+ (< (position a list) (position b list))))))
+
+(defun sort-methods (gf methods)
+ (let ((indeces (loop for arg in (generic-function-argument-precedence-order gf)
+ collect (position arg
+ (generic-function-lambda-list gf)))))
+ (flet ((more-specific-method-p (a b)
+ (loop for i in indeces
+ if (more-specific-specializer-p (elt (method-specializers a) i)
+ (elt (method-specializers b) i)
+ (elt args i))
+ return t)))
+ (sort methods #'more-specific-method-p))))
+
+(defgeneric compute-applicable-methods (generic-function function-arguments) ;clos
+ (:documentation "Return the set of applicable methods of GENERIC-FUNCTION. "))
+(defmethod compute-applicable-methods ((gf standard-generic-function) args)
+ (let ((methods (mapcan #'(lambda (method)
+ (when (applicable-method-p method args)
+ (list method)))
+ (generic-function-methods gf))))
+ (sort-methods gf methods)))
+
+(defgeneric compute-applicable-methods-using-classes
+ (generic-function classes)) ; mop
+(defmethod compute-applicable-methods-using-classes
+ ((generic-function standard-generic-function) classes)
+ (flet ((filter (method)
+ (let ((eql-specializer-p nil))
+ (when (every #'(lambda (a b)
+ (if (and (eql-specializer-p a)
+ (eq (class-of (eql-specializer-object a))
+ b))
+ (setq eql-specializer-p t)
+ (subclassp b a)))
+ (method-specializers method)
+ classes)
+ (if eql-specializer-p
+ (return-from compute-applicable-methods-using-classes
+ (values nil nil))
+ (list method))))))
+ (values (sort-methods gf (mapcan #'filter (generic-function-methods gf)))
+ t)))
+
+(defun applicable-methods (gf args)
+ (let ((classes (mapcar #'class-of
+ (subseq args 0 (number-of-required-args gf)))))
+ (multiple-value-bind (methods presentp)
+ (gethash classes (generic-function-applicable-methods gf))
+ (if presentp
+ methods
+ (multiple-value-bind (methods memorablep)
+ (compute-applicable-methods-using-classes gf classes)
+ (if memorablep
+ (setf (gethash classes (generic-function-applicable-methods gf))
+ methods)
+ (compute-applicable-methods gf args)))))))
+
+(defgeneric compute-discriminating-function (generic-function)) ; mop
+(defmethod compute-discriminating-function ((gf standard-generic-function))
+ (let* ((combination (slot-value gf 'method-combination))
+ (methods (gensym)))
+ (compile
+ nil
+ `(lambda (&rest ,+gf-args-variable+)
+ ;; check args here.
+
+ (let ((,methods (applicable-methods ,gf ,+gf-args-variable+)))
+ (if (null ,methods)
+ (apply #'no-applicable-method ,gf ,+gf-args-variable+)
+ (multiple-value-bind (effective-method-function presentp)
+ (gethash methods (generic-function-effective-methods gf))
+ (if presentp
+ (funcall effective-method-function ,+gf-args-variable+)
+ (progn
+ (setq effective-method-function
+ (compile
+ nil
+ (eval '(lambda (,+gf-args-variable+)
+ ,(compute-effective-method gf
+ combination
+ methods)))))
+ (setf (gethash methods
+ (generic-function-effective-methods gf))
+ effective-method-function)
+ (funcall effective-method-function
+ ,+gf-args-variable+))))))))))
+
+(defgeneric find-method
+ (generic-function qualifiers specializers &optional errorp)
+ (:documentation ;; clos
+ "Return the method object that agrees on QUALIFIERS and SPECIALIZERS."))
+(defmethod find-method
+ ((gf standard-generic-function) qualifiers specializers &optional errorp)
+ (when (/= (length specializers) (number-of-required-args gf))
+ (error "The lambda list of ~S is ~S, and it doesn't match specializers ~S."
+ gf (generic-function-lambda-list gf) specializers))
+ (flet ((agreep (a b)
+ (if (eql-specializer-p a)
+ (and (eql-specializer-p b)
+ (eql (eql-specializer-object a) (eql-specializer-object b)))
+ (eq a b))))
+ (let ((method (find-if
+ #'(lambda (method)
+ (and (agreep (method-specializers method) specializers)
+ (equal (method-qualifiers method) qualifiers)))
+ (generic-function-methods generic-function))))
+ (or method
+ (when errorp
+ (error "No method for ~S with qualifiers ~S and specializers ~S."
+ gf qualifiers specializers))))))
+
+(defun check-lambda-list-congruence (gf method)
+ )
+
+(defgeneric add-method (generic-function method) ; clos
+ (:documentation "Add METHOD to GENERIC-FUNCTION."))
+(defmethod add-method
+ ((generic-function standard-generic-function) (method method))
+ (when (method-generic-function method)
+ (error "Method ~S is already associated with generic function ~S"
+ method (method-generic-function method)))
+ (check-lambda-list-congruence generic-function method)
+
+ (let ((old-method (find-method generic-function
+ (method-qualifiers method)
+ (method-specializers method))))
+ (when old-method
+ (remove-method generic-function old-method)))
+ (push method (slot-value generic-function 'methods))
+ (mapc #'(lambda (specializer) (add-direct-method specializer method))
+ (method-specializers method))
+ (clear-gf-cache gf)
+ (map-dependents generic-function
+ #'(lambda (dependent)
+ (update-dependent generic-function dependent
+ 'add-method method)))
+ method)
+
+(defgeneric remove-method (generic-function method) ; clos
+ (:documentation "Remove METHOD from GENERIC-FUNCTION by modifying it"))
+(defmethod remove-method ((generic-function standard-generic-function) method)
+ (let ((gf-methods (generic-function-methods generic-function)))
+ (when (member method gf-methods)
+ (setf (slot-value generic-function 'methods) (remove method gf-methods))
+ (mapc #'(lambda (specializer) (remove-direct-method specializer method))
+ (method-specializers method))))
+ (clear-gf-cache gf)
+ (map-dependents generic-function
+ #'(lambda (dependent)
+ (update-dependent generic-function dependent
+ 'remove-method method)))
+ method)
+
+
+
+(defun class-of-sequence (sequence)
+ (typecase sequence
+ (list (typecase sequence
+ (null (find-class 'null))
+ (cons (find-class 'cons))
+ (t (find-class 'list))))
+ (vector (typecase sequence
+ (bit-vector (find-class 'bit-vector))
+ (string (find-class 'string))
+ (t (find-class 'vector))))
+ (t (find-class 'sequence))))
+
+(defun class-of-number (number)
+ (typecase number
+ (integer (find-class 'integer))
+ (ratio (find-class 'ratio))
+ (rational (find-class 'rational))
+ (float (find-class 'float))
+ (real (find-class 'real))
+ (complex (find-class 'complex))
+ (t (find-class 'number))))
+
+(defun class-of-stream (stream)
+ (typecase stream
+ (broadcast-stream (find-class 'broadcast-stream))
+ (concatenated-stream (find-class 'concatenated-stream))
+ (string-stream (find-class 'string-stream))
+ (echo-stream (find-class 'echo-stream))
+ (synonym-stream (find-class 'synonym-stream))
+ (file-stream (find-class 'file-stream))
+ (two-way-stream (find-class 'two-way-stream))
+ (t (find-class 'stream))))
+
+(defun class-of-condition (condition)
+ (typecase condition
+ (simple-error (find-class 'simple-error))
+ (simple-type-error (find-class 'simple-type-error))
+ (simple-warning (find-class 'simple-warning))
+ (simple-condition (find-class 'simple-condition))
+
+ (floating-point-inexact (find-class 'floating-point-inexact))
+ (floating-point-invalid-operation (find-class
+ 'floating-point-invalid-operation))
+ (floating-point-overflow (find-class 'floating-point-overflow))
+ (floating-point-underflow (find-class 'floating-point-underflow))
+ (division-by-zero (find-class 'division-by-zero))
+ (arithmetic-error (find-class 'arithmetic-error))
+
+ (reader-error (find-class 'reader-error))
+ (parse-error (find-class 'parse-error))
+
+ (end-of-file (find-class 'end-of-file))
+ (stream-error (find-class 'stream-error))
+
+ (unbound-slot (find-class 'unbound-slot))
+ (unbound-variable (find-class 'unbound-variable))
+ (undefined-function (find-class 'undefined-function))
+ (cell-error (find-class 'cell-error))
+
+ (type-error (find-class 'type-error))
+ (package-error (find-class 'package-error))
+ (control-error (find-class 'control-error))
+ (print-not-readable (find-class 'print-not-readable))
+ (program-error (find-class 'program-error))
+ (file-error (find-class 'file-error))
+ (error (find-class 'error))
+
+ (storage-condition (find-class 'storage-condition))
+ (serious-condition (find-class 'serious-condition))
+
+ (style-warning (find-class 'style-warning))
+ (warning (find-class 'warning))
+
+ (t (find-class 'condition))))
+
+
+(progn
+ (setq *mop-working-p* t))
+
+
+
+(defconstant +condition-report-slot-name+
+ (gensym "CONDITION-REPORT-SLOT-NAME-"))
+
+(deftype lambda-expression () '(satisfies lambda-expression-p))
+(defun lambda-expression-p (object)
+ (and (consp object) (eq (first object) 'lambda) (listp (second object))))
+
+(defun condition-initargs-form (options)
+ (check-singleton-options options '(:default-initargs :documentation :report
+ :direct-superclasses :direct-slots))
+ (let ((report-option (assoc :report options)))
+ (when report-option
+ (destructuring-bind (report-name) (cdr report-option)
+ (assert (typep report-name (or string symbol lambda-expression)))
+ (let ((slot-spec `(,+condition-report-slot-name+ :allocation :class
+ :initform ',report-name)))
+ (push slot-spec (cdr (assoc :direct-slots options)))))
+ (setq options (remove :report options :key #'car))))
+ (class-initargs-form options))
+
+(defmacro define-condition (name parent-types slot-specs &rest options)
+ (let ((*message-prefix* (format nil "DEFINE-CONDITION ~S: " name))
+ (options `((:direct-superclasses ,@(or parent-types '(condition)))
+ (:direct-slots ,@slot-specs)
+ ,@options)))
+ `(let ((*message-prefix* ,*message-prefix*))
+ (apply #'ensure-class ',name ,(condition-initargs-form options)))))
+
+;; 9.1.1 Condition Types
+;; http://www.lispworks.com/reference/HyperSpec/Body/09_aa.htm
+;; > The metaclass of the class condition is not specified.
+(define-condition condition (t) ()
+ (:report (lambda (condition stream)
+ (format stream "Condition ~S is signaled." (class-of condition)))))
+
+(defun make-condition (type &rest slot-initializations)
+ )
+
+|# \ No newline at end of file
diff --git a/Sacla/condition.lisp b/Sacla/condition.lisp
new file mode 100644
index 0000000..d7ec782
--- /dev/null
+++ b/Sacla/condition.lisp
@@ -0,0 +1,437 @@
+;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
+;; ALL RIGHTS RESERVED.
+;;
+;; $Id: condition.lisp,v 1.11 2004/08/19 06:26:06 yuji Exp $
+;;
+;; 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.
+;;
+;; 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.
+
+
+
+;; 9.1.1 Condition Types
+;; http://www.lispworks.com/reference/HyperSpec/Body/09_aa.htm
+;; CONDITION is defined in clos.lisp.
+(define-condition warning () ())
+(define-condition style-warning (warning) ())
+(define-condition serious-condition () ())
+(define-condition storage-condition (serious-condition) ())
+(define-condition error (serious-condition) ())
+(define-condition type-error (error)
+ ((datum :initarg :datum :accessor type-error-datum)
+ (expected-type :initarg :expected-type :accessor type-error-expected-type))
+ (:report (lambda (condition stream)
+ (format stream "~S is not of type ~S"
+ (type-error-datum condition)
+ (type-error-expected-type condition)))))
+(define-condition package-error (error)
+ ((package :initarg :package :accessor package-error-package)))
+(define-condition control-error (error) ())
+(define-condition print-not-readable (error)
+ ((object :initarg :object :accessor print-not-readable-object)))
+(define-condition program-error (error) ())
+(define-condition file-error (error)
+ ((pathname :initarg :pathname :accessor file-error-pathname)))
+(define-condition stream-error (error)
+ ((stream :initarg :stream :accessor stream-error-stream)))
+(define-condition end-of-file (stream-error) ())
+(define-condition parse-error (error) ())
+(define-condition reader-error (parse-error stream-error) ())
+(define-condition cell-error (error)
+ ((name :initarg :name :accessor cell-error-name)))
+(define-condition unbound-variable (cell-error) ())
+(define-condition undefined-function (cell-error) ())
+(define-condition unbound-slot (cell-error)
+ ((instance :initarg :incetance :accessor unbound-slot-instance)))
+(define-condition arithmetic-error (error)
+ ((operation :initarg :operation :accessor arithmetic-error-operation)
+ (operands :initarg :operands :accessor arithmetic-error-operands)))
+(define-condition division-by-zero (arithmetic-error) ())
+(define-condition floating-point-inexact (arithmetic-error) ())
+(define-condition floating-point-invalid-operation (arithmetic-error) ())
+(define-condition floating-point-overflow (arithmetic-error) ())
+(define-condition floating-point-underflow (arithmetic-error) ())
+(define-condition simple-condition (condition)
+ ((format-control :initarg :format-control
+ :accessor simple-condition-format-control)
+ (format-arguments :initarg :format-arguments
+ :accessor simple-condition-format-arguments))
+ (:report (lambda (condition stream)
+ (apply #'format stream
+ (simple-condition-format-control condition)
+ (simple-condition-format-arguments condition)))))
+(define-condition simple-warning (simple-condition warning) ())
+(define-condition simple-error (simple-condition error) ())
+(define-condition simple-type-error (simple-condition type-error) ())
+;; non standard
+(define-condition simple-program-error (simple-condition program-error) ())
+
+
+
+;; utilities
+(defun existing-condition-name-p (object)
+ (and (symbolp object) (subtypep object 'condition)))
+(deftype condition-designator ()
+ '(or string condition (satisfies existing-condition-name-p)))
+(defun condition (datum arguments
+ &optional (default-simple-condition 'simple-condition))
+ (typecase datum
+ (condition (when arguments
+ (error 'type-error :datum arguments :expected-type 'null))
+ datum)
+ (string (make-condition default-simple-condition
+ :format-control
+ (concatenate 'string *message-prefix* datum)
+ :format-arguments arguments))
+ ((satisfies existing-condition-name-p)
+ (apply #'make-condition datum arguments))
+ (t (error 'type-error :datum datum :expected-type 'condition-designator))))
+
+
+
+;; 9.1.4 Handling Conditions
+;; http://www.lispworks.com/reference/HyperSpec/Body/09_ad.htm
+(defvar *handler-clusters* '())
+(defmacro handler-bind (bindings &body forms)
+ ;; binding::= (type handler)
+ ;; type --- a type specifier.
+ ;; handler --- a form; evaluated to produce a handler-function.
+ `(let ((*handler-clusters*
+ (cons (list ,@(mapcar #'(lambda (binding)
+ (destructuring-bind (type handler) binding
+ `(cons ',type ,handler)))
+ bindings))
+ *handler-clusters*)))
+ ,@forms))
+
+(defun handler-case-bindings-and-body (block-tag condition-variable
+ handler-case-clauses)
+ (loop for clause in handler-case-clauses
+ for (typespec (var) . rest) = clause
+ for clause-tag = (gensym)
+ collect `(,typespec #'(lambda (temp)
+ ,(if var
+ `(setq ,condition-variable temp)
+ '(declare (ignore temp)))
+ (go ,clause-tag)))
+ into bindings
+ append `(,clause-tag (return-from ,block-tag
+ (let ,(when var `((,var ,condition-variable)))
+ ,@rest)))
+ into body
+ finally (return (values bindings body))))
+
+(defmacro handler-case (form &rest clauses)
+ (let ((no-error-clause (assoc ':no-error clauses)))
+ (if no-error-clause
+ (let ((normal-return (gensym "NORMAL-RETURN-"))
+ (error-return (gensym "ERROR-RETURN-")))
+ `(block ,error-return
+ (multiple-value-call #'(lambda ,@(cdr no-error-clause))
+ (block ,normal-return
+ (return-from ,error-return
+ (handler-case (return-from ,normal-return ,form)
+ ,@(remove no-error-clause clauses)))))))
+ (let ((block-tag (gensym))
+ (condition (gensym)))
+ (multiple-value-bind (bindings body)
+ (handler-case-bindings-and-body block-tag condition clauses)
+ `(block ,block-tag
+ (let ((,condition nil))
+ (declare (ignorable ,condition))
+ (tagbody
+ (handler-bind ,bindings
+ (return-from ,block-tag ,form))
+ ,@body))))))))
+
+(defmacro ignore-errors (&body body)
+ `(handler-case (progn ,@body)
+ (error (condition) (values nil condition))))
+
+
+
+;; 9.1.4.2 Restarts
+;; http://www.lispworks.com/reference/HyperSpec/Body/09_adb.htm
+(defstruct (restart (:print-object print-restart))
+ (name nil :type symbol)
+ (function (required-argument) :type function)
+ report-function
+ interactive-function
+ (test-function #'(lambda (condition) (declare (ignore condition)) t)))
+(defun print-restart (restart stream)
+ (format stream "#<~A restart (sacla)>" (restart-name restart)))
+
+(defvar *restart-clusters* 'nil)
+(defmacro restart-bind (restart-specs &body forms)
+ "Execute FORMS in a dynamic environment where specified restarts are ~
+ in effect."
+ ;; restart-spec::= (name function {key-val-pair}*)
+ ;; key-val-pair::= :interactive-function interactive-function |
+ ;; :report-function report-function |
+ ;; :test-function test-function
+ (flet ((make-restart-form (spec)
+ (destructuring-bind (name function . initargs) spec
+ `(make-restart :name ',name :function ,function ,@initargs))))
+ `(let ((*restart-clusters* (cons (list ,@(mapcar #'make-restart-form
+ restart-specs))
+ *restart-clusters*)))
+ ,@forms)))
+
+(defvar *condition-restarts* 'nil)
+(defmacro with-condition-restarts (condition-form restarts-form &body forms)
+ "Execute FORMS in an environment where restarts are associated with ~
+ a condition."
+ `(let ((*condition-restarts* (acons ,condition-form ,restarts-form
+ *condition-restarts*)))
+ ,@forms))
+
+(defmacro with-restarts (restarts-form form &environment env)
+ "Associate a condition to be signaled by FORM with restarts of RESTARTS-FORM."
+ (flet ((signaling-form-p (form)
+ (and (consp form) (member (car form) '(cerror error signal warn)))))
+ (let ((form (macroexpand form env)))
+ (if (not (signaling-form-p form))
+ form
+ (let* ((condition (gensym))
+ (signaler (car form))
+ (datum (if (eq signaler 'cerror) (third form) (second form)))
+ (args (if (eq signaler 'cerror) (cdddr form) (cddr form)))
+ (default-condition (ecase signaler
+ ((cerror error) 'simple-error)
+ (warning 'simple-warning)
+ (signal 'simple-condition))))
+ `(let ((,condition (condition ,datum ',args ',default-condition)))
+ (with-condition-restarts ,condition
+ ,restarts-form
+ ,(if (eq signaler 'cerror)
+ `(cerror ,(second form) ,condition)
+ `(,signaler ,condition)))))))))
+
+(defun restart-case-bindings-and-body (block-tag args-var restart-case-clauses)
+ ;; restart-case-clause::= (case-name lambda-list
+ ;; [[:interactive interactive-expression | :report report-expression |
+ ;; :test test-expression]] declaration* form*)
+ (loop for clause in restart-case-clauses
+ for (case-name lambda-list . tail) = clause
+ for clause-tag = (gensym)
+ for initargs =
+ (loop for plist on tail by #'cddr
+ for (key value) = plist
+ and names = '(:interactive :report :test) then (remove key names)
+ if (member key names)
+ if (eq key :interactive)
+ append `(:interactive-function #',value)
+ else if (eq key :report)
+ append `(:report-function
+ #',(if (not (stringp value))
+ value
+ `(lambda (stream)
+ (write-string ,value stream))))
+ else if (eq key :test) append `(:test-function #',value)
+ else do (loop-finish)
+ finally (setq tail plist))
+ collect `(,case-name
+ #'(lambda (&rest rest) (setq ,args-var rest) (go ,clause-tag))
+ ,@initargs) into bindings
+ append `(,clause-tag
+ (return-from ,block-tag
+ (apply #'(lambda ,lambda-list ,@tail) ,args-var))) into body
+ finally (return (values bindings body))))
+
+(defmacro restart-case (restartable-form &body clauses)
+ "Eval RESTARTABLE-FORM in an environment with restarts specified by CLAUSES."
+ (let ((block-tag (gensym))
+ (args (gensym)))
+ (multiple-value-bind (bindings body)
+ (restart-case-bindings-and-body block-tag args clauses)
+ `(block ,block-tag
+ (let ((,args nil))
+ (declare (ignorable ,args))
+ (tagbody
+ (restart-bind ,bindings
+ (return-from ,block-tag
+ (with-restarts (first *restart-clusters*) ,restartable-form)))
+ ,@body))))))
+
+(defmacro with-simple-restart ((restart-name format-string &rest format-arguments)
+ &body forms)
+ `(restart-case (progn ,@forms)
+ (,restart-name ()
+ :report (lambda (stream) (format stream ,format-string ,@format-arguments))
+ (values nil t))))
+
+(defun compute-restarts (&optional condition)
+ "Compute a list of the restarts which are currently active."
+ (let ((visibles nil)
+ (ignorables nil))
+ (dolist (assoc *condition-restarts*)
+ (if (eq (car assoc) condition)
+ (setq visibles (append (cdr assoc) visibles))
+ (setq ignorables (append (cdr assoc) ignorables))))
+ (flet ((visible-p (restart)
+ (and (or (null condition)
+ (member restart visibles)
+ (not (member restart ignorables)))
+ (funcall (restart-test-function restart) condition))))
+ (loop for restart in (mapcan #'copy-list *restart-clusters*)
+ if (visible-p restart) collect restart))))
+
+(defun find-restart (id &optional condition)
+ "Search for a particular restart in the current dynamic environment."
+ (if (restart-p id)
+ (if (funcall (restart-test-function id) condition)
+ id
+ nil)
+ (find id (compute-restarts condition) :key #'restart-name)))
+
+(defun restart (designator)
+ (or (find-restart designator)
+ (error "Restart ~S is not active." designator)))
+
+(defun invoke-restart (restart-designator &rest values)
+ (let ((restart (restart restart-designator)))
+ (apply (restart-function restart) values)))
+
+(defun invoke-restart-interactively (restart-designator)
+ (let* ((restart (restart restart-designator))
+ (interactive-function (restart-interactive-function restart)))
+ (apply (restart-function restart) (if interactive-function
+ (funcall interactive-function)
+ '()))))
+
+(defun abort (&optional condition)
+ (let ((restart (find-restart 'abort condition)))
+ (when restart
+ (invoke-restart 'abort))
+ (error 'control-error)))
+
+(defun muffle-warning (&optional condition)
+ (let ((restart (find-restart 'muffle-warning condition)))
+ (when restart
+ (invoke-restart 'muffle-warning))
+ (error 'control-error)))
+
+(defun continue (&optional condition)
+ (let ((restart (find-restart 'continue condition)))
+ (when restart
+ (invoke-restart restart))))
+
+(defun store-value (value &optional condition)
+ (let ((restart (find-restart 'store-value condition)))
+ (when restart
+ (invoke-restart 'store-value value))))
+
+(defun use-value (value &optional condition)
+ (let ((restart (find-restart 'use-value condition)))
+ (when restart
+ (invoke-restart 'use-value value))))
+
+
+
+(defvar *break-on-signals* 'nil)
+(defun break (&optional (format-control "Break") &rest format-arguments)
+ (with-simple-restart (continue "Return from BREAK.")
+ (let ((*debugger-hook* nil))
+ (invoke-debugger (make-condition 'simple-condition
+ :format-control format-control
+ :format-arguments format-arguments))))
+ nil)
+(defun signal (datum &rest arguments)
+ (let ((condition (condition datum arguments))
+ (*handler-clusters* *handler-clusters*))
+ (when (typep condition *break-on-signals*)
+ (break "~A~%Break entered because of *BREAK-ON-SIGNALS*." condition))
+ (loop while *handler-clusters*
+ do (dolist (handler (pop *handler-clusters*))
+ (when (typep condition (car handler))
+ (funcall (cdr handler) condition))))
+ nil))
+
+(defun error (datum &rest arguments)
+ (let ((condition (condition datum arguments 'simple-error)))
+ (signal condition)
+ (invoke-debugger condition)))
+
+(defun cerror (continue-format-control datum &rest arguments)
+ (restart-case (error (condition datum arguments 'simple-error))
+ (continue ()
+ :report (lambda (stream)
+ (apply #'format stream continue-format-control arguments))))
+ nil)
+
+(defmacro check-type (place typespec &optional string)
+ (declare (ignorable string))
+ `(loop
+ until (typep ,place ',typespec)
+ do (restart-case (error 'type-error :datum ,place :expected-type ',typespec)
+ (store-value (value)
+ :report (lambda (stream) (store-value-report stream ',place))
+ :interactive store-value-interactive
+ (setf ,place value)))))
+
+(defun warn (datum &rest arguments)
+ (let ((condition (condition datum arguments 'simple-warning)))
+ (check-type condition warning)
+ (restart-case (signal condition)
+ (muffle-warning ()
+ :report "Skip warning."
+ (return-from warn nil)))
+ (format *error-output* "~&Warning:~%~A~%" condition)
+ nil))
+
+
+
+(defun assert-report (names stream)
+ (format stream "Retry assertion")
+ (if names
+ (format stream " with new value~P for ~{~S~^, ~}." (length names) names)
+ (format stream ".")))
+(defun assert-prompt (name value)
+ (cond ((y-or-n-p "The old value of ~S is ~S.~%~
+ Do you want to supply a new value? "
+ name value)
+ (format *query-io* "~&Type a form to be evaluated:~%")
+ (flet ((read-it () (eval (read *query-io*))))
+ (if (symbolp name) ;help user debug lexical variables
+ (progv (list name) (list value) (read-it))
+ (read-it))))
+ (t value)))
+(defmacro assert (test-form &optional places datum-form &rest argument-forms)
+ `(loop
+ (when ,test-form (return nil))
+ (restart-case (error ,@(if datum-form
+ `(,datum-form ,@argument-forms)
+ `("The assertion ~S failed." ',test-form)))
+ (continue ()
+ :report (lambda (stream) (assert-report ',places stream))
+ ,@(mapcar #'(lambda (place)
+ `(setf ,place (assert-prompt ',place ,place)))
+ places)))))
+
+;;Function INVOKE-DEBUGGER
+;;Variable *DEBUGGER-HOOK*
+;;
+;;Defined in clos.lisp
+;; Macro DEFINE-CONDITION
+;; Function MAKE-CONDITION
+;; Function INVALID-METHOD-ERROR
+;; Function METHOD-COMBINATION-ERROR
diff --git a/Sacla/cons.lisp b/Sacla/cons.lisp
new file mode 100644
index 0000000..6276a7f
--- /dev/null
+++ b/Sacla/cons.lisp
@@ -0,0 +1,993 @@
+;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
+;; ALL RIGHTS RESERVED.
+;;
+;; $Id: cons.lisp,v 1.4 2004/02/20 07:23:42 yuji Exp $
+;;
+;; 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.
+;;
+;; 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.
+
+(defun atom (object)
+ "Return true if OBJECT is of type atom; otherwise, return false."
+ (not (consp object)))
+
+(defun caar (list)
+ "Return the car of the car of LIST."
+ (car (car list)))
+
+(defun cadr (list)
+ "Return the car of the cdr of LIST."
+ (car (cdr list)))
+
+(defun cdar (list)
+ "Return the cdr of the car of LIST."
+ (cdr (car list)))
+
+(defun cddr (list)
+ "Return the cdr of the cdr of LIST."
+ (cdr (cdr list)))
+
+(defun caaar (list)
+ "Return the car of the caar of LIST."
+ (car (caar list)))
+
+(defun caadr (list)
+ "Return the car of the cadr of LIST."
+ (car (cadr list)))
+
+(defun cadar (list)
+ "Return the car of the cdar of LIST."
+ (car (cdar list)))
+
+(defun caddr (list)
+ "Return the car of the cddr of LIST."
+ (car (cddr list)))
+
+(defun cdaar (list)
+ "Return the cdr of the caar of LIST."
+ (cdr (caar list)))
+
+(defun cdadr (list)
+ "Return the cdr of the cadr of LIST."
+ (cdr (cadr list)))
+
+(defun cddar (list)
+ "Return the cdr of the cdar of LIST."
+ (cdr (cdar list)))
+
+(defun cdddr (list)
+ "Return the cdr of the cddr of LIST."
+ (cdr (cddr list)))
+
+(defun caaaar (list)
+ "Return the car of the caaar of LIST."
+ (car (caaar list)))
+
+(defun caaadr (list)
+ "Return the car of the caadr of LIST."
+ (car (caadr list)))
+
+(defun caadar (list)
+ "Return the car of the cadar of LIST."
+ (car (cadar list)))
+
+(defun caaddr (list)
+ "Return the car of the caddr of LIST."
+ (car (caddr list)))
+
+(defun cadaar (list)
+ "Return the car of the cdaar of LIST."
+ (car (cdaar list)))
+
+(defun cadadr (list)
+ "Return the car of the cdadr of LIST."
+ (car (cdadr list)))
+
+(defun caddar (list)
+ "Return the car of the cddar of LIST."
+ (car (cddar list)))
+
+(defun cadddr (list)
+ "Return the car of the cdddr of LIST."
+ (car (cdddr list)))
+
+(defun cdaaar (list)
+ "Return the cdr of the caaar of LIST."
+ (cdr (caaar list)))
+
+(defun cdaadr (list)
+ "Return the cdr of the caadr of LIST."
+ (cdr (caadr list)))
+
+(defun cdadar (list)
+ "Return the cdr of the cadar of LIST."
+ (cdr (cadar list)))
+
+(defun cdaddr (list)
+ "Return the cdr of the caddr of LIST."
+ (cdr (caddr list)))
+
+(defun cddaar (list)
+ "Return the cdr of the cdaar of LIST."
+ (cdr (cdaar list)))
+
+(defun cddadr (list)
+ "Return the cdr of the cdadr of LIST."
+ (cdr (cdadr list)))
+
+(defun cdddar (list)
+ "Return the cdr of the cddar of LIST."
+ (cdr (cddar list)))
+
+(defun cddddr (list)
+ "Return the cdr of the cdddr of LIST."
+ (cdr (cdddr list)))
+
+
+(defsetf caar (x) (v)
+ `(progn
+ (rplaca (car ,x) ,v)
+ ,v))
+
+(defsetf cadr (x) (v)
+ `(progn
+ (rplaca (cdr ,x) ,v)
+ ,v))
+
+(defsetf cdar (x) (v)
+ `(progn
+ (rplacd (car ,x) ,v)
+ ,v))
+
+(defsetf cddr (x) (v)
+ `(progn
+ (rplacd (cdr ,x) ,v)
+ ,v))
+
+(defsetf caaar (x) (v)
+ `(progn
+ (rplaca (caar ,x) ,v)
+ ,v))
+
+(defsetf caadr (x) (v)
+ `(progn
+ (rplaca (cadr ,x) ,v)
+ ,v))
+
+(defsetf cadar (x) (v)
+ `(progn
+ (rplaca (cdar ,x) ,v)
+ ,v))
+
+(defsetf caddr (x) (v)
+ `(progn
+ (rplaca (cddr ,x) ,v)
+ ,v))
+
+(defsetf cdaar (x) (v)
+ `(progn
+ (rplacd (caar ,x) ,v)
+ ,v))
+
+(defsetf cdadr (x) (v)
+ `(progn
+ (rplacd (cadr ,x) ,v)
+ ,v))
+
+(defsetf cddar (x) (v)
+ `(progn
+ (rplacd (cdar ,x) ,v)
+ ,v))
+
+(defsetf cdddr (x) (v)
+ `(progn
+ (rplacd (cddr ,x) ,v)
+ ,v))
+
+(defsetf caaaar (x) (v)
+ `(progn
+ (rplaca (caaar ,x) ,v)
+ ,v))
+
+(defsetf caaadr (x) (v)
+ `(progn
+ (rplaca (caadr ,x) ,v)
+ ,v))
+
+(defsetf caadar (x) (v)
+ `(progn
+ (rplaca (cadar ,x) ,v)
+ ,v))
+
+(defsetf caaddr (x) (v)
+ `(progn
+ (rplaca (caddr ,x) ,v)
+ ,v))
+
+(defsetf cadaar (x) (v)
+ `(progn
+ (rplaca (cdaar ,x) ,v)
+ ,v))
+
+(defsetf cadadr (x) (v)
+ `(progn
+ (rplaca (cdadr ,x) ,v)
+ ,v))
+
+(defsetf caddar (x) (v)
+ `(progn
+ (rplaca (cddar ,x) ,v)
+ ,v))
+
+(defsetf cadddr (x) (v)
+ `(progn
+ (rplaca (cdddr ,x) ,v)
+ ,v))
+
+(defsetf cdaaar (x) (v)
+ `(progn
+ (rplacd (caaar ,x) ,v)
+ ,v))
+
+(defsetf cdaadr (x) (v)
+ `(progn
+ (rplacd (caadr ,x) ,v)
+ ,v))
+
+(defsetf cdadar (x) (v)
+ `(progn
+ (rplacd (cadar ,x) ,v)
+ ,v))
+
+(defsetf cdaddr (x) (v)
+ `(progn
+ (rplacd (caddr ,x) ,v)
+ ,v))
+
+(defsetf cddaar (x) (v)
+ `(progn
+ (rplacd (cdaar ,x) ,v)
+ ,v))
+
+(defsetf cddadr (x) (v)
+ `(progn
+ (rplacd (cdadr ,x) ,v)
+ ,v))
+
+(defsetf cdddar (x) (v)
+ `(progn
+ (rplacd (cddar ,x) ,v)
+ ,v))
+
+(defsetf cddddr (x) (v)
+ `(progn
+ (rplacd (cdddr ,x) ,v)
+ ,v))
+
+(defun null (object)
+ "Return t if OBJECT is the empty list; otherwise, return nil."
+ (eq object nil))
+
+(defun endp (list)
+ "Return true if LIST is the empty list. Returns false if LIST is a cons."
+ (check-type list list)
+ (null list))
+
+(defun listp (object)
+ "Return true if OBJECT is of type list; otherwise, return false."
+ (or (null object) (consp object)))
+
+
+(defun first (list)
+ "Return the 1st element in LIST or NIL if LIST is empty."
+ (car list))
+(defun second (list)
+ "Return the 2nd element in LIST or NIL if there is no 2nd element."
+ (cadr list))
+(defun third (list)
+ "Returns the 3rd element in LIST or NIL if there is no 3rd element."
+ (caddr list))
+(defun fourth (list)
+ "Return the 4th element in LIST or NIL if there is no 4th element."
+ (cadddr list))
+(defun fifth (list)
+ "Return the 5th element in LIST or NIL if there is no 5th element."
+ (car (cddddr list)))
+(defun sixth (list)
+ "Return the 6th element in LIST or NIL if there is no 6th element."
+ (cadr (cddddr list)))
+(defun seventh (list)
+ "Return the 7th element in LIST or NIL if there is no 7th element."
+ (caddr (cddddr list)))
+(defun eighth (list)
+ "Return the 8th element in LIST or NIL if there is no 8th element."
+ (cadddr (cddddr list)))
+(defun ninth (list)
+ "Return the 9th element in LIST or NIL if there is no 9th element."
+ (car (cddddr (cddddr list))))
+(defun tenth (list)
+ "Return the 10th element in LIST or NIL if there is no 10th element."
+ (cadr (cddddr (cddddr list))))
+
+(defun rest (list)
+ "Perform the same operation as cdr."
+ (cdr list))
+
+
+(defsetf first (x) (v)
+ `(setf (car ,x) ,v))
+
+(defsetf second (x) (v)
+ `(setf (cadr ,x) ,v))
+
+(defsetf third (x) (v)
+ `(setf (caddr ,x) ,v))
+
+(defsetf fourth (x) (v)
+ `(setf (cadddr ,x) ,v))
+
+(defsetf fifth (x) (v)
+ `(setf (car (cddddr ,x)) ,v))
+
+(defsetf sixth (x) (v)
+ `(setf (cadr (cddddr ,x)) ,v))
+
+(defsetf seventh (x) (v)
+ `(setf (caddr (cddddr ,x)) ,v))
+
+(defsetf eighth (x) (v)
+ `(setf (cadddr (cddddr ,x)) ,v))
+
+(defsetf ninth (x) (v)
+ `(setf (car (cddddr (cddddr ,x))) ,v))
+
+(defsetf tenth (x) (v)
+ `(setf (cadr (cddddr (cddddr ,x))) ,v))
+
+(defsetf rest (x) (v)
+ `(setf (cdr ,x) ,v))
+
+
+(defun nthcdr (n list)
+ "Return the tail of LIST that would be obtained by calling cdr N times."
+ (check-type n (integer 0))
+ (do ((i n (1- i))
+ (result list (cdr result)))
+ ((zerop i) result)))
+
+(defun nth (n list)
+ "Return the Nth element in LIST, where the car is the zero-th element."
+ (car (nthcdr n list)))
+
+(defsetf nth (n list) (v)
+ `(setf (car (nthcdr ,n ,list)) ,v))
+
+
+(defun copy-list (list)
+ "Return a copy of LIST which is either a proper list or a dotted list."
+ (unless (null list)
+ (let ((result (cons (car list) nil)))
+ (do ((x (cdr list) (cdr x))
+ (splice result (cdr (rplacd splice (cons (car x) nil)))))
+ ((atom x) (rplacd splice x)))
+ result)))
+
+(defun list (&rest args)
+ "Return ARGS which is a list of supplied arguments."
+ (copy-list args))
+
+(defun list* (arg &rest others)
+ "Return a list of the arguments with the last cons being a dotted pair."
+ (cond ((null others) arg)
+ ((null (cdr others)) (cons arg (car others)))
+ (t (let ((others (copy-list others)))
+ (do ((x others (cdr x)))
+ ((null (cddr x)) (rplacd x (cadr x))))
+ (cons arg others)))))
+
+(defun list-length (list)
+ "Return the length of the given LIST, or nil if the LIST is circular."
+ (do ((n 0 (+ n 2)) ;Counter.
+ (fast list (cddr fast)) ;Fast pointer: leaps by 2.
+ (slow list (cdr slow))) ;Slow pointer: leaps by 1.
+ (nil)
+ ;; If fast pointer hits the end, return the count.
+ (when (endp fast) (return n))
+ (when (endp (cdr fast)) (return (+ n 1)))
+ ;; If fast pointer eventually equals slow pointer,
+ ;; then we must be stuck in a circular list.
+ ;; (A deeper property is the converse: if we are
+ ;; stuck in a circular list, then eventually the
+ ;; fast pointer will equal the slow pointer.
+ ;; That fact justifies this implementation.)
+ (when (and (eq fast slow) (> n 0)) (return nil))))
+
+(defun make-list (size &key initial-element)
+ "Return a list of SIZE length, every element of which is INITIAL-ELEMENT."
+ (check-type size (integer 0))
+ (do ((i size (1- i))
+ (list '() (cons initial-element list)))
+ ((zerop i) list)))
+
+(defun last (list &optional (n 1))
+ "Returns the last N conses (not the last N elements) of LIST."
+ (check-type n (integer 0))
+ (do ((l list (cdr l))
+ (r list)
+ (i 0 (1+ i)))
+ ((atom l) r)
+ (if (>= i n) (pop r))))
+
+(defun butlast (list &optional (n 1))
+ "Return a copy of LIST from which the last N conses have been omitted."
+ (check-type n (integer 0))
+ (if (null list)
+ nil
+ (let ((length (do ((p (cdr list) (cdr p))
+ (i 1 (1+ i)))
+ ((atom p) i))))
+ (do* ((here list (cdr here))
+ (result (list nil))
+ (splice result)
+ (count (- length n) (1- count)))
+ ((<= count 0) (cdr result))
+ (setq splice (cdr (rplacd splice (list (car here)))))))))
+
+(defun nbutlast (list &optional (n 1))
+ "Modify LIST to remove the last N conses."
+ (check-type n (integer 0))
+ (if (null list)
+ nil
+ (let ((length (do ((p (cdr list) (cdr p))
+ (i 1 (1+ i)))
+ ((atom p) i))))
+ (unless (<= length n)
+ (do ((1st (cdr list) (cdr 1st))
+ (2nd list 1st)
+ (count (- length n 1) (1- count)))
+ ((zerop count) (rplacd 2nd ()) list))))))
+
+(defun nconc (&rest lists)
+ "Concatenate LISTS by changing them."
+ (setq lists (do ((p lists (cdr p)))
+ ((or (car p) (null p)) p)))
+ (do* ((top (car lists))
+ (splice top)
+ (here (cdr lists) (cdr here)))
+ ((null here) top)
+ (rplacd (last splice) (car here))
+ (when (car here)
+ (setq splice (car here)))))
+
+(defun append (&rest lists)
+ "Concatenate LISTS by copying them."
+ (setq lists (do ((p lists (cdr p)))
+ ((or (car p) (null p)) p)))
+ (cond
+ ((null lists) '())
+ ((null (cdr lists)) (car lists))
+ (t (let* ((top (list (caar lists)))
+ (splice top))
+ (do ((x (cdar lists) (cdr x)))
+ ((atom x))
+ (setq splice (cdr (rplacd splice (list (car x))))))
+ (do ((p (cdr lists) (cdr p)))
+ ((null (cdr p)) (rplacd splice (car p)) top)
+ (do ((x (car p) (cdr x)))
+ ((atom x))
+ (setq splice (cdr (rplacd splice (list (car x)))))))))))
+
+(defun revappend (list tail)
+ "Return (nconc (reverse list) tail)."
+ (do ((top list (cdr top))
+ (result tail (cons (car top) result)))
+ ((endp top) result)))
+
+(defun nreconc (list tail)
+ "Return (nconc (nreverse list) tail)."
+ (do ((1st (cdr list) (if (atom 1st) 1st (cdr 1st)))
+ (2nd list 1st)
+ (3rd tail 2nd))
+ ((atom 2nd) 3rd)
+ (rplacd 2nd 3rd)))
+
+(defun tailp (object list)
+ "Return true if OBJECT is the same as some tail of LIST, otherwise false."
+ (if (null list)
+ (null object)
+ (do ((list list (cdr list)))
+ ((atom (cdr list)) (or (eql object list) (eql object (cdr list))))
+ (if (eql object list)
+ (return t)))))
+
+(defun ldiff (list object)
+ "Return a copy of LIST before the part which is the same as OBJECT."
+ (unless (eql list object)
+ (do* ((result (list (car list)))
+ (splice result)
+ (list (cdr list) (cdr list)))
+ ((atom list) (when (eql list object) (rplacd splice nil)) result)
+ (if (eql list object)
+ (return result)
+ (setq splice (cdr (rplacd splice (list (car list)))))))))
+
+(defun acons (key datum alist)
+ "Construct a new alist by adding the pair (key . datum) to alist."
+ (cons (cons key datum) alist))
+
+(defun 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)))))
+
+(defun 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))))
+
+(defun 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))
+
+(defun 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))))
+
+(defun 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))))
+
+(defun 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))
+
+(defun copy-alist (alist)
+ "Return a copy of ALIST."
+ (if (null alist)
+ nil
+ (let* ((new-alist (list (cons (caar alist) (cdar alist))))
+ (tail new-alist))
+ (dolist (pair (cdr alist))
+ (rplacd tail (list (cons (car pair) (cdr pair))))
+ (setq tail (cdr tail)))
+ new-alist)))
+
+(defun pairlis (keys data &optional (alist '()))
+ "Construct an association list from keys and data (adding to alist)"
+ (do ((x keys (cdr x))
+ (y data (cdr y)))
+ ((endp x) alist)
+ (setq alist (acons (car x) (car y) alist))))
+
+
+(defun 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)))
+
+(defun 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)))
+
+(defun copy-tree (tree)
+ "Create a copy of TREE (a structure of conses)."
+ (if (consp tree)
+ (cons (copy-tree (car tree)) (copy-tree (cdr tree)))
+ tree))
+
+(defun 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)))
+
+(defun 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)))
+
+(defun 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)))
+
+(defun 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))
+
+(defun 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)))
+
+(defun 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))
+
+(defun 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)))
+
+
+
+(defmacro push (item place &environment env)
+ "Prepend item to the list in PLACE, store the list in PLACE, and returns it."
+ (if (symbolp place)
+ `(setq ,place (cons ,item ,place))
+ (multiple-value-bind (temporary-vars values stores setter getter)
+ (get-setf-expansion place env)
+ (let ((item-var (gensym)))
+ `(let* ((,item-var ,item)
+ ,@(mapcar #'list temporary-vars values)
+ (,(car stores) (cons ,item-var ,getter)))
+ ,setter)))))
+
+(defmacro pop (place &environment env)
+ "Return the car of the list in PLACE, storing the cdr of it back into PLACE."
+ (if (symbolp place)
+ `(prog1 (car ,place) (setq ,place (cdr ,place)))
+ (multiple-value-bind (temporary-vars values stores setter getter)
+ (get-setf-expansion place env)
+ (let ((list-var (gensym)))
+ `(let* (,@(mapcar #'list temporary-vars values)
+ (,list-var ,getter)
+ (,(car stores) (cdr ,list-var)))
+ ,setter
+ (car ,list-var))))))
+
+
+
+(defun 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)))
+
+(defun 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)))
+
+(defun 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))
+
+(defun 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)))
+
+(defun 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))
+
+(defun 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)))))))
+
+(defun 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))
+
+(defun 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))))
+
+(defun 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))))
+
+(defun 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))
+
+(defun 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))))
+
+(defun 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))
+
+(defun 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)))))
+
+(defmacro pushnew (item place &rest keys &environment env)
+ "Test if ITEM is the same as any element of the list in PLACE. If not, prepend it to the list, then the new list is stored in PLACE."
+ (if (symbolp place)
+ `(setq ,place (adjoin ,item ,place ,@keys))
+ (multiple-value-bind (temporary-vars values stores setter getter)
+ (get-setf-expansion place env)
+ (let ((item-var (gensym)))
+ `(let* ((,item-var ,item)
+ ,@(mapcar #'list temporary-vars values)
+ (,(car stores) (adjoin ,item-var ,getter ,@keys)))
+ ,setter)))))
+
+
+(defun 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)))
+
+(defun 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)))))))
+
+(defun 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)))
+
+(defun 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)))))
+
+(defun 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)))))
+
+(defun 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)))
+
+
+
+(defun get-properties (plist indicator-list)
+ "Look up any of several property list entries all at once."
+ (do ((plist plist (cddr plist)))
+ ((endp plist) (values nil nil nil))
+ (when (member (car plist) indicator-list)
+ (return (values (car plist) (cadr plist) plist)))))
+
+(defun getf (plist indicator &optional (default ()))
+ "Find a property on PLIST whose property indicator is identical to INDICATOR, and returns its corresponding property value."
+ (do ((plist plist (cddr plist)))
+ ((endp plist) default)
+ (when (eq indicator (car plist))
+ (return (cadr plist)))))
+
+
+
+(define-setf-expander getf (place indicator
+ &optional (default nil default-supplied)
+ &environment env)
+ (multiple-value-bind (temporary-vars values stores setter getter)
+ (get-setf-expansion place env)
+ (let ((value-var (gensym))
+ (indicator-var (gensym))
+ (place-var (gensym))
+ (tail-var (gensym))
+ (default-var (when default-supplied (gensym))))
+ (values
+ `(,@temporary-vars ,indicator-var ,@(when default-supplied
+ `(,default-var)))
+ `(,@values ,indicator ,@(when default-supplied `(,default)))
+ `(,value-var)
+ `(let ((,place-var ,getter))
+ (multiple-value-bind (,(gensym) ,(gensym) ,tail-var)
+ (get-properties ,place-var (list ,indicator-var))
+ (if ,tail-var
+ (rplaca (cdr ,tail-var) ,value-var)
+ (let ((,(car stores) (cons ,indicator-var
+ (cons ,value-var ,place-var))))
+ ,setter
+ ,value-var))
+ ,value-var))
+ `(getf ,getter ,indicator-var ,@(when default-supplied
+ `(,default-var)))))))
+
+(defmacro remf (place indicator &environment env)
+ "Remove from the property list stored in PLACE a property with a property indicator identical to INDICATOR."
+ (multiple-value-bind (temporary-vars values stores setter getter)
+ (get-setf-expansion place env)
+ (let ((indicator-var (gensym))
+ (plist-var (gensym))
+ (splice-var (gensym)))
+ `(do* (,@(mapcar #'list temporary-vars values)
+ (,indicator-var ,indicator)
+ (,plist-var (cons nil ,getter))
+ (,splice-var ,plist-var (cddr ,splice-var))
+ ,(car stores))
+ ((endp ,splice-var) nil)
+ (when (eq ,indicator-var (cadr ,splice-var))
+ (rplacd ,splice-var (cdddr ,splice-var))
+ (setq ,(car stores) (cdr ,plist-var))
+ ,setter
+ (return t))))))
+
diff --git a/Sacla/core.lisp b/Sacla/core.lisp
new file mode 100644
index 0000000..509f0ab
--- /dev/null
+++ b/Sacla/core.lisp
@@ -0,0 +1,726 @@
+;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
+;; ALL RIGHTS RESERVED.
+;;
+;; $Id: core.lisp,v 1.30 2004/05/26 07:57:52 yuji Exp $
+;;
+;; 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.
+;;
+;; 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.
+
+;;; primitives
+;;(defun alloc-pointers (n)
+;; (alloc-pointers n))
+
+
+;;; objects
+
+;; cons
+(defstruct (cons (:constructor cons (car cdr))
+ (:conc-name "") (:predicate consp) (:copier nil))
+ (car)
+ (cdr)
+ )
+
+(defun rplaca (cons object)
+ "Replace the car of CONS with OBJECT."
+ (setf (car cons) object)
+ cons)
+
+(defun rplacd (cons object)
+ "Replace the cdr of CONS with OBJECT."
+ (setf (cdr cons) object)
+ cons)
+
+
+;; symbol
+(defstruct (symbol (:constructor make-symbol (name)) (:predicate symbolp) (:copier nil))
+ (name "" (:type string))
+ (%value 'unbound)
+ (function nil)
+ (package nil)
+ (plist nil (:type list))
+ )
+
+(defconstant unbound
+ 'nil
+ "Represent variable's unbound state as a symbol itself.")
+
+(defconstant nil
+ 'nil
+ "Represent both boolean (and generalized boolean) false and the empty list.")
+
+(defconstant t
+ 't
+ "The boolean representing true, and the canonical generalized boolean representing true.")
+
+(defun boundp (symbol)
+ (not (eq (symbol-%value symbol) 'unbound)))
+
+(defun makunbound (symbol)
+ (setf (symbol-%value symbol) 'unbound))
+
+(defun symbol-value (symbol)
+ (if (boundp symbol)
+ (symbol-%value symbol)
+ (error 'unbound-variable :name symbol)))
+
+(defsetf symbol-value (symbol) (new-value)
+ (setf (symbol-%value symbol) new-value))
+
+(defun set (symbol value)
+ (setf (symbol-value symbol) value))
+
+(defvar *gensym-counter* 0)
+(defun gensym (&optional (x "G"))
+ (gensym x))
+
+
+;; function
+(defstruct (function (:predicate functionp))
+ (lambda-expression)
+ )
+;; functionp,,, are defined here
+
+(defun fdefinition (function-name)
+ (etypecase function-name
+ (symbol (symbol-function function-name))
+ (setf-function-name )))
+
+(defsetf fdefinition (function-name) (new-function)
+ )
+
+(defun fboundp (name)
+ )
+
+(defun fmakunbound (name)
+ )
+
+(defun function-lambda-expression (function)
+ )
+
+(defun compiled-function-p (object)
+ )
+
+(defmacro function (name)
+ )
+
+
+
+;;; special operators
+(defmacro quote (object)
+ )
+
+(defmacro eval-when (situations &body body)
+ )
+
+(defmacro if (test-form then-form &optional else-form)
+ )
+
+(defmacro load-time-value (form &optional read-only-p)
+ )
+
+(defmacro locally (&rest declarations-and-forms)
+ )
+
+(defmacro symbol-macrolet ((symbol-expansions) &body body)
+ )
+
+(defmacro the (value-type form)
+ )
+
+
+;; data and control flow
+(defun apply (function arg &rest more-args)
+ )
+
+(defmacro defun (function-name lambda-list &body body)
+ )
+
+(defmacro flet (functions &body body)
+ )
+
+(defmacro labels (functions &body body)
+ )
+
+(defmacro macrolet (macros &body body)
+ )
+
+(defun funcall (function &rest args)
+ (when (and (symbolp function)
+ (or (not (fboundp function))
+ (do ((x '(block catch eval-when flet function go if labels let
+ let* load-time-value locally macrolet
+ multiple-value-call multiple-value-prog1 progn progv
+ quote return-from setq symbol-macrolet tagbody the
+ throw unwind-protect)
+ (cdr x)))
+ ((null x) nil)
+ (when (eq function (car x))
+ (return t)))
+ (macro-function function)))
+ (error 'undefined-function :name function))
+ (apply function args))
+
+(defconstant call-arguments-limit
+ 50
+ "An integer not smaller than 50 and at least as great as the value of lambda-parameters-limit, the exact magnitude of which is implementation-dependent.")
+
+(defconstant lambda-parameters-limit
+ 50
+ "A positive integer that is the upper exclusive bound on the number of parameter names that can appear in a single lambda list.")
+
+(defconstant lambda-list-keywords
+ '(&allow-other-keys &aux &body &environment &key &optional &rest &whole)
+ "a list, the elements of which are implementation-dependent, but which must contain at least the symbols &allow-other-keys, &aux, &body, &environment, &key, &optional, &rest, and &whole.")
+
+(defmacro defparameter (name initial-value
+ &optional (documentation nil documentation-p))
+ `(progn (declaim (special ,name))
+ (setf (symbol-value ',name) ,initial-value)
+ ,(when documentation-p
+ `(setf (documentation ',name 'variable) ',documentation))
+ ',name))
+
+(defmacro defvar (name &optional
+ (initial-value nil initial-value-p)
+ (documentation nil documentation-p))
+ `(progn (declaim (special ,name))
+ ,(when initial-value-p
+ `(unless (boundp ',name)
+ (setf (symbol-value ',name) ,initial-value)))
+ ,(when documentation-p
+ `(setf (documentation ',name 'variable) ',documentation))
+ ',name))
+
+
+(defmacro defconstant (name initial-value &optional documentation)
+ )
+
+(defmacro destructuring-bind (lambda-list expression &body body)
+ )
+
+(defmacro let (vars &body body)
+ )
+
+(defmacro let* (vars &body body)
+ )
+
+(defmacro progv (symbols values &body body)
+ )
+
+(defmacro setq (&rest pairs)
+ )
+
+(defmacro block (name &body body)
+ )
+
+(defmacro catch (tag &body body)
+ )
+
+(defmacro go (tag)
+ )
+
+(defmacro return-from (name &optional result)
+ )
+
+(defmacro tagbody (&body body)
+ )
+
+(defmacro throw (tag result-form)
+ )
+
+(defmacro unwind-protect (protected-form &rest cleanup-forms)
+ )
+
+(defun eq (x y)
+ )
+
+(defun eql (x y)
+ (or (eq x y)
+ (and (numberp x) (numberp y) (= x y) (eq (type-of x) (type-of y)))
+ (and (characterp x) (characterp y) (char= x y))))
+
+(defun equalp (x y)
+ (cond
+ ((eq x y) t)
+ ((characterp x) (and (characterp y) (char-equal x y)))
+ ((numberp x) (and (numberp y) (= x y)))
+ ((consp x) (and (consp y) (equalp (car x) (car y)) (equalp (cdr x) (cdr y))))
+ ((arrayp x) (and (arrayp y)
+ (equal (array-dimensions x) (array-dimensions y))
+ (dotimes (i (array-total-size x) t)
+ (unless (equalp (row-major-aref x i) (row-major-aref y i))
+ (return nil)))))
+ ((hash-table-p x) (and (hash-table-p y)
+ (= (hash-table-count x) (hash-table-count y))
+ (eq (hash-table-test x) (hash-table-test y))
+ (with-hash-table-iterator (get x)
+ (loop
+ (multiple-value-bind (entry-returned key x-value)
+ (get)
+ (unless entry-returned
+ (return t))
+ (multiple-value-bind (y-value present-p)
+ (gethash key y)
+ (unless (and present-p (equalp x-value y-value))
+ (return nil))))))))
+ ((typep x 'structure-object) (and (typep x 'structure-object)
+ (eq (class-of x) (class-of y))
+ ))
+ (t nil)))
+
+
+(defun values (&rest object)
+ )
+
+(defmacro multiple-value-call (function-form &body body)
+ )
+
+(defmacro multiple-value-prog1 (first-form &rest forms)
+ )
+
+(defconstant multiple-values-limit most-positive-fixnum "")
+
+(defmacro progn (&rest forms)
+ )
+
+(defmacro define-modify-macro (name lambda-list function &optional documentation)
+ )
+
+(defmacro defsetf (access-fn &rest rest)
+ )
+
+(defmacro define-setf-expander (access-fn lambda-list &body body)
+ )
+
+(defun get-setf-expansion (place &optional environment)
+ )
+
+
+;; eval
+(defun compile (name &optional definition)
+ (compile name definition))
+
+(defun eval (form)
+ )
+
+(defun compiler-macro-function (name &optional environment)
+ )
+
+(defsetf compiler-macro-function (name &optional environment) (new-function)
+ )
+
+(defmacro define-compiler-macro (name lambda-list &body body)
+ )
+
+(defmacro defmacro (name lambda-list &body body)
+ )
+
+(defun macro-function (symbol &optional environment)
+ )
+
+(defsetf macro-function (symbol &optional environment) (new-function)
+ )
+
+(defun macroexpand-1 (form &optional env)
+ )
+
+(defmacro define-symbol-macro (symbol expansion)
+ )
+
+(defvar *macroexpand-hook* #'funcall
+ "")
+
+(defun proclaim (declaration-specifier)
+ )
+
+(defmacro declaim (&rest declaration-specifiers)
+ )
+
+(defun constantp (form &optional environment)
+ )
+
+
+;; array
+(defun arrayp (object)
+ (arrayp object))
+
+(defun make-array (dimensions &key (element-type t)
+ initial-element initial-contents adjustable
+ fill-pointer displaced-to displaced-index-offset)
+ )
+
+(defun adjust-array (array new-dimensions &key
+ (element-type (array-element-type array))
+ initial-element initial-contents
+ fill-pointer displaced-to displaced-index-offset)
+ )
+
+
+(defun adjustable-array-p (array)
+ (adjustable-array-p array))
+
+(defun array-dimensions (array)
+ (array-dimensions array))
+
+(defun array-element-type (array)
+ (array-element-type array))
+
+(defun array-has-fill-pointer-p (array)
+ (array-has-fill-pointer-p array))
+
+(defun array-displacement (array)
+ (array-displacement array))
+
+(defun fill-pointer (vector)
+ (fill-pointer vector))
+
+(defsetf fill-pointer (vector) (value)
+ `(setf (fill-pointer ,vector) ,value))
+
+(defun row-major-aref (array index)
+ (row-major-aref array index))
+
+(defsetf row-major-aref (array index) (value)
+ `(setf (row-major-aref ,array ,index) ,value))
+
+(defun upgraded-array-element-type (typespec &optional environment)
+ (upgraded-array-element-type typespec environment))
+
+(defconst array-dimension-limit 1024
+ "")
+
+(defconst array-rank-limit 8
+ "")
+
+(defconst array-total-size-limit 1024
+ "")
+
+(defun simple-vector-p (object)
+ ""
+ (simple-vector-p object))
+
+(defun svref (simple-vector index)
+ ""
+ (svref simple-vector index))
+
+(defsetf svref (simple-vector index) (value)
+ `(setf (svref ,simple-vector ,index) ,value))
+
+(defun bit (bit-array &rest subscripts)
+ (apply #'bit bit-array subscripts))
+
+(defsetf bit (bit-array &rest subscripts) (value)
+ `(setf (apply #'bit ,bit-array ,subscripts) ,value))
+
+(defun sbit (bit-array &rest subscripts)
+ (apply #'sbit bit-array subscripts))
+
+(defsetf sbit (bit-array &rest subscripts) (value)
+ `(setf (apply #'sbit ,bit-array ,subscripts) ,value))
+
+
+(defun bit-and (bit-array1 bit-array2 &optional opt-arg)
+ (bit-and bit-array1 bit-array2 opt-arg))
+
+(defun bit-ior (bit-array1 bit-array2 &optional opt-arg)
+ (bit-ior bit-array1 bit-array2 opt-arg))
+
+(defun bit-xor (bit-array1 bit-array2 &optional opt-arg)
+ (bit-xor bit-array1 bit-array2 opt-arg))
+
+(defun bit-not (bit-array &optional opt-arg)
+ (bit-not bit-array opt-arg))
+
+
+;; string
+(defun char (string index)
+ (char string index))
+
+(defsetf char (string index) (value)
+ `(setf (char ,string ,index) ,value))
+
+(defun schar (string index)
+ (schar string index))
+
+(defsetf schar (string index) (value)
+ `(setf (schar ,string ,index) ,value))
+
+
+;; character
+(defconst char-code-limit 256
+ "")
+
+(defun char= (character &rest more-characters)
+ (apply #'char= character more-characters))
+
+(defun char< (character &rest more-characters)
+ (apply #'char< character more-characters))
+
+(defun characterp (object)
+ (characterp object))
+
+(defun alpha-char-p (character)
+ (alpha-char-p character))
+
+(defun alphanumericp (character)
+ (alphanumericp character))
+
+(defun graphic-char-p (character)
+ (graphic-char-p character))
+
+(defun char-upcase (character)
+ (char-upcase character))
+
+(defun char-downcase (character)
+ (char-downcase character))
+
+(defun upper-case-p (character)
+ (upper-case-p character))
+
+(defun lower-case-p (character)
+ (lower-case-p character))
+
+(defun both-case-p (character)
+ (both-case-p character))
+
+(defun char-code (character)
+ (char-code character))
+
+(defun char-int (character)
+ (char-int character))
+
+(defun char-name (character)
+ (char-name character))
+
+(defun name-char (name)
+ (name-char name))
+
+
+;; sequence
+(defun make-sequence (result-type size &key initial-element)
+ "Return a sequence of the type RESULT-TYPE and of length SIZE."
+ )
+
+
+;; hash-table
+
+;; (defun hash-table-p (object)
+;; )
+;;
+;; (defun make-hash-table (&key test size rehash-size rehash-threshold)
+;; )
+
+;; (defun hash-table-count (hash-table)
+;; )
+;;
+;; (defun hash-table-size (hash-table)
+;; )
+;;
+;; (defun hash-table-rehash-size (hash-table)
+;; )
+;;
+;; (defun hash-table-rehash-threshold (hash-table)
+;; )
+;;
+;; (defun hash-table-test (hash-table)
+;; )
+
+;; (defun gethash (key hash-table &optional default)
+;; )
+;;
+;; (defsetf gethash (key hash-table &optional default) (value)
+;; `(setf (gethash ,key ,hash-table ,default) ,value))
+
+;; (defun remhash (key hash-table)
+;; )
+
+;; (defmacro with-hash-table-iterator ((name hash-table) &body body)
+;; )
+
+;; (defun clrhash (hash-table)
+;; )
+
+(defun sxhash (object)
+ (rem (equal-hash) most-positive-fixnum))
+
+
+;; stream
+(defun streamp (object)
+ )
+
+(defun input-stream-p (stream)
+ )
+
+(defun output-stream-p (stream)
+ )
+
+(defun interactive-stream-p (stream)
+ )
+
+(defun open-stream-p (stream)
+ )
+
+(defun stream-element-type (stream)
+ )
+
+(defun read-byte (stream &optional eof-error-p eof-value)
+ )
+
+(defun write-byte (byte stream)
+ )
+
+(defun peek-char (&optional peek-type input-stream eof-error-p eof-value
+ recursive-p)
+ )
+
+(defun read-char (&optional input-stream eof-error-p eof-value recursive-p)
+ )
+
+(defun read-char-no-hang (&optional input-stream eof-error-p eof-value
+ recursive-p)
+ )
+
+(defun unread-char (character &optional input-stream)
+ )
+
+(defun write-char (character &optional output-stream)
+ )
+
+(defun fresh-line (&optional output-stream)
+ )
+
+(defun file-length (stream)
+ )
+
+(defun file-position (stream &optional position)
+ )
+
+(defun file-string-length (stream object)
+ )
+
+(defun open (filespec &key direction element-type
+ if-exists if-does-not-exist external-format)
+ )
+
+(defun stream-external-format (stream)
+ )
+
+(defun close (stream &key abort)
+ )
+
+(defun listen (&optional input-stream)
+ )
+
+(defun clear-input (&optional input-stream)
+ )
+
+(defun finish-output (&optional output-stream)
+ )
+
+(defun force-output (&optional output-stream)
+ )
+
+(defun clear-output (&optional output-stream)
+ )
+
+(defun y-or-n-p (&optional control &rest arguments)
+ )
+
+(defun yes-or-no-p (&optional control &rest arguments)
+ )
+
+(defun make-synonym-stream (symbol)
+ )
+
+(defun synonym-stream-symbol (synonym-stream)
+ )
+
+(defun make-broadcast-stream (&rest streams)
+ )
+
+(defun broadcast-stream-streams (broadcast-stream)
+ )
+
+(defun make-two-way-stream (input-stream output-stream)
+ )
+
+(defun two-way-stream-input-stream (two-way-stream)
+ )
+
+(defun two-way-stream-output-stream (two-way-stream)
+ )
+
+(defun make-echo-stream (input-stream output-stream)
+ )
+
+(defun echo-stream-input-stream (echo-stream)
+ )
+
+(defun echo-stream-output-stream (echo-stream)
+ )
+
+(defun make-concatenated-stream (&rest input-streams)
+ )
+
+(defun concatenated-stream-streams (concatenated-stream)
+ )
+
+
+(defun make-string-input-stream (string &optional start end)
+ )
+
+(defun make-string-output-stream (&key element-type)
+ )
+
+(defun get-output-stream-string (string-output-stream)
+ )
+
+
+(defun stream-error-stream (condition)
+ )
+
+(defvar *DEBUG-IO*)
+(defvar *ERROR-OUTPUT*)
+(defvar *QUERY-IO*)
+(defvar *STANDARD-INPUT*)
+(defvar *STANDARD-OUTPUT*)
+(defvar *TRACE-OUTPUT*)
+(defvar *TERMINAL-IO*)
+
+(defmacro with-input-from-string ((var string &key index (start 0) end)
+ &body body)
+ (multiple-value-bind (decls forms) (declarations-and-forms body)
+ `(let ((,var (make-string-input-stream ,string ,start ,end)))
+ ,@decls
+ (unwind-protect
+ (progn ,@forms)
+ (close ,var)
+ ,@(when index
+ `((setf ,index (string-input-stream-current-position ,var))))))))
+
+
+(defmacro with-output-to-string ((var &optional string-form &key element-type)
+ &body body))
+
+
+;;; package
diff --git a/Sacla/data-and-control.lisp b/Sacla/data-and-control.lisp
new file mode 100644
index 0000000..cea7493
--- /dev/null
+++ b/Sacla/data-and-control.lisp
@@ -0,0 +1,388 @@
+;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
+;; ALL RIGHTS RESERVED.
+;;
+;; $Id: data-and-control.lisp,v 1.17 2004/09/02 06:59:43 yuji Exp $
+;;
+;; 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.
+;;
+;; 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.
+
+(defun expand-case (keyform clauses &key (test #'eql))
+ (let ((key (gensym))
+ (last (car (last clauses))))
+ `(let ((,key ,keyform))
+ (declare (ignorable ,key))
+ (cond
+ ,@(mapcar
+ #'(lambda (clause)
+ (let ((key-list (first clause))
+ (forms (rest clause)))
+ (cond
+ ((and (eq clause last) (member key-list '(otherwise t)))
+ `(t ,@forms))
+ ((not (listp key-list))
+ `((funcall ',test ,key ',key-list) ,@forms))
+ ((null key-list)
+ `(nil ,@forms))
+ ((rest key-list)
+ `((member ,key ',key-list :test ',test) ,@forms))
+ (t
+ `((funcall ',test ,key ',(car key-list)) ,@forms)))))
+ clauses)))))
+
+(defmacro psetq (&rest pairs)
+ ;; not use reverse for build order consistency
+ (do* ((pairs pairs (cddr pairs))
+ (tmp (gensym) (gensym))
+ (inits (list nil))
+ (inits-splice inits)
+ (setqs (list nil))
+ (setqs-splice setqs))
+ ((null pairs) (when (cdr inits)
+ `(let ,(cdr inits)
+ (setq ,@(cdr setqs))
+ nil)))
+ (setq inits-splice
+ (cdr (rplacd inits-splice (list (list tmp (cadr pairs)))))
+ setqs-splice
+ (cddr (rplacd setqs-splice (list (car pairs) tmp))))))
+
+
+(defmacro return (&optional result)
+ `(return-from nil ,result))
+
+(defun not (x)
+ (if x nil t))
+
+(defun equal (x y)
+ (cond
+ ((eql x y) t)
+ ((consp x) (and (consp y) (equal (car x) (car y)) (equal (cdr x) (cdr y))))
+ ((stringp x) (and (stringp y) (string= x y)))
+ ((bit-vector-p x) (and (bit-vector-p y) (= (length x) (length y))
+ (dotimes (i (length x) t)
+ (unless (eql (aref x i) (aref y i))
+ (return nil)))))
+ ((pathnamep x) (and (pathnamep y)
+ (equal (pathname-host x) (pathname-host y))
+ (equal (pathname-device x) (pathname-device y))
+ (equal (pathname-directory x) (pathname-directory y))
+ (equal (pathname-name x) (pathname-name y))
+ (equal (pathname-type x) (pathname-type y))
+ (equal (pathname-version x) (pathname-version y))))
+ (t nil)))
+
+(defun identity (object)
+ object)
+
+(defun complement (function)
+ #'(lambda (&rest arguments) (not (apply function arguments))))
+
+(defun constantly (object)
+ #'(lambda (&rest arguments)
+ (declare (ignore arguments))
+ object))
+
+(defmacro and (&rest forms)
+ (cond
+ ((null forms) t)
+ ((null (cdr forms)) (car forms))
+ (t `(when ,(car forms)
+ (and ,@(cdr forms))))))
+
+(defmacro or (&rest forms)
+ (cond
+ ((null forms) nil)
+ ((null (cdr forms)) (car forms))
+ (t (let ((tmp (gensym)))
+ `(let ((,tmp ,(car forms)))
+ (if ,tmp
+ ,tmp
+ (or ,@(cdr forms))))))))
+
+(defmacro cond (&rest clauses)
+ (when clauses
+ (let ((test1 (caar clauses))
+ (forms1 (cdar clauses)))
+ (if forms1
+ `(if ,test1
+ (progn ,@forms1)
+ (cond ,@(cdr clauses)))
+ (let ((tmp (gensym)))
+ `(let ((,tmp ,test1))
+ (if ,tmp
+ ,tmp
+ (cond ,@(cdr clauses)))))))))
+
+(defmacro when (test-form &rest forms)
+ `(if ,test-form
+ (progn ,@forms)
+ nil))
+
+(defmacro unless (test-form &rest forms)
+ `(if ,test-form
+ nil
+ (progn ,@forms)))
+
+
+(defmacro case (keyform &rest clauses)
+ (expand-case keyform clauses))
+
+(defmacro ccase (keyplace &rest clauses)
+ (let* ((clauses (mapcar #'(lambda (clause)
+ (let ((key (first clause))
+ (forms (rest clause)))
+ `(,(%list key) ,@forms)))
+ clauses))
+ (expected-type `(member ,@(apply #'append (mapcar #'car clauses))))
+ (block-name (gensym))
+ (tag (gensym)))
+ `(block ,block-name
+ (tagbody
+ ,tag
+ (return-from ,block-name
+ (case ,keyplace
+ ,@clauses
+ (t (restart-case (error 'type-error :datum ,keyplace
+ :expected-type ',expected-type)
+ (store-value (value)
+ :report (lambda (stream)
+ (store-value-report stream ',keyplace))
+ :interactive store-value-interactive
+ (setf ,keyplace value)
+ (go ,tag))))))))))
+
+
+(defmacro ecase (keyform &rest clauses)
+ (let* ((clauses (mapcar #'(lambda (clause)
+ (let ((key (first clause))
+ (forms (rest clause)))
+ `(,(%list key) ,@forms)))
+ clauses))
+ (expected-type `(member ,@(apply #'append (mapcar #'car clauses)))))
+ `(case ,keyform
+ ,@clauses
+ (t (error 'type-error :datum ,keyform :expected-type ',expected-type)))))
+
+(defmacro typecase (keyform &rest clauses)
+ (let* ((last (car (last clauses)))
+ (clauses (mapcar #'(lambda (clause)
+ (let ((type (first clause))
+ (forms (rest clause)))
+ (if (and (eq clause last)
+ (member type '(otherwise t)))
+ clause
+ `((,type) ,@forms))))
+ clauses)))
+ (expand-case keyform clauses :test #'typep)))
+
+(defmacro ctypecase (keyplace &rest clauses)
+ (let ((expected-type `(or ,@(mapcar #'car clauses)))
+ (block-name (gensym))
+ (tag (gensym)))
+ `(block ,block-name
+ (tagbody
+ ,tag
+ (return-from ,block-name
+ (typecase ,keyplace
+ ,@clauses
+ (t (restart-case (error 'type-error
+ :datum ,keyplace
+ :expected-type ',expected-type)
+ (store-value (value)
+ :report (lambda (stream)
+ (store-value-report stream ',keyplace))
+ :interactive store-value-interactive
+ (setf ,keyplace value)
+ (go ,tag))))))))))
+
+
+
+(defmacro etypecase (keyform &rest clauses)
+ `(typecase ,keyform
+ ,@clauses
+ (t (error 'type-error
+ :datum ',keyform :expected-type '(or ,@(mapcar #'car clauses))))))
+
+
+(defmacro multiple-value-bind (vars values-form &body body)
+ (cond
+ ((null vars)
+ `(progn ,@body))
+ ((null (cdr vars))
+ `(let ((,(car vars) ,values-form))
+ ,@body))
+ (t
+ (let ((rest (gensym)))
+ `(multiple-value-call #'(lambda (&optional ,@vars &rest ,rest)
+ (declare (ignore ,rest))
+ ,@body)
+ ,values-form)))))
+
+
+
+(defmacro multiple-value-list (form)
+ `(multiple-value-call #'list ,form))
+
+(defmacro multiple-value-setq (vars form)
+ `(values (setf (values ,@vars) ,form)))
+;; (let ((temps (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) vars)))
+;; `(multiple-value-bind ,temps ,form
+;; (setq ,@(mapcan #'(lambda (var temp) (list var temp)) vars temps))
+;; ,(car temps))))
+
+(defun values-list (list)
+ (check-type list proper-list)
+ (apply #'values list))
+
+(defmacro nth-value (n form)
+ `(nth ,n (multiple-value-list ,form)))
+
+(define-setf-expander values (&rest places &environment env)
+ (let (all-temps all-vars 1st-newvals rest-newvals all-setters all-getters)
+ (dolist (place places)
+ (multiple-value-bind (temps vars newvals setter getter)
+ (get-setf-expansion place env)
+ (setq all-temps (cons temps all-temps)
+ all-vars (cons vars all-vars)
+ 1st-newvals (cons (car newvals) 1st-newvals)
+ rest-newvals (cons (cdr newvals) rest-newvals)
+ all-setters (cons setter all-setters)
+ all-getters (cons getter all-getters))))
+ (values (apply #'append (reverse (append rest-newvals all-temps)))
+ (append (apply #'append (reverse all-vars))
+ (make-list (reduce #'+ rest-newvals :key #'length)))
+ (reverse 1st-newvals)
+ `(values ,@(reverse all-setters))
+ `(values ,@(reverse all-getters)))))
+
+;;(define-setf-expander apply (function &rest args)
+;; (assert (and (listp function)
+;; (= (list-length function) 2)
+;; (eq (first function) 'function)
+;; (symbolp (second function))))
+;; (let ((function (cadr function))
+;; (newvals (list (gensym)))
+;; (temps (mapcar #'(lambda (arg) (gensym)) args)))
+;; (values temps
+;; args
+;; newvals
+;; `(apply #'(setf ,function) ,(car newvals) ,@vars)
+;; `(apply #',function ,@temps))))
+
+(defmacro prog (vars &body body)
+ (flet ((declare-p (expr)
+ (and (consp expr) (eq (car expr) 'declare))))
+ (do ((decls nil)
+ (forms body (cdr forms)))
+ ((not (declare-p (car forms))) `(block nil
+ (let ,vars
+ ,@(reverse decls)
+ (tagbody ,@forms))))
+ (push (car forms) decls))))
+
+(defmacro prog* (vars &body body)
+ (multiple-value-bind (decls forms) (declarations-and-forms body)
+ `(block nil
+ (let* ,vars
+ ,@(reverse decls)
+ (tagbody ,@forms)))))
+
+(defmacro prog1 (first-form &rest more-forms)
+ (let ((result (gensym)))
+ `(let ((,result ,first-form))
+ ,@more-forms
+ ,result)))
+
+(defmacro prog2 (first-form second-form &rest more-forms)
+ `(prog1 (progn ,first-form ,second-form) ,@more-forms))
+
+
+(defmacro setf (&rest pairs &environment env)
+ (let ((nargs (length pairs)))
+ (assert (evenp nargs))
+ (cond
+ ((zerop nargs) nil)
+ ((= nargs 2)
+ (let ((place (car pairs))
+ (value-form (cadr pairs)))
+ (cond
+ ((symbolp place)
+ `(setq ,place ,value-form))
+ ((consp place)
+ (if (eq (car place) 'the)
+ `(setf ,(caddr place) (the ,(cadr place) ,value-form))
+ (multiple-value-bind (temps vars newvals setter getter)
+ (get-setf-expansion place env)
+ (declare (ignore getter))
+ `(let (,@(mapcar #'list temps vars))
+ (multiple-value-bind ,newvals ,value-form
+ ,setter))))))))
+ (t
+ (do* ((pairs pairs (cddr pairs))
+ (setfs (list 'progn))
+ (splice setfs))
+ ((endp pairs) setfs)
+ (setq splice (cdr (rplacd splice
+ `((setf ,(car pairs) ,(cadr pairs)))))))))))
+
+(defmacro psetf (&rest pairs &environment env)
+ (let ((nargs (length pairs)))
+ (assert (evenp nargs))
+ (if (< nargs 4)
+ `(progn (setf ,@pairs) nil)
+ (let ((setters nil))
+ (labels ((expand (pairs)
+ (if pairs
+ (multiple-value-bind (temps vars newvals setter getter)
+ (get-setf-expansion (car pairs) env)
+ (declare (ignore getter))
+ (setq setters (cons setter setters))
+ `(let (,@(mapcar #'list temps vars))
+ (multiple-value-bind ,newvals ,(cadr pairs)
+ ,(expand (cddr pairs)))))
+ `(progn ,@setters nil))))
+ (expand pairs))))))
+
+(defmacro shiftf (&rest places-and-newvalue &environment env)
+ (let ((nargs (length places-and-newvalue)))
+ (assert (>= nargs 2))
+ (let ((place (car places-and-newvalue)))
+ (multiple-value-bind (temps vars newvals setter getter)
+ (get-setf-expansion place env)
+ `(let (,@(mapcar #'list temps vars))
+ (multiple-value-prog1 ,getter
+ (multiple-value-bind ,newvals
+ ,(if (= nargs 2)
+ (cadr places-and-newvalue)
+ `(shiftf ,@(cdr places-and-newvalue)))
+ ,setter)))))))
+
+(defmacro rotatef (&rest places &environment env)
+ (if (< (length places) 2)
+ nil
+ (multiple-value-bind (temps vars newvals setter getter)
+ (get-setf-expansion (car places) env)
+ `(let (,@(mapcar #'list temps vars))
+ (multiple-value-bind ,newvals (shiftf ,@(cdr places) ,getter)
+ ,setter)
+ nil))))
diff --git a/Sacla/do.lisp b/Sacla/do.lisp
new file mode 100644
index 0000000..6b7d3fd
--- /dev/null
+++ b/Sacla/do.lisp
@@ -0,0 +1,85 @@
+;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
+;; ALL RIGHTS RESERVED.
+;;
+;; $Id: do.lisp,v 1.12 2004/05/26 07:57:52 yuji Exp $
+;;
+;; 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.
+;;
+;; 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.
+
+
+(defun do-expand (var-init-step-list test-and-result-forms body parallel-p)
+ (let ((top (gensym))
+ (test-form (first test-and-result-forms))
+ (result-forms (rest test-and-result-forms))
+ (let-operator (if parallel-p 'let 'let*))
+ (setq-operator (if parallel-p 'psetq 'setq)))
+ (multiple-value-bind (declarations forms) (declarations-and-forms body)
+ `(block nil
+ (,let-operator (,@(mapcar #'(lambda (x) (if (atom x) x (subseq x 0 2)))
+ var-init-step-list))
+ ,@declarations
+ (tagbody
+ ,top
+ (when ,test-form (return (progn ,@result-forms)))
+ ,@forms
+ (,setq-operator ,@(mapcan #'(lambda (x)
+ (when (and (consp x) (= (length x) 3))
+ `(,(first x) ,(third x))))
+ var-init-step-list))
+ (go ,top)))))))
+
+(defmacro do (var-init-step-list test-and-result-forms &body body)
+ (do-expand var-init-step-list test-and-result-forms body 'parallel))
+
+(defmacro do* (var-init-step-list test-and-result-forms &body body)
+ (do-expand var-init-step-list test-and-result-forms body nil))
+
+(defmacro dotimes ((var count-form &optional result-form) &body body)
+ (let ((max (gensym)))
+ `(do* ((,max ,count-form)
+ (,var 0 (1+ ,var)))
+ ((>= ,var ,max) ,result-form)
+ ,@body)))
+
+(defmacro dolist ((var list-form &optional result-form) &body body)
+ (let ((top (gensym))
+ (tag (gensym))
+ (list (gensym)))
+ (multiple-value-bind (declarations forms) (declarations-and-forms body)
+ `(block nil
+ (let ((,list ,list-form)
+ (,var nil))
+ (declare (ignorable ,var))
+ (unless (atom ,list)
+ (let ((,var (car ,list)))
+ ,@declarations
+ (block ,tag
+ (tagbody
+ ,top
+ ,@forms
+ (setq ,list (cdr ,list))
+ (when (atom ,list) (return-from ,tag))
+ (setq ,var (car ,list))
+ (go ,top)))))
+ ,result-form)))))
+
diff --git a/Sacla/eval.lisp b/Sacla/eval.lisp
new file mode 100644
index 0000000..fec502a
--- /dev/null
+++ b/Sacla/eval.lisp
@@ -0,0 +1,46 @@
+;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
+;; ALL RIGHTS RESERVED.
+;;
+;; $Id: eval.lisp,v 1.6 2004/02/20 07:23:42 yuji Exp $
+;;
+;; 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.
+;;
+;; 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.
+
+;;(defmacro lambda (lambda-list &body body)
+;; (function `(lambda ,lambda-list ,@body)))
+
+;;(defun macroexpand (form &optional env)
+;; (multiple-value-bind (expansion expanded-p)
+;; (macroexpand-1 form env)
+;; (if (not expanded-p)
+;; (return (values form nil)))
+;; (loop
+;; (multiple-value-bind (expansion expanded-p)
+;; (macroexpand-1 expansion expanded-p))
+;; (unless expanded-p
+;; (return (values expansion t))))))
+
+(defun special-operator-p (symbol)
+ (check-type symbol symbol)
+ (member symbol '(block catch eval-when flet function go if labels let let* load-time-value locally macrolet multiple-value-call multiple-value-prog1 progn progv quote return-from setq symbol-macrolet tagbody the throw unwind-protect)))
+
diff --git a/Sacla/hash-table.lisp b/Sacla/hash-table.lisp
new file mode 100644
index 0000000..d45ebcb
--- /dev/null
+++ b/Sacla/hash-table.lisp
@@ -0,0 +1,248 @@
+;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
+;; ALL RIGHTS RESERVED.
+;;
+;; $Id: hash-table.lisp,v 1.14 2004/09/02 06:59:43 yuji Exp $
+;;
+;; 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.
+;;
+;; 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.
+
+(defun %print-hash-table (hash-table stream depth)
+ (declare (ignore depth))
+ (format stream "#<~A hash table (sumire), ~D entr~@:P>"
+ (symbol-name (hash-table-test hash-table))
+ (hash-table-count hash-table)))
+
+;;(defun prime ()
+;; (do ((primes (list 3))
+;; (n 5 (+ n 2)))
+;; ((> n 10000))
+;; (dolist (prime primes (progn (push n primes) (print n)))
+;; (when (zerop (rem n prime))
+;; (return)))))
+;;
+;;(defun prime-p (n)
+;; (do ((i 2 (1+ i)))
+;; ((= i n) t)
+;; (when (zerop (rem n i))
+;; (return nil))))
+
+(defun touch-up-size (size)
+ (let ((primes '(211 307 401 503 601 701 809 907 1009 1259 1511 2003 3001
+ 4001 5003 6007 7001 8009 9001 10007 12007 14009 16001 18013
+ 20011 30011 40009 50021 60013 70001 80021 90001 100003)))
+ (dolist (prime primes)
+ (when (> prime size)
+ (return-from touch-up-size prime))))
+ (setq size (ceiling size))
+ (when (zerop (rem size 2)) (incf size))
+ (when (zerop (rem size 3)) (incf size 2))
+ (when (zerop (rem size 7)) (incf size 4))
+ size)
+
+(defun calculate-rehash-count (size rehash-threshold)
+ (floor (* size (max 0.2 rehash-threshold))))
+
+(defstruct (hash-table
+ (:constructor %make-hash-table)
+ (:print-function %print-hash-table))
+ ""
+ (count 0 :type (integer 0 *))
+ (size (required-argument) :type (integer 0 *))
+ (rehash-size (required-argument)
+ :type (or (integer 1 *) (float (1.0) *)) :read-only t)
+ (rehash-threshold (required-argument) :type (real 0 1) :read-only t)
+ (test (required-argument) :type symbol :read-only t)
+ (test-function (required-argument) :type function :read-only t)
+ (hash-function (required-argument) :type function :read-only t)
+ (buckets (required-argument) :type vector)
+ (rehash-count (required-argument) :type (integer 0 *)))
+
+(defun make-hash-table (&key (test 'eql)
+ (size 67)
+ (rehash-size 1.5)
+ (rehash-threshold 0.5))
+ (cond
+ ((eq test #'eq) (setq test 'eq))
+ ((eq test #'eql) (setq test 'eql))
+ ((eq test #'equal) (setq test 'equal))
+ ((eq test #'equalp) (setq test 'equalp)))
+ (let* ((hash-function (ecase test
+ (eq #'eq-hash)
+ (eql #'eql-hash)
+ (equal #'equal-hash)
+ (equalp #'equalp-hash)))
+ (size (touch-up-size size))
+ (buckets (make-array size :initial-element nil))
+ (rehash-count (calculate-rehash-count size rehash-threshold))
+ (hash-table (%make-hash-table :size size
+ :rehash-size rehash-size
+ :rehash-threshold rehash-threshold
+ :rehash-count rehash-count
+ :buckets buckets
+ :test test
+ :test-function (symbol-function test)
+ :hash-function hash-function)))
+ hash-table))
+
+(defun gethash (key hash-table &optional default)
+ (let* ((hash (funcall (hash-table-hash-function hash-table) key))
+ (size (hash-table-size hash-table))
+ (test-function (hash-table-test-function hash-table))
+ (chain (aref (hash-table-buckets hash-table) (rem hash size))))
+ (do ((plist chain (cddr plist)))
+ ((atom plist) (values default nil))
+ (when (funcall test-function (car plist) key)
+ (return (values (cadr plist) t))))))
+
+(defun puthash (key value hash-table)
+ (let* ((hash (funcall (hash-table-hash-function hash-table) key))
+ (size (hash-table-size hash-table))
+ (test-function (hash-table-test-function hash-table))
+ (buckets (hash-table-buckets hash-table))
+ (index (rem hash size))
+ (chain (aref buckets index)))
+ (do ((plist chain (cddr plist)))
+ ((atom plist) (progn
+ (setf (aref buckets index) (cons key (cons value chain)))
+ (incf (hash-table-count hash-table))))
+ (when (funcall test-function (car plist) key)
+ (rplaca (cdr plist) value)
+ (return))))
+ value)
+
+(defun rehash-hash-table (hash-table)
+ (let* ((old-size (hash-table-size hash-table))
+ (old-buckets (hash-table-buckets hash-table))
+ (rehash-threshold (hash-table-rehash-threshold hash-table))
+ (rehash-size (hash-table-rehash-size hash-table))
+ (count (hash-table-count hash-table))
+ (size (touch-up-size (max (funcall (if (integerp rehash-size) #'+ #'*)
+ old-size rehash-size)
+ (/ count (max 0.5 rehash-threshold)))))
+ (buckets (make-array size :initial-element nil)))
+ (setf (hash-table-count hash-table) 0
+ (hash-table-size hash-table) size
+ (hash-table-buckets hash-table) buckets
+ (hash-table-rehash-count hash-table) (calculate-rehash-count
+ size rehash-threshold))
+ (dotimes (i old-size)
+ (do ((chain (aref old-buckets i) (cddr chain)))
+ ((atom chain))
+ (puthash (car chain) (cadr chain) hash-table))))
+ hash-table)
+
+(defun (setf gethash) (value key hash-table &optional default)
+ (declare (ignore default))
+ (when (>= (hash-table-count hash-table) (hash-table-rehash-count hash-table))
+ (rehash-hash-table hash-table))
+ (puthash key value hash-table)
+ value)
+
+(defun remhash (key hash-table)
+ (let* ((hash (funcall (hash-table-hash-function hash-table) key))
+ (size (hash-table-size hash-table))
+ (test-function (hash-table-test-function hash-table))
+ (buckets (hash-table-buckets hash-table))
+ (index (rem hash size))
+ (chain (aref buckets index)))
+ (do ((plist chain (cddr plist))
+ (last nil (cdr plist)))
+ ((atom plist) nil)
+ (when (funcall test-function (car plist) key)
+ (if last
+ (rplacd last (cddr plist))
+ (setf (aref buckets index) (cddr plist)))
+ (decf (hash-table-count hash-table))
+ (return t)))))
+
+
+(defun clrhash (hash-table)
+ (let ((buckets (hash-table-buckets hash-table))
+ (size (hash-table-size hash-table)))
+ (dotimes (i size)
+ (setf (elt buckets i) nil))
+ (setf (hash-table-count hash-table) 0)
+ hash-table))
+
+(defun hash-table-iterator-1 (table)
+ (let* ((index 0)
+ (size (hash-table-size table))
+ (chain (aref (hash-table-buckets table) 0)))
+ #'(lambda ()
+ (block iterator
+ (loop
+ (when chain (return))
+ (incf index)
+ (when (= index size) (return-from iterator nil))
+ (setq chain (aref (hash-table-buckets table) index)))
+ (multiple-value-prog1 (values t (first chain) (second chain))
+ (setq chain (cddr chain)))))))
+
+(defun hash-table-iterator (hash-table-list)
+ (let ((tables (%list hash-table-list)))
+ (cond
+ ((null tables) (constantly nil))
+ ((null (rest tables)) (hash-table-iterator-1 (car tables)))
+ (t (let ((iterator (hash-table-iterator-1 (pop tables))))
+ #'(lambda ()
+ (loop
+ (multiple-value-bind (more key value) (funcall iterator)
+ (cond
+ (more (return (values more key value)))
+ (tables (setq iterator (hash-table-iterator-1 (pop tables))))
+ (t (return nil)))))))))))
+
+(defmacro with-hash-table-iterator ((name hash-table-form) &body body)
+ (let ((iterator (gensym)))
+ `(let ((,iterator (hash-table-iterator ,hash-table-form)))
+ (declare (ignorable ,iterator))
+ (macrolet ((,name () '(funcall ,iterator)))
+ ,@body))))
+
+
+(defun maphash (function hash-table)
+ (with-hash-table-iterator (next-entry hash-table)
+ (loop (multiple-value-bind (more key value) (next-entry)
+ (unless more (return nil))
+ (funcall function key value)))))
+
+
+(defun eq-hash (key)
+ (sxhash key))
+(defun eql-hash (key)
+ (sxhash key))
+
+(defun equal-hash (key)
+ (sxhash key))
+
+(defun equalp-hash (key)
+ (typecase key
+ (character (sxhash (char-upcase key)))
+ (float (sxhash (rationalize key)))
+ (cons 10)
+ (array 20)
+ (hash-table (logand (equalp-hash (hash-table-count key))
+ (equalp-hash (hash-table-test key))))
+ (structure-object (sxhash (class-of key)))
+ (t (sxhash key))))
+
diff --git a/Sacla/init.lisp b/Sacla/init.lisp
new file mode 100755
index 0000000..031b8e7
--- /dev/null
+++ b/Sacla/init.lisp
@@ -0,0 +1,55 @@
+;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
+;; ALL RIGHTS RESERVED.
+;;
+;; $Id: init.lisp,v 1.7 2004/09/02 06:59:43 yuji Exp $
+;;
+;; 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.
+;;
+;; 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.
+
+;;; Commentary:
+;; I mainly use clisp, but other common lisp implementations should work
+;; with a minor tweak.
+;; Set *sacla-dir* to the dir where the sacla tree sits,
+;; like (setq *sacla-dir* /path/to/sacla).
+;; Load this file first (load "init"), then enter (in-package "TB").
+;; Load and test a lisp file like the following,
+;; (ld "reader")
+;; (test "must-reader").
+;;
+
+(defvar *sacla-dir* "/usr/local/src/lisp/sacla")
+(defvar *sacla-lisp-dir* (concatenate 'string *sacla-dir* "/lisp"))
+(defvar *sacla-lisp-tests-dir* (concatenate 'string *sacla-dir* "/lisp/tests"))
+;;"/cygdrive/c/src/lisp/sacla/lisp"
+;;(setq *print-circle* t)
+
+#+clisp (ext:cd *sacla-lisp-dir*)
+#+cmu (unix:unix-chdir *sacla-lisp-dir*)
+
+(load (concatenate 'string *sacla-lisp-dir* "/testbed"))
+
+(in-package "TB")
+(setq tb::*testbed-compile* t)
+(tb::ld "share")
+
+(push :sacla *features*)
diff --git a/Sacla/loop.lisp b/Sacla/loop.lisp
new file mode 100644
index 0000000..f1ab322
--- /dev/null
+++ b/Sacla/loop.lisp
@@ -0,0 +1,1142 @@
+;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
+;; ALL RIGHTS RESERVED.
+;;
+;; $Id: loop.lisp,v 1.38 2005/04/16 07:34:27 yuji Exp $
+;;
+;; 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.
+;;
+;; 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.
+
+#-sacla
+(progn
+ (defpackage "SACLA-LOOP"
+ (:documentation "An ANSI Common Lisp Loop facility.")
+ (:use "COMMON-LISP")
+ (:shadow "ERROR" "WARN" "LOOP" "LOOP-FINISH")
+ (:export "LOOP" "LOOP-FINISH"))
+ (in-package "SACLA-LOOP"))
+
+#-sacla
+(progn
+ (defvar *message-prefix* "")
+ (defun error (datum &rest arguments)
+ (when (stringp datum)
+ (setq datum (concatenate 'string *message-prefix* datum)))
+ (apply #'cl:error datum arguments))
+ (defun warn (datum &rest arguments)
+ (when (stringp datum)
+ (setq datum (concatenate 'string *message-prefix* datum)))
+ (apply #'cl:warn datum arguments))
+
+
+ (defun %list (designator)
+ (if (listp designator) designator (list designator)))
+ (defun %keyword (designator)
+ (intern (string designator) "KEYWORD"))
+ (define-modify-macro appendf (&rest args) append "Append onto list")
+ (defun mapappend (function &rest lists)
+ (apply #'append (apply #'mapcar function lists)))
+ (define-condition simple-program-error (simple-condition program-error) ())
+)
+
+(defun globally-special-p (symbol)
+ (assert (symbolp symbol))
+ (if (constantp symbol)
+ (values nil t)
+ #+abcl (values (EXT:SPECIAL-VARIABLE-P symbol t))
+ #+allegro (values (excl::variable-special-p symbol nil) t)
+ #+clisp (values (ext:special-variable-p symbol nil) t)
+ #+cmu (values (walker:variable-globally-special-p symbol) t)
+ #+ecl (values (si:specialp symbol) t)
+ #+gcl (values (si:specialp symbol) t)
+ #+lispworks (values (eq :special (hcl:variable-information symbol)) t)
+ #+sbcl (values (sb-walker:var-globally-special-p symbol) t)
+ #-(or abcl allegro clisp cmu ecl gcl lispworks sbcl)
+ (progn
+ (warn "Implementation-specific globally-special-p should be defined.")
+ (values nil nil))))
+
+(defvar *loop-clauses*
+ (let ((table (make-hash-table)))
+ (mapc #'(lambda (spec)
+ (destructuring-bind (clause-name . keywords) spec
+ (dolist (key keywords) (setf (gethash key table) clause-name))))
+ '((for-as-clause :for :as)
+ (with-clause :with)
+ (do-clause :do :doing)
+ (return-clause :return)
+ (initially-clause :initially)
+ (finally-clause :finally)
+ (accumulation-clause :collect :collecting :append :appending
+ :nconc :nconcing :count :counting :sum :summing :maximize :maximizing
+ :minimize :minimizing)
+ (conditional-clause :if :when :unless)
+ (repeat-clause :repeat)
+ (always-never-thereis-clause :always :never :thereis)
+ (while-clause :while)
+ (until-clause :until)))
+ table)
+ "A table mapping loop keywords to their processor function-designator.")
+
+(defvar *for-as-subclauses*
+ (let ((table (make-hash-table)))
+ (mapc #'(lambda (spec)
+ (destructuring-bind (subclause-name . keywords) spec
+ (dolist (key keywords)
+ (setf (gethash key table) subclause-name))))
+ '((for-as-arithmetic-subclause
+ :from :downfrom :upfrom :to :downto :upto :below :above :by)
+ (for-as-in-list-subclause :in)
+ (for-as-on-list-subclause :on)
+ (for-as-equals-then-subclause :=)
+ (for-as-across-subclause :across)
+ (for-as-being-subclause :being)))
+ table)
+ "A table mapping for-as prepositions to their processor function-designator.")
+
+(defvar *for-as-prepositions*
+ (let ((prepositions nil))
+ (maphash #'(lambda (key value) (declare (ignore value)) (push key prepositions))
+ *for-as-subclauses*)
+ prepositions))
+
+(defvar *environment*)
+(defvar *loop-tokens*)
+(defvar *current-keyword* nil)
+(defvar *current-clause* nil)
+
+(defun append-context (message)
+ (concatenate 'string message
+ (let ((clause (ldiff *current-clause* *loop-tokens*)))
+ (format nil "~%Current LOOP context:~{ ~S~}" clause))))
+
+
+(defun loop-error (datum &rest arguments)
+ (when (stringp datum) (setq datum (append-context datum)))
+ (apply #'error datum arguments))
+
+(defun loop-warn (datum &rest arguments)
+ (when (stringp datum) (setq datum (append-context datum)))
+ (apply #'warn datum arguments))
+
+
+(defun keyword? (&optional keyword-list-designator)
+ (and *loop-tokens*
+ (symbolp (car *loop-tokens*))
+ (let ((keyword-list (%list keyword-list-designator))
+ (keyword (%keyword (car *loop-tokens*))))
+ (and (or (null keyword-list) (find keyword keyword-list))
+ (setq *current-clause* *loop-tokens*
+ *loop-tokens* (rest *loop-tokens*)
+ *current-keyword* keyword)))))
+
+(defun keyword1 (keyword-list-designator &key prepositionp)
+ (let ((keywords (%list keyword-list-designator)))
+ (or (keyword? keywords)
+ (let ((length (length keywords))
+ (kind (if prepositionp "preposition" "keyword")))
+ (case length
+ (0 (loop-error "A loop ~A is missing." kind))
+ (1 (loop-error "Loop ~A ~S is missing." kind (car keywords)))
+ (t (loop-error "One of the loop ~As ~S must be supplied."
+ kind keywords)))))))
+
+(defun preposition? (&optional keyword-list-designator)
+ (let ((*current-keyword* *current-keyword*)
+ (*current-clause* *current-clause*))
+ (keyword? keyword-list-designator)))
+
+(defun preposition1 (&optional keyword-list-designator)
+ (let ((*current-keyword* *current-keyword*)
+ (*current-clause* *current-clause*))
+ (keyword1 keyword-list-designator :prepositionp t)))
+
+
+
+(defvar *loop-name* nil)
+(defvar *it-symbol* nil)
+(defvar *it-visible-p* nil)
+(defvar *anonymous-accumulator* nil)
+(defvar *boolean-terminator* nil)
+(defvar *accumulators* nil)
+(defvar *loop-components* nil)
+
+
+
+(defun clause1 ()
+ (multiple-value-bind (clause-function-designator present-p)
+ (gethash *current-keyword* *loop-clauses*)
+ (unless present-p
+ (loop-error "Unknown loop keyword ~S encountered." (car *current-clause*)))
+ (let ((*message-prefix* (format nil "LOOP ~A clause: " *current-keyword*)))
+ (funcall clause-function-designator))))
+
+(defun clause* ()
+ (loop
+ (let ((key (keyword?)))
+ (unless key (return))
+ (clause1))))
+
+(defun lp (&rest tokens)
+ (let ((*loop-tokens* tokens)
+ *current-keyword*
+ *current-clause*)
+ (clause*)
+ (when *loop-tokens* (error "~S remained after lp." *loop-tokens*))))
+
+(defun form1 ()
+ (unless *loop-tokens* (loop-error "A normal lisp form is missing."))
+ (pop *loop-tokens*))
+
+(defun compound-forms* ()
+ (when (and *loop-tokens* (consp (car *loop-tokens*)))
+ (cons (pop *loop-tokens*) (compound-forms*))))
+
+(defun compound-forms+ ()
+ (or (compound-forms*) (loop-error "At least one compound form is needed.")))
+
+(defun simple-var-p (var) (and (not (null var)) (symbolp var)))
+
+(defun simple-var1 ()
+ (unless (and *loop-tokens* (simple-var-p (car *loop-tokens*)))
+ (loop-error "A simple variable name is missing."))
+ (pop *loop-tokens*))
+
+(defun empty-p (d-var-spec)
+ (or (null d-var-spec)
+ (and (consp d-var-spec)
+ (empty-p (car d-var-spec))
+ (empty-p (cdr d-var-spec)))))
+
+(defun d-var-spec-p (spec)
+ (or (simple-var-p spec)
+ (null spec)
+ (and (consp spec) (d-var-spec-p (car spec)) (d-var-spec-p (cdr spec)))))
+
+(defun d-var-spec1 ()
+ (unless (and *loop-tokens* (d-var-spec-p (car *loop-tokens*)))
+ (loop-error "A destructured-variable-spec is missing."))
+ (let ((d-var-spec (pop *loop-tokens*)))
+ d-var-spec))
+
+(defun stray-of-type-error ()
+ (loop-error "OF-TYPE keyword should be followed by a type spec."))
+
+(defun type-spec? ()
+ (let ((type t)
+ (supplied-p nil))
+ (when (or (and (preposition? :of-type) (or *loop-tokens* (stray-of-type-error)))
+ (and *loop-tokens* (member (car *loop-tokens*) '(fixnum float t nil))))
+ (setq type (pop *loop-tokens*) supplied-p t))
+ (values type supplied-p)))
+
+
+(defun car-type (d-type-spec)
+ (if (consp d-type-spec) (car d-type-spec) d-type-spec))
+(defun cdr-type (d-type-spec)
+ (if (consp d-type-spec) (cdr d-type-spec) d-type-spec))
+(defun default-value (type)
+ (cond
+ ((subtypep type 'bignum) (1+ most-positive-fixnum))
+ ((subtypep type 'integer) 0)
+ ((subtypep type 'ratio) 1/10)
+ ((subtypep type 'float) 0.0)
+ ((subtypep type 'number) 0)
+ ((subtypep type 'character) #\Space)
+ ((subtypep type 'string) "")
+ ((subtypep type 'bit-vector) #*0)
+ ((subtypep type 'vector) #())
+ ((subtypep type 'package) *package*)
+ (t nil)))
+(defun default-type (type)
+ (if (eq type t)
+ t
+ (let ((value (default-value type)))
+ (if (typep value type)
+ type
+ (let ((default-type (type-of value)))
+ (if (subtypep type default-type)
+ default-type
+ (if (null value)
+ `(or null ,type)
+ `(or ,default-type ,type))))))))
+
+(defun default-binding (type var)
+ `(,(default-type type) ,var ,(default-value type)))
+
+(defvar *temporaries* nil
+ "Temporary variables used in with-clauses and for-as-clauses.")
+
+(defvar *ignorable* nil
+ "Ignorable temporary variables in *temporaries*.")
+
+(defun constant-bindings (d-type-spec d-var-spec value)
+ (let ((bindings nil))
+ (labels ((dig (type var value)
+ (cond
+ ((null var) nil) ;; do nothing
+ ((simple-var-p var) (appendf bindings `((,type ,var ',value))))
+ (t (dig (car-type type) (car var) (car value))
+ (dig (cdr-type type) (cdr var) (cdr value))))))
+ (dig d-type-spec d-var-spec value)
+ bindings)))
+
+(defun default-bindings (d-type-spec d-var-spec)
+ (let ((bindings nil))
+ (labels ((dig (type var)
+ (cond
+ ((null var) nil) ;; do nothing
+ ((simple-var-p var)
+ (appendf bindings `(,(default-binding type var))))
+ (t (dig (car-type type) (car var))
+ (dig (cdr-type type) (cdr var))))))
+ (dig d-type-spec d-var-spec)
+ bindings)))
+
+(defun ordinary-bindings (d-type-spec d-var-spec value-form)
+ (let ((temporaries *temporaries*)
+ (bindings nil))
+ (labels
+ ((dig (type var form temp)
+ ;; a TEMP moves horizontally, or cdr-wise, on an FORM.
+ ;; a TEMP can be reused by pushing it back onto TEMPORARIES.
+ (cond
+ ((empty-p var) nil)
+ ((simple-var-p var)
+ (when temp (push temp temporaries))
+ (appendf bindings `((,type ,var ,form))))
+ ((empty-p (car var))
+ (dig (cdr-type type) (cdr var) `(cdr ,form) temp))
+ ((empty-p (cdr var))
+ (when temp (push temp temporaries))
+ (dig (car-type type) (car var) `(car ,form) nil))
+ (t (unless temp (setq temp (or (pop temporaries) (gensym))))
+ (dig (car-type type) (car var) `(car (setq ,temp ,form)) nil)
+ (dig (cdr-type type) (cdr var) `(cdr ,temp) temp)))))
+ (dig d-type-spec d-var-spec value-form nil)
+ (setq *temporaries* temporaries)
+ bindings)))
+
+(defun quoted-form-p (form)
+ (let ((expansion (macroexpand form *environment*)))
+ (and (consp expansion) (eq (first expansion) 'quote))))
+
+(defun quoted-object (form)
+ (let ((expansion (macroexpand form *environment*)))
+ (destructuring-bind (quote-special-operator object) expansion
+ (assert (eq quote-special-operator 'quote))
+ object)))
+
+(defun bindings (d-type-spec d-var-spec
+ &optional (value-form "NEVER USED" value-form-p))
+ (cond
+ ((null value-form-p) (default-bindings d-type-spec d-var-spec))
+ ((quoted-form-p value-form) (constant-bindings d-type-spec d-var-spec
+ (quoted-object value-form)))
+ (t (ordinary-bindings d-type-spec d-var-spec value-form))))
+
+(defun fill-in (&rest args)
+ (when args
+ (appendf (getf *loop-components* (first args)) (second args))
+ (apply #'fill-in (cddr args))))
+
+(defun declarations (bindings)
+ (let ((declarations (mapcan #'(lambda (binding)
+ (destructuring-bind (type var . rest) binding
+ (declare (ignore rest))
+ (unless (eq type 't) `((type ,type ,var)))))
+ bindings)))
+ (when declarations `((declare ,@declarations)))))
+
+(defun let-form (bindings) `(let ,(mapcar #'cdr bindings) ,@(declarations bindings)))
+
+(defun with (var &optional (type t) &key (= (default-value type)))
+ (fill-in :binding-forms `(,(let-form `((,type ,var ,=))))))
+
+(defun multiple-value-list-form-p (form)
+ (let (expanded-p)
+ (loop
+ (when (and (consp form) (eq (first form) 'multiple-value-list))
+ (return t))
+ (multiple-value-setq (form expanded-p) (macroexpand-1 form *environment*))
+ (unless expanded-p (return nil)))))
+
+(defun multiple-value-list-argument-form (form)
+ (let ((expansion form)
+ (expanded-p nil))
+ (loop
+ (when (and (consp expansion) (eq (first expansion) 'multiple-value-list))
+ (return (second expansion)))
+ (multiple-value-setq (expansion expanded-p)
+ (macroexpand-1 expansion *environment*))
+ (unless expanded-p
+ (error "~S is not expanded into a multiple-value-list form." form)))))
+
+(defun destructuring-multiple-value-bind (d-type-spec d-var-spec value-form)
+ (let ((mv-bindings nil)
+ (d-bindings nil)
+ (padding-temps nil)
+ temp)
+ (do ((vars d-var-spec (cdr vars))
+ (types d-type-spec (cdr-type types)))
+ ((endp vars))
+ (if (listp (car vars))
+ (progn (setq temp (gensym))
+ (appendf mv-bindings `((t ,temp)))
+ (appendf d-bindings `((,(car-type types) ,(car vars) ,temp)))
+ (when (empty-p (car vars)) (push temp padding-temps)))
+ (appendf mv-bindings `((,(car-type types) ,(car vars))))))
+ (fill-in :binding-forms `((multiple-value-bind ,(mapcar #'second mv-bindings)
+ ,(multiple-value-list-argument-form value-form)
+ ,@(declarations mv-bindings)
+ ,@(when padding-temps
+ `((declare (ignore ,@padding-temps)))))))
+ (let ((bindings (mapappend #'(lambda (d-binding) (apply #'bindings d-binding))
+ d-bindings)))
+ (when bindings (fill-in :binding-forms `(,(let-form bindings)))))))
+
+(defun d-var-type-spec ()
+ (let ((var (d-var-spec1))
+ (type (type-spec?)))
+ (when (empty-p var)
+ (unless (member type '(nil t)) (loop-warn "Type spec ~S is ignored." type))
+ (setq var (gensym)
+ type t))
+ (values var type)))
+
+(defun with-clause ()
+ (let ((d-bindings nil))
+ (loop (multiple-value-bind (var type) (d-var-type-spec)
+ (let ((rest (when (preposition? :=) `(,(form1)))))
+ (appendf d-bindings `((,type ,var ,@rest)))))
+ (unless (preposition? :and) (return)))
+ (destructuring-bind (d-binding0 . rest) d-bindings
+ (if (and (null rest)
+ (cddr d-binding0)
+ (destructuring-bind (type var form) d-binding0
+ (declare (ignore type))
+ (and (consp var) (multiple-value-list-form-p form))))
+ (apply #'destructuring-multiple-value-bind d-binding0)
+ (let ((bindings (mapappend #'(lambda (d-binding)
+ (apply #'bindings d-binding))
+ d-bindings)))
+ (fill-in :binding-forms `(,(let-form bindings))))))))
+
+
+(defun dispatch-for-as-subclause (var type)
+ (unless *loop-tokens* (loop-error "A preposition is missing."))
+ (let ((preposition (preposition1 *for-as-prepositions*)))
+ (multiple-value-bind (subclause-function-designator present-p)
+ (gethash preposition *for-as-subclauses*)
+ (unless present-p
+ (loop-error "Unknown preposition ~S is supplied." preposition))
+ (push preposition *loop-tokens*)
+ (funcall subclause-function-designator var type))))
+
+(defun for (var type &rest rest)
+ (let ((*loop-tokens* rest))
+ (dispatch-for-as-subclause var type)))
+
+(defvar *for-as-components*)
+(defun for-as-fill-in (&rest key-list-pairs)
+ (when key-list-pairs
+ (destructuring-bind (key list . rest) key-list-pairs
+ (appendf (getf *for-as-components* key) list)
+ (apply #'for-as-fill-in rest))))
+
+(defvar *hash-group* '(:hash-key :hash-keys :hash-value :hash-values))
+(defvar *symbol-group* '(:symbol :symbols :present-symbol :present-symbols
+ :external-symbol :external-symbols))
+
+(defun loop-finish-test-forms (tests)
+ (case (length tests)
+ (0 nil)
+ (1 `((when ,@tests (loop-finish))))
+ (t `((when (or ,@tests) (loop-finish))))))
+
+(defun psetq-forms (args)
+ (assert (evenp (length args)))
+ (case (length args)
+ (0 nil)
+ (2 `((setq ,@args)))
+ (t `((psetq ,@args)))))
+
+(defun for-as-clause ()
+ (let ((*for-as-components* nil))
+ (loop (multiple-value-bind (var type) (d-var-type-spec)
+ (dispatch-for-as-subclause var type))
+ (unless (preposition? :and) (return)))
+ (destructuring-bind (&key bindings bindings2
+ before-head head-psetq head-tests after-head
+ before-tail tail-psetq tail-tests after-tail)
+ *for-as-components*
+ (fill-in :binding-forms `(,@(when bindings `(,(let-form bindings)))
+ ,@(when bindings2 `(,(let-form bindings2))))
+ :head `(,@before-head
+ ,@(psetq-forms head-psetq)
+ ,@(loop-finish-test-forms head-tests)
+ ,@after-head)
+ :tail `(,@before-tail
+ ,@(psetq-forms tail-psetq)
+ ,@(loop-finish-test-forms tail-tests)
+ ,@after-tail)))))
+
+(defun for-as-parallel-p ()
+ (or *for-as-components*
+ (and *loop-tokens*
+ (symbolp (car *loop-tokens*))
+ (string= (symbol-name (car *loop-tokens*)) "AND"))))
+
+(defun gensym-ignorable ()
+ (let ((var (gensym)))
+ (push var *ignorable*)
+ var))
+
+(defun destructuring-multiple-value-setq (d-var-spec value-form &key iterator-p)
+ (let (d-bindings mv-vars temp)
+ (do ((vars d-var-spec (cdr vars)))
+ ((endp vars))
+ (if (listp (car vars))
+ (progn (setq temp (or (pop *temporaries*) (gensym-ignorable)))
+ (appendf mv-vars `(,temp))
+ (appendf d-bindings `((t ,(car vars) ,temp))))
+ (appendf mv-vars `(,(car vars)))))
+ (let ((mv-setq-form `(multiple-value-setq ,mv-vars ,value-form))
+ (bindings nil))
+ (do ((d-bindings d-bindings (cdr d-bindings)))
+ ((endp d-bindings))
+ (destructuring-bind (type var temp) (car d-bindings)
+ (declare (ignore type var))
+ (push temp *temporaries*)
+ (appendf bindings (apply #'bindings (car d-bindings)))))
+ (when iterator-p (setq mv-setq-form `(unless ,mv-setq-form (loop-finish))))
+ (if bindings
+ `(progn ,mv-setq-form (setq ,@(mapappend #'cdr bindings)))
+ mv-setq-form))))
+
+(defun along-with (var type &key equals (then equals))
+ (for-as-fill-in :bindings (apply #'bindings type var (when (quoted-form-p equals)
+ `(,equals))))
+ (unless (quoted-form-p equals)
+ (for-as-fill-in :after-head
+ `((setq ,@(mapappend #'cdr (bindings type var equals))))))
+ (for-as-fill-in :after-tail
+ `((setq ,@(mapappend #'cdr (bindings type var then))))))
+
+(defun for-as-equals-then-subclause (var type)
+ ;; 6.1.1.4 Expanding Loop Forms
+ ;; http://www.lispworks.com/reference/HyperSpec/Body/06_aad.htm
+ ;; the form1 and form2 in a for-as-equals-then form includes the lexical
+ ;; environment of all the loop variables.
+ (preposition1 :=)
+ (let* ((first (form1))
+ (then (if (preposition? :then) (form1) first))
+ (parallel-p (for-as-parallel-p)))
+ (for-as-fill-in :bindings (apply #'bindings type var (when (quoted-form-p first)
+ `(,first))))
+ (if (and (not parallel-p) (consp var) (multiple-value-list-form-p first))
+ (for-as-fill-in :before-head
+ `(,(destructuring-multiple-value-setq var
+ (multiple-value-list-argument-form first))))
+ (unless (quoted-form-p first)
+ (for-as-fill-in :head-psetq (mapappend #'cdr (bindings type var first)))))
+ (if (and (not parallel-p) (consp var) (multiple-value-list-form-p then))
+ (for-as-fill-in :before-tail
+ `(,(destructuring-multiple-value-setq var
+ (multiple-value-list-argument-form then))))
+ (for-as-fill-in :tail-psetq (mapappend #'cdr (bindings type var then))))))
+
+
+(defun for-as-arithmetic-step-and-test-functions (used-prepositions)
+ (let ((up-p (subsetp used-prepositions '(:below :upto :upfrom :from :to :by))))
+ (values (if up-p '+ '-)
+ (cond ((member :to used-prepositions) (if up-p '> '<))
+ ((member :upto used-prepositions) '>)
+ ((member :below used-prepositions) '>=)
+ ((member :downto used-prepositions) '<)
+ ((member :above used-prepositions) '<=)
+ (t nil)))))
+
+(defun zero (type)
+ (cond
+ ((subtypep type 'short-float) 0.0s0)
+ ((subtypep type 'single-float) 0.0f0)
+ ((subtypep type 'double-float) 0.0d0)
+ ((subtypep type 'long-float) 0.0l0)
+ ((subtypep type 'float) 0.0)
+ (t 0)))
+
+(defun one (type)
+ (cond
+ ((subtypep type 'short-float) 1.0s0)
+ ((subtypep type 'single-float) 1.0f0)
+ ((subtypep type 'double-float) 1.0d0)
+ ((subtypep type 'long-float) 1.0l0)
+ ((subtypep type 'float) 1.0)
+ (t 1)))
+
+(defun for-as-arithmetic-possible-prepositions (used-prepositions)
+ (append
+ (cond
+ ((intersection '(:from :downfrom :upfrom) used-prepositions) nil)
+ ((intersection '(:downto :above) used-prepositions) '(:from :downfrom))
+ ((intersection '(:upto :below) used-prepositions) '(:from :upfrom))
+ (t '(:from :downfrom :upfrom)))
+ (cond
+ ((intersection '(:to :downto :upto :below :above) used-prepositions) nil)
+ ((find :upfrom used-prepositions) '(:to :upto :below))
+ ((find :downfrom used-prepositions) '(:to :downto :above))
+ (t '(:to :downto :upto :below :above)))
+ (unless (find :by used-prepositions) '(:by))))
+
+(defun for-as-arithmetic-subclause (var type)
+ (unless (simple-var-p var) (loop-error "Destructuring on a number is invalid."))
+ (multiple-value-bind (subtype-p valid-p) (subtypep type 'real)
+ (when (and (not subtype-p) valid-p) (setq type 'real)))
+ (let (from to by preposition used candidates bindings)
+ (loop (setq candidates (or (for-as-arithmetic-possible-prepositions used)
+ (return)))
+ (push (or (setq preposition (preposition? candidates)) (return))
+ used)
+ (let ((value-form (form1)))
+ (if (member preposition '(:from :downfrom :upfrom))
+ (progn (setq from value-form)
+ (appendf bindings `((,type ,var ,from))))
+ (progn (when (not (constantp value-form *environment*))
+ (let ((temp (gensym)))
+ (appendf bindings `((number ,temp ,value-form)))
+ (setq value-form temp)))
+ (ecase preposition
+ ((:to :downto :upto :below :above) (setq to value-form))
+ (:by (setq by value-form)))))))
+ (unless (intersection used '(:from :downfrom :upfrom))
+ (appendf bindings `((,type ,var ,(zero type)))))
+ (multiple-value-bind (step test) (for-as-arithmetic-step-and-test-functions used)
+ (let ((tests (when test `((,test ,var ,to)))))
+ (for-as-fill-in :bindings bindings
+ :head-tests tests
+ :tail-psetq `(,var (,step ,var ,(or by (one type))))
+ :tail-tests tests)))))
+
+
+(defun cl-external-p (symbol)
+ (multiple-value-bind (cl-symbol status)
+ (find-symbol (symbol-name symbol) "CL")
+ (and (eq symbol cl-symbol) (eq status :external))))
+
+(defun constant-function-p (form)
+ (let ((expansion (macroexpand form *environment*)))
+ (and (consp expansion)
+ (eq (first expansion) 'function)
+ (symbolp (second expansion))
+ (let ((symbol (second expansion)))
+ (and (cl-external-p symbol) (fboundp symbol))))))
+
+(defvar *list-end-test* 'atom)
+(defun by-step-fun () (if (preposition? :by) (form1) '#'cdr))
+
+(defun for-as-on-list-subclause (var type)
+ (preposition1 :on)
+ ;; Check with atom. See 6.1.2.1.3 The for-as-on-list subclause.
+ ;; http://www.lispworks.com/reference/HyperSpec/Body/06_abac.htm
+ (let* ((form (form1))
+ (by-step-fun (by-step-fun))
+ (test *list-end-test*)
+ (list-var (if (simple-var-p var) var (gensym "LIST-")))
+ (list-type (if (simple-var-p var) type t))
+ (at-least-one-iteration-p (and (quoted-form-p form)
+ (not (funcall test (quoted-object form))))))
+ (for-as-fill-in :bindings `((,list-type ,list-var ,form)
+ ,@(unless (constant-function-p by-step-fun)
+ (let ((temp (gensym "STEPPER-")))
+ (prog1 `((t ,temp ,by-step-fun))
+ (setq by-step-fun temp)))))
+ :head-tests (unless at-least-one-iteration-p
+ `((,test ,list-var)))
+ :tail-psetq `(,list-var (funcall ,by-step-fun ,list-var))
+ :tail-tests `((,test ,list-var)))
+ (unless (simple-var-p var)
+ (along-with var type :equals (if at-least-one-iteration-p form list-var)
+ :then list-var))))
+
+(defun for-as-in-list-subclause (var type)
+ (preposition1 :in)
+ ;; Check with endp. See 6.1.2.1.2 The for-as-in-list subclause.
+ ;; http://www.lispworks.com/reference/HyperSpec/Body/06_abab.htm
+ (let ((*list-end-test* 'endp))
+ (for `(,var) `(,type) :on (form1) :by (by-step-fun))))
+
+(defun constant-vector-p (form) (or (quoted-form-p form) (vectorp form)))
+(defun constant-vector (form)
+ (cond
+ ((quoted-form-p form) (quoted-object form))
+ ((vectorp form) form)
+ (t (error "~S is not a vector form." form))))
+
+(defun for-as-across-subclause (var type)
+ (preposition1 :across)
+ (let* ((form (form1))
+ (vector (if (constant-vector-p form) form (gensym "VECTOR-")))
+ (length (if (constant-vector-p form)
+ (length (constant-vector form))
+ (gensym "LENGTH-")))
+ (i (gensym "INDEX-"))
+ (at-least-one-iteration-p (and (constant-vector-p form) (plusp length))))
+ (unless (constant-vector-p form)
+ (for-as-fill-in :bindings `((t ,vector ,form))
+ :bindings2 `((fixnum ,length (length ,vector)))))
+ (for-as-fill-in :bindings `((fixnum ,i 0))
+ :head-tests (unless at-least-one-iteration-p `((= ,i ,length)))
+ :tail-psetq `(,i (1+ ,i))
+ :tail-tests `((= ,i ,length)))
+ (along-with var type :equals (if at-least-one-iteration-p
+ `',(aref (constant-vector form) 0)
+ `(aref ,vector ,i))
+ :then `(aref ,vector ,i))))
+
+(defun using-other-var (kind)
+ (let ((using-phrase (when (preposition? :using) (pop *loop-tokens*)))
+ (other-key-name (if (find kind '(:hash-key :hash-keys))
+ "HASH-VALUE"
+ "HASH-KEY")))
+ (when using-phrase
+ (destructuring-bind (other-key other-var) using-phrase
+ (unless (string= other-key other-key-name)
+ (loop-error "Keyword ~A is missing." other-key-name))
+ other-var))))
+
+(defun hash-d-var-spec (returned-p var other-var kind)
+ (if (find kind '(:hash-key :hash-keys))
+ `(,returned-p ,var ,other-var)
+ `(,returned-p ,other-var ,var)))
+
+(defun for-as-hash-subclause (var type kind)
+ (let* ((hash-table (progn (preposition1 '(:in :of)) (form1)))
+ (other-var (using-other-var kind))
+ (for-as-parallel-p (for-as-parallel-p))
+ (returned-p (or (pop *temporaries*) (gensym-ignorable)))
+ (iterator (gensym))
+ narrow-typed-var narrow-type)
+ (when (and (simple-var-p var) (not (typep 'nil type)))
+ (setq narrow-typed-var var
+ narrow-type type)
+ (setq var (gensym)
+ type `(or null ,type))
+ (for-as-fill-in :bindings `(,(default-binding narrow-type narrow-typed-var))))
+ (flet ((iterator-form () `(with-hash-table-iterator (,iterator ,hash-table))))
+ (if for-as-parallel-p
+ (progn (unless (constantp hash-table *environment*)
+ (let ((temp (gensym "HASH-TABLE-")))
+ (for-as-fill-in :bindings `((t ,temp ,hash-table)))
+ (setq hash-table temp)))
+ (fill-in :iterator-forms `(,(iterator-form))))
+ (fill-in :binding-forms `(,(iterator-form)))))
+ (let* ((d-var-spec (hash-d-var-spec returned-p var other-var kind))
+ (d-mv-setq (destructuring-multiple-value-setq d-var-spec `(,iterator)
+ :iterator-p t))
+ (setters `(,d-mv-setq
+ ,@(when narrow-typed-var `((setq ,narrow-typed-var ,var))))))
+ (push returned-p *temporaries*)
+ (for-as-fill-in :bindings `(,@(bindings type var)
+ ,@(when other-var (bindings t other-var)))
+ :after-head setters
+ :after-tail setters))))
+
+
+
+(defun for-as-package-subclause (var type kind)
+ (let* ((package (if (preposition? '(:in :of)) (form1) '*package*))
+ (for-as-parallel-p (for-as-parallel-p))
+ (returned-p (or (pop *temporaries*) (gensym-ignorable)))
+ (iterator (gensym))
+ (kinds (ecase kind
+ ((:symbol :symbols) '(:internal :external :inherited))
+ ((:present-symbol :present-symbols) '(:internal :external))
+ ((:external-symbol :external-symbols) '(:external)))))
+ (unless (typep 'nil type) (setq type `(or null ,type)))
+ (flet ((iterator-form () `(with-package-iterator (,iterator ,package ,@kinds))))
+ (if for-as-parallel-p
+ (progn (unless (constantp package *environment*)
+ (let ((temp (gensym "PACKAGE-")))
+ (for-as-fill-in :bindings `((t ,temp ,package)))
+ (setq package temp)))
+ (fill-in :iterator-forms `(,(iterator-form))))
+ (fill-in :binding-forms `(,(iterator-form)))))
+ (let* ((d-var-spec `(,returned-p ,var))
+ (d-mv-setq (destructuring-multiple-value-setq d-var-spec `(,iterator)
+ :iterator-p t)))
+ (push returned-p *temporaries*)
+ (for-as-fill-in :bindings (bindings type var)
+ :after-head `(,d-mv-setq)
+ :after-tail `(,d-mv-setq)))))
+
+(defun for-as-being-subclause (var type)
+ (preposition1 :being)
+ (preposition1 '(:each :the))
+ (let* ((kind (preposition1 (append *hash-group* *symbol-group*))))
+ (cond
+ ((find kind *hash-group*) (for-as-hash-subclause var type kind))
+ ((find kind *symbol-group*) (for-as-package-subclause var type kind))
+ (t (loop-error "Internal logic error")))))
+
+(defun form-or-it ()
+ (if (and *it-visible-p* (preposition? :it))
+ (or *it-symbol* (setq *it-symbol* (gensym)))
+ (form1)))
+
+(defun enumerate (items)
+ (case (length items)
+ (1 (format nil "~S" (first items)))
+ (2 (format nil "~S and ~S" (first items) (second items)))
+ (t (format nil "~{~S, ~}and ~S" (butlast items) (first (last items))))))
+
+(defun invalid-accumulator-combination-error (keys)
+ (loop-error "Accumulator ~S cannot be mixed with ~S."
+ *current-keyword* (enumerate keys)))
+
+(defun accumulator-kind (key)
+ (ecase key
+ ((:collect :collecting :append :appending :nconc :nconcing) :list)
+ ((:sum :summing :count :counting) :total)
+ ((:maximize :maximizing :minimize :minimizing) :limit)))
+
+(defun accumulator-spec (name)
+ (let* ((kind (accumulator-kind *current-keyword*))
+ (spec (assoc name *accumulators*))
+ (plist (cdr spec)))
+ (if spec
+ (if (not (eq kind (getf plist :kind)))
+ (invalid-accumulator-combination-error (reverse (getf plist :keys)))
+ (progn
+ (pushnew *current-keyword* (getf plist :keys))
+ (when (member kind '(:total :limit))
+ (multiple-value-bind (type supplied-p) (type-spec?)
+ (when supplied-p (push type (getf plist :types)))))))
+ (let ((var (or name (gensym "ACCUMULATOR-"))))
+ (setq plist `(:var ,var :kind ,kind :keys (,*current-keyword*)))
+ (ecase kind
+ (:list (setf (getf plist :splice) (gensym "SPLICE-"))
+ (unless name (fill-in :results `((cdr ,var)))))
+ ((:total :limit)
+ (multiple-value-bind (type supplied-p) (type-spec?)
+ (when supplied-p (push type (getf plist :types))))
+ (when (eq kind :limit)
+ (let ((first-p (gensym "FIRST-P-")))
+ (setf (getf plist :first-p) first-p)
+ (with first-p t := t)))
+ (unless name (fill-in :results `(,var)))))
+ (push (setq spec `(,name ,@plist)) *accumulators*)))
+ spec))
+
+(defun ambiguous-loop-result-error ()
+ (error 'simple-program-error
+ :format-control
+ (append-context "~S cannot be used without `into' preposition with ~S")
+ :format-arguments `(,*anonymous-accumulator* ,*boolean-terminator*)))
+
+(defun accumulate-in-list (form accumulator-spec)
+ (destructuring-bind (name &key var splice &allow-other-keys) accumulator-spec
+ (declare (ignore name))
+ (let* ((copy-f (ecase *current-keyword*
+ ((:collect :collecting) 'list)
+ ((:append :appending) 'copy-list)
+ ((:nconc :nconcing) 'identity)))
+ (collecting-p (member *current-keyword* '(:collect :collecting)))
+ (last-f (if collecting-p 'cdr 'last))
+ (splicing-form (if collecting-p
+ `(rplacd ,splice (setq ,splice (list ,form)))
+ `(setf (cdr ,splice) (,copy-f ,form)
+ ,splice (,last-f ,splice)))))
+ (if (globally-special-p var)
+ (lp :do `(if ,splice
+ ,splicing-form
+ (setq ,splice (,last-f (setq ,var (,copy-f ,form))))))
+ (lp :do splicing-form)))))
+
+(defun accumulation-clause ()
+ (let* ((form (form-or-it))
+ (name (if (preposition? :into)
+ (simple-var1)
+ (progn
+ (setq *anonymous-accumulator* *current-keyword*)
+ (when *boolean-terminator* (ambiguous-loop-result-error))
+ nil)))
+ (accumulator-spec (accumulator-spec name)))
+ (destructuring-bind (name &rest plist &key var &allow-other-keys)
+ accumulator-spec
+ (declare (ignore name))
+ (ecase *current-keyword*
+ ((:collect :collecting :append :appending :nconc :nconcing)
+ (accumulate-in-list form accumulator-spec))
+ ((:count :counting) (lp :if form :do `(incf ,var)))
+ ((:sum :summing) (lp :do `(incf ,var ,form)))
+ ((:maximize :maximizing :minimize :minimizing)
+ (let ((first-p (getf plist :first-p))
+ (fun (if (member *current-keyword* '(:maximize :maximizing)) '< '>)))
+ (lp :do `(let ((value ,form))
+ (cond
+ (,first-p (setq ,first-p nil ,var value))
+ ((,fun ,var value) (setq ,var value)))))))))))
+
+(defun return-clause () (lp :do `(return-from ,*loop-name* ,(form-or-it))))
+
+
+(defun do-clause () (fill-in :body (compound-forms+)))
+
+(defun selectable-clause ()
+ (let ((*current-keyword* *current-keyword*)
+ (*current-clause* *current-clause*))
+ (unless (keyword? '(:if :when :unless :do :doing :return :collect :collecting
+ :append :appending :nconc :nconcing :count :counting
+ :sum :summing :maximize :maximizing :minimize :minimizing))
+ (loop-error "A selectable-clause is missing."))
+ (ecase *current-keyword*
+ ((:if :when :unless) (conditional-clause))
+ ((:do :doing) (do-clause))
+ ((:return) (return-clause))
+ ((:collect :collecting :append :appending :nconc :nconcing :count :counting
+ :sum :summing :maximize :maximizing :minimize :minimizing)
+ (accumulation-clause)))))
+
+(defun conditional-clause ()
+ (let* ((*it-symbol* nil)
+ (middle (gensym "MIDDLE-"))
+ (bottom (gensym "BOTTOM-"))
+ (test-form (if (eq *current-keyword* :unless) `(not ,(form1)) (form1)))
+ (condition-form `(unless ,test-form (go ,middle))))
+ ;; condition-form is destructively modified in the following code for IT.
+ (lp :do condition-form)
+ (let ((*it-visible-p* t)) (selectable-clause))
+ (loop (unless (preposition? :and) (return)) (selectable-clause))
+ (cond
+ ((preposition? :else)
+ (lp :do `(go ,bottom))
+ (fill-in :body `(,middle))
+ (let ((*it-visible-p* t)) (selectable-clause))
+ (loop (unless (preposition? :and) (return)) (selectable-clause))
+ (fill-in :body `(,bottom)))
+ (t (fill-in :body `(,middle))))
+ (preposition? :end)
+ (when *it-symbol*
+ (with *it-symbol*)
+ (setf (second condition-form)
+ `(setq ,*it-symbol* ,(second condition-form))))))
+
+(defun initially-clause () (fill-in :initially (compound-forms+)))
+(defun finally-clause () (fill-in :finally (compound-forms+)))
+(defun while-clause () (lp :unless (form1) :do '(loop-finish) :end))
+(defun until-clause () (lp :while `(not ,(form1))))
+(defun repeat-clause ()
+ (let* ((form (form1))
+ (type (typecase (if (quoted-form-p form) (quoted-object form) form)
+ (fixnum 'fixnum)
+ (t 'real))))
+ (lp :for (gensym) :of-type type :downfrom form :to 1)))
+(defun always-never-thereis-clause ()
+ (setq *boolean-terminator* *current-keyword*)
+ (when *anonymous-accumulator* (ambiguous-loop-result-error))
+ (ecase *current-keyword*
+ (:always (lp :unless (form1) :return nil :end) (fill-in :results '(t)))
+ (:never (lp :always `(not ,(form1))))
+ (:thereis (lp :if (form1) :return :it :end) (fill-in :results '(nil)))))
+
+(defun variable-clause* ()
+ (loop (let ((key (keyword? '(:with :initially :finally :for :as))))
+ (if key (clause1) (return)))))
+
+(defun main-clause* ()
+ (loop
+ (if (keyword? '(:do :doing :return :if :when :unless :initially :finally
+ :while :until :repeat :always :never :thereis
+ :collect :collecting :append :appending :nconc :nconcing
+ :count :counting :sum :summing :maximize :maximizing
+ :minimize :minimizing))
+ (clause1)
+ (return))))
+
+(defun name-clause? ()
+ (when (keyword? :named)
+ (unless *loop-tokens* (loop-error "A loop name is missing."))
+ (let ((name (pop *loop-tokens*)))
+ (unless (symbolp name)
+ (loop-error "~S cannot be a loop name which must be a symbol." name))
+ (setq *loop-name* name))))
+
+(defun bound-variables (binding-form)
+ (let ((operator (first binding-form))
+ (second (second binding-form)))
+ (ecase operator
+ ((let let* symbol-macrolet) (mapcar #'first second))
+ ((multiple-value-bind) second)
+ ((with-package-iterator with-hash-table-iterator) `(,(first second))))))
+
+(defun check-multiple-bindings (variables)
+ (mapl #'(lambda (vars)
+ (when (member (first vars) (rest vars))
+ (loop-error 'simple-program-error
+ :format-control "Variable ~S is bound more than once."
+ :format-arguments (list (first vars)))))
+ variables))
+
+
+(defmacro with-loop-context (tokens &body body)
+ `(let ((*loop-tokens* ,tokens)
+ (*loop-name* nil)
+ (*current-keyword* nil)
+ (*current-clause* nil)
+ (*loop-components* nil)
+ (*temporaries* nil)
+ (*ignorable* nil)
+ (*accumulators* nil)
+ (*anonymous-accumulator* nil)
+ (*boolean-terminator* nil)
+ (*message-prefix* "LOOP: "))
+ ,@body))
+
+(defun with-iterator-forms (iterator-forms form)
+ (if (null iterator-forms)
+ form
+ (destructuring-bind ((iterator-macro spec) . rest) iterator-forms
+ `(,iterator-macro ,spec
+ ,(with-iterator-forms rest form)))))
+
+(defun with-binding-forms (binding-forms form)
+ (if (null binding-forms)
+ form
+ (destructuring-bind (binding-form0 . rest) binding-forms
+ (append binding-form0 (list (with-binding-forms rest form))))))
+
+(defun with-temporaries (temporary-specs form)
+ (destructuring-bind (temporaries &key ignorable) temporary-specs
+ (if temporaries
+ `(let ,temporaries
+ ,@(when ignorable `((declare (ignorable ,@ignorable))))
+ ,form)
+ form)))
+
+(defun with-list-accumulator (accumulator-spec form)
+ (destructuring-bind (name &key var splice &allow-other-keys) accumulator-spec
+ (let* ((anonymous-p (null name))
+ (list-var (if (or anonymous-p (globally-special-p var))
+ var
+ (gensym "LIST-")))
+ (value-form (if (and (not anonymous-p) (globally-special-p var))
+ nil
+ '(list nil)))
+ (form (if (and (not anonymous-p) (not (globally-special-p var)))
+ `(symbol-macrolet ((,var (cdr ,list-var)))
+ ,form)
+ form)))
+ `(let ((,list-var ,value-form))
+ ;;(declare (dynamic-extent ,list-var))
+ (declare (type list ,list-var))
+ (let ((,splice ,list-var))
+ (declare (type list ,splice))
+ ,form)))))
+
+(defun with-numeric-accumulator (accumulator-spec form)
+ (destructuring-bind (name &key var types &allow-other-keys) accumulator-spec
+ (labels ((type-eq (a b) (and (subtypep a b) (subtypep b a))))
+ (when (null types) (setq types '(number)))
+ (destructuring-bind (type0 . rest) types
+ (when (and rest (notevery #'(lambda (type) (type-eq type0 type)) types))
+ (warn "Different types ~A are declared for ~A accumulator."
+ (enumerate types) (or name "the anonymous")))
+ (let ((type (if rest `(or ,type0 ,@rest) type0)))
+ `(let ((,var ,(zero type)))
+ (declare (type ,type ,var))
+ ,form))))))
+
+(defun with-accumulators (accumulator-specs form)
+ (if (null accumulator-specs)
+ form
+ (destructuring-bind (spec . rest) accumulator-specs
+ (ecase (getf (cdr spec) :kind)
+ (:list
+ (with-list-accumulator spec (with-accumulators rest form)))
+ ((:total :limit)
+ (with-numeric-accumulator spec (with-accumulators rest form)))))))
+
+(defun reduce-redundant-code ()
+ (when (null (getf *loop-components* :initially))
+ (let ((rhead (reverse (getf *loop-components* :head)))
+ (rtail (reverse (getf *loop-components* :tail)))
+ (neck nil))
+ (loop
+ (when (or (null rhead) (null rtail) (not (equal (car rhead) (car rtail))))
+ (return))
+ (push (pop rhead) neck)
+ (pop rtail))
+ (setf (getf *loop-components* :head) (nreverse rhead)
+ (getf *loop-components* :neck) neck
+ (getf *loop-components* :tail) (nreverse rtail)))))
+
+(defmacro extended-loop (&rest tokens &environment environment)
+ (let ((*environment* environment))
+ (with-loop-context tokens
+ (let ((body-tag (gensym "LOOP-BODY-"))
+ (epilogue-tag (gensym "LOOP-EPILOGUE-")))
+ (name-clause?)
+ (variable-clause*)
+ (main-clause*)
+ (when *loop-tokens*
+ (error "Loop form tail ~S remained unprocessed." *loop-tokens*))
+ (reduce-redundant-code)
+ (destructuring-bind (&key binding-forms iterator-forms initially
+ head neck body tail finally results)
+ *loop-components*
+ (check-multiple-bindings
+ (append *temporaries* (mapappend #'bound-variables binding-forms)
+ (mapcar #'(lambda (spec) (getf (cdr spec) :var)) *accumulators*)))
+ `(block ,*loop-name*
+ ,(with-temporaries `(,*temporaries* :ignorable ,*ignorable*)
+ (with-accumulators *accumulators*
+ (with-binding-forms binding-forms
+ (with-iterator-forms iterator-forms
+ `(macrolet ((loop-finish () '(go ,epilogue-tag)))
+ (tagbody
+ ,@head
+ ,@initially
+ ,body-tag
+ ,@neck
+ ,@body
+ ,@tail
+ (go ,body-tag)
+ ,epilogue-tag
+ ,@finally
+ ,@(when results
+ `((return-from ,*loop-name* ,(car results))))))))))))))))
+
+(defmacro simple-loop (&rest compound-forms)
+ (let ((top (gensym)))
+ `(block nil
+ (tagbody
+ ,top
+ ,@compound-forms
+ (go ,top)))))
+
+(defmacro loop (&rest forms)
+ (if (every #'consp forms)
+ `(simple-loop ,@forms)
+ `(extended-loop ,@forms)))
+
+
diff --git a/Sacla/package.lisp b/Sacla/package.lisp
new file mode 100644
index 0000000..09e4efc
--- /dev/null
+++ b/Sacla/package.lisp
@@ -0,0 +1,633 @@
+;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
+;; ALL RIGHTS RESERVED.
+;;
+;; $Id: package.lisp,v 1.21 2004/09/02 06:59:43 yuji Exp $
+;;
+;; 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.
+;;
+;; 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.
+
+(defstruct (package
+ (:constructor %make-package)
+ (:print-object print-package)
+ (:predicate packagep))
+ ""
+ (%name nil :type (or string null))
+ (%nicknames nil :type list)
+ (%shadowing-symbols nil :type list)
+ (%use-list nil :type list)
+ (%used-by-list nil :type list)
+ (internal-symbols (make-hash-table :test 'equal) :type hash-table)
+ (external-symbols (make-hash-table :test 'equal) :type hash-table))
+
+(defun print-package (package stream)
+ (format stream "#<~A package (sumire)>" (package-%name package)))
+
+(defvar *keyword-package* (%make-package :%name "KEYWORD" :%nicknames '())
+ "")
+
+(defvar *cl-package* (%make-package :%name "COMMON-LISP" :%nicknames (list "CL"))
+ "")
+
+(defvar *cl-user-package*
+ (%make-package :%name "COMMON-LISP-USER" :%nicknames (list "CL-USER")
+ :%use-list (list *cl-package*))
+ "")
+
+(setf (package-%used-by-list *cl-package*) (list *cl-user-package*))
+
+(defvar *package* *cl-user-package*
+ "The current package.")
+
+(defvar *all-packages* (list *cl-user-package* *cl-package* *keyword-package*)
+ "")
+
+(define-condition non-existent-package-name-error (package-error) ())
+
+(defun %package (designator)
+ (or (find-package designator)
+ (and (typep designator 'package-designator)
+ (error 'non-existent-package-name-error :package designator))
+ (error 'type-error :datum designator :expected-type 'package-designator)))
+
+(defun %package-list (designator)
+ (mapcar #'%package (%list designator)))
+
+(defmacro in-package (name)
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (setq *package* (%package ',name))))
+
+(defun list-all-packages ()
+ (copy-list *all-packages*))
+
+(defun find-registered-package (name)
+ (block this
+ (dolist (package *all-packages* nil)
+ (when (string= name (package-%name package))
+ (return-from this package))
+ (dolist (nickname (package-%nicknames package))
+ (when (string= name nickname)
+ (return-from this package))))))
+
+(defun find-package (name)
+ (if (packagep name)
+ name
+ (find-registered-package (string name))))
+
+(defun unuse-package (packages-to-unuse &optional (package *package*))
+ (let ((packages-to-unuse (%package-list packages-to-unuse))
+ (package (%package package)))
+ (dolist (unuse packages-to-unuse t)
+ (setf (package-%use-list package)
+ (remove unuse (package-%use-list package)))
+ (setf (package-%used-by-list unuse)
+ (remove package (package-%used-by-list unuse))))))
+
+(defun package-name (package)
+ (copy-seq (package-%name (%package package))))
+
+(defun package-nicknames (package)
+ (copy-list (package-%nicknames (%package package))))
+
+(defun package-shadowing-symbols (package)
+ (copy-list (package-%shadowing-symbols (%package package))))
+
+(defun package-use-list (package)
+ (copy-list (package-%use-list (%package package))))
+
+(defun package-used-by-list (package)
+ (copy-list (package-%used-by-list (%package package))))
+
+(define-condition package-name-error (simple-error)
+ ((name :type string :reader package-name-error-name :initarg :name))
+ (:report (lambda (condition stream)
+ (format stream "A package named ~S already exists."
+ (package-name-error-name condition)))))
+
+(defun rename-package (package new-name &optional new-nicknames)
+ (let* ((package (%package package))
+ (new-name (string new-name))
+ (new-nicknames (string-list new-nicknames)))
+ (dolist (name (cons new-name new-nicknames))
+ (let ((found (find-package name)))
+ (when (and found (not (eq package found)))
+ (error 'package-name-error :name name))))
+ (setf (package-%name package) new-name
+ (package-%nicknames package) new-nicknames)
+ package))
+
+(defun find-symbol (name &optional (package *package*))
+ (let ((name (string name))
+ (package (%package package)))
+ (multiple-value-bind (symbol registered-p)
+ (gethash name (package-external-symbols package))
+ (if registered-p
+ (values symbol :external)
+ (multiple-value-bind (symbol registered-p)
+ (gethash name (package-internal-symbols package))
+ (if registered-p
+ (values symbol :internal)
+ (dolist (used (package-use-list package) (values nil nil))
+ (multiple-value-bind (symbol registered-p)
+ (gethash name (package-external-symbols used))
+ (when registered-p
+ (return (values symbol :inherited)))))))))))
+
+(defun find-all-symbols (name)
+ (let ((name (string name))
+ (all-symbols nil))
+ (dolist (package (list-all-packages) (remove-duplicates all-symbols))
+ (multiple-value-bind (symbol status) (find-symbol name package)
+ (case status ((:internal :external) (push symbol all-symbols)))))))
+
+(defun accessible-symbol-p (symbol package)
+ (multiple-value-bind (symbol-found status)
+ (find-symbol (symbol-name symbol) package)
+ (and (eq symbol symbol-found) status)))
+
+(defun present-symbol-p (symbol package)
+ (multiple-value-bind (symbol-found status)
+ (find-symbol (symbol-name symbol) package)
+ (and (eq symbol-found symbol) (find status '(:internal :external)))))
+
+(define-condition unintern-would-reveal-name-conflict-error (package-error)
+ ((symbol :type symbol :reader unintern-error-symbol :initarg :symbol)))
+
+(defun unintern (symbol &optional (package *package*))
+ (flet ((conflicting-inherited-symbols (name package)
+ (let ((symbols nil))
+ (dolist (used-package (package-use-list package))
+ (multiple-value-bind (symbol-found foundp)
+ (gethash name (package-external-symbols used-package))
+ (when foundp
+ (pushnew symbol-found symbols))))
+ (if (cdr symbols) symbols nil))))
+ (let* ((name (symbol-name symbol))
+ (package (%package package))
+ (present-p (present-symbol-p symbol package)))
+ (when present-p
+ (when (member symbol (package-shadowing-symbols package))
+ (when (conflicting-inherited-symbols name package)
+ (error 'unintern-would-reveal-name-conflict-error
+ :symbol symbol :package package))
+ (setf (package-%shadowing-symbols package)
+ (remove symbol (package-%shadowing-symbols package))))
+ (remhash name (ecase present-p
+ (:internal (package-internal-symbols package))
+ (:external (package-external-symbols package))))
+ (when (eq (symbol-package symbol) package)
+ (setf (symbol-package symbol) nil))
+ t))))
+
+
+(defun shadowing-import (symbol-list-designator &optional (package *package*))
+ (let ((symbol-list (symbol-list symbol-list-designator))
+ (package (%package package)))
+ (dolist (symbol symbol-list t)
+ (let ((name (symbol-name symbol)))
+ (multiple-value-bind (symbol-found status) (find-symbol name package)
+ (let ((present-p (member status '(:internal :external))))
+ (when (and present-p (not (eq symbol symbol-found)))
+ (unintern symbol-found package))
+ (unless (and present-p (eq symbol symbol-found))
+ (setf (gethash name (package-internal-symbols package)) symbol))
+ (pushnew symbol (package-%shadowing-symbols package))))))))
+
+(define-condition import-would-cause-shadowing-error (package-error)
+ ((symbol :type symbol :reader import-error-symbol :initarg :symbol)))
+
+(defun import (symbol-list-designator &optional (package *package*))
+ (let ((symbol-list (symbol-list symbol-list-designator))
+ (package (%package package)))
+ (dolist (symbol symbol-list t)
+ (let ((name (symbol-name symbol)))
+ (multiple-value-bind (symbol-found status) (find-symbol name package)
+ (cond
+ ((and status (not (eq symbol symbol-found)))
+ (cerror "Import this symbol with shadowing-import."
+ 'import-would-cause-shadowing-error
+ :package package :symbol symbol)
+ (shadowing-import symbol package))
+ ((and (member status '(:internal :external))
+ (eq symbol symbol-found))
+ ;; The spec says `If the symbol is already present
+ ;; in the importing package, import has no effect.'
+ )
+ (t
+ (setf (gethash name (package-internal-symbols package)) symbol)
+ (when (null (symbol-package symbol))
+ (setf (symbol-package symbol) package)))))))))
+
+(define-condition use-package-would-cause-name-conflict-error (package-error)
+ ((names :type list :reader use-package-error-names :initarg :names)
+ (package-to-use :type package :reader use-package-error-package-to-use
+ :initarg :package-to-use)))
+
+(defun check-use-package-name-conflict (using-package package-to-use)
+ (let* ((conflicting-names nil)
+ (shadows (package-shadowing-symbols using-package))
+ (user-tables (cons (package-internal-symbols using-package)
+ (cons (package-external-symbols using-package)
+ (mapcar #'package-external-symbols
+ (package-use-list using-package)))))
+ (fat-user
+ (> (reduce #'+ user-tables :key #'hash-table-count)
+ (hash-table-count (package-external-symbols package-to-use))))
+ (tables (if fat-user
+ (list (package-external-symbols package-to-use))
+ user-tables))
+ (package (if fat-user using-package package-to-use)))
+ (mapc #'(lambda (table)
+ (maphash
+ #'(lambda (name symbol)
+ (multiple-value-bind (symbol-found status)
+ (find-symbol name package)
+ (when (and status
+ (not (eq symbol symbol-found))
+ (not (member name shadows :test #'string=)))
+ (push name conflicting-names))))
+ table))
+ tables)
+ (when conflicting-names
+ (restart-case (error 'use-package-would-cause-name-conflict-error
+ :names conflicting-names :package package
+ :package-to-use package-to-use)
+ (continue ()
+ :report "Shadowing-import the conflicting symbols."
+ (shadowing-import (mapcar #'(lambda (name)
+ (find-symbol name package-to-use))
+ conflicting-names)
+ package))))))
+
+(defun use-package (package-to-use-list &optional (package *package*))
+ (let ((package-to-use-list (%package-list package-to-use-list))
+ (package (%package package)))
+ (dolist (package-to-use package-to-use-list t)
+ (cond
+ ((member package-to-use (package-use-list package)))
+ ((eq package-to-use *keyword-package*)
+ (warn "The keyword package cannot be used by other packages."))
+ ((eq package-to-use package)
+ (warn "A package cannot use-package itself."))
+ (t (check-use-package-name-conflict package package-to-use)
+ (push package-to-use (package-%use-list package))
+ (push package (package-%used-by-list package-to-use)))))))
+
+(defun make-package (name &key nicknames use)
+ (let ((package
+ (%make-package
+ :%name (cond
+ ((not (find-package name)) (string name))
+ (t (cerror "Return the existing package."
+ 'package-name-error :name name)
+ (return-from make-package (find-package name))))
+ :%nicknames (mapcan
+ #'(lambda (nickname)
+ (cond
+ ((string= nickname name) nil)
+ ((find-package nickname)
+ (cerror "Don't use this nickname."
+ 'package-name-error :name nickname))
+ (t (list (string nickname)))))
+ nicknames))))
+ (use-package use package)
+ (pushnew package *all-packages*)
+ package))
+
+(define-condition non-accessible-symbol-error (package-error)
+ ((symbol :type symbol
+ :reader non-accessible-symbol-error-symbol :initarg :symbol)))
+(define-condition export-would-cause-conflict-in-user-package-error
+ (package-error)
+ ((symbol :type symbol :reader export-error-symbol :initarg :symbol)
+ (user-package :type package
+ :reader export-error-user-package :initarg :user-package)))
+
+(defun export (symbol-list-designator &optional (package *package*))
+ (let ((symbol-list (symbol-list symbol-list-designator))
+ (package (%package package))
+ status)
+ (dolist (symbol symbol-list t)
+ (loop until (setq status (accessible-symbol-p symbol package))
+ do
+ (cerror "Import this symbol." 'non-accessible-symbol-error
+ :package package :symbol symbol)
+ (import (list symbol) package))
+ (unless (eq status :external)
+ (let ((name (symbol-name symbol)))
+ (dolist (user (package-used-by-list package))
+ (loop
+ (multiple-value-bind (symbol-found status) (find-symbol name user)
+ (when (or (null status) (eq symbol symbol-found))
+ (return))
+ (cerror "Shadowing-import the symbol in the user package."
+ 'export-would-cause-conflict-in-user-package-error
+ :package package :user-package user :symbol symbol)
+ (shadowing-import (list symbol) user))))
+ (when (eq status :inherited)
+ (import (list symbol) package))
+ (remhash name (package-internal-symbols package))
+ (setf (gethash name (package-external-symbols package)) symbol))))))
+
+(defun unexport (symbol-list-designator &optional (package *package*))
+ (let ((symbol-list (symbol-list symbol-list-designator))
+ (package (%package package))
+ status)
+ (dolist (symbol symbol-list t)
+ (unless (setq status (accessible-symbol-p symbol package))
+ (cerror "Import this symbol." 'non-accessible-symbol-error
+ :package package :symbol symbol))
+ (when (eq status :external)
+ (remhash (symbol-name symbol) (package-external-symbols package))
+ (setf (gethash (symbol-name symbol) (package-internal-symbols package))
+ symbol)))))
+
+(defun intern (name &optional (package *package*))
+ (let ((name (string name))
+ (package (%package package)))
+ (multiple-value-bind (symbol status) (find-symbol name package)
+ (if status
+ (values symbol status)
+ (let ((symbol (make-symbol name)))
+ (import (list symbol) package)
+ (when (eq package *keyword-package*)
+ (export (list symbol) package)
+ (setf (symbol-value symbol) symbol))
+ (values symbol nil))))))
+
+(defun shadow (symbol-names &optional (package *package*))
+ (let ((symbol-names (string-list symbol-names))
+ (package (%package package)))
+ (dolist (name symbol-names t)
+ (multiple-value-bind (symbol status) (find-symbol name package)
+ (when (or (not status) (eq status :inherited))
+ (setq symbol (make-symbol name))
+ (setf (symbol-package symbol) package)
+ (setf (gethash name (package-internal-symbols package)) symbol))
+ (pushnew symbol (package-%shadowing-symbols package))))))
+
+(defun hash-table-values (table)
+ (let ((values nil))
+ (with-hash-table-iterator (get table)
+ (loop (multiple-value-bind (more k v) (get)
+ (declare (ignore k))
+ (unless more (return))
+ (push v values))))
+ values))
+
+(defun package-symbol-tables (package type)
+ (ecase type
+ (:internal (list (package-internal-symbols package)))
+ (:external (list (package-external-symbols package)))
+ (:inherited (mapcar #'package-external-symbols
+ (package-use-list package)))))
+
+(define-condition package-symbol-types-error (program-error)
+ ((types :reader symbol-types-error-types :initarg :types)))
+
+(defun shadowed-name-p (name package)
+ (member name (package-shadowing-symbols package) :test #'string=))
+
+(defun package-iterator (package &rest symbol-types)
+ (unless symbol-types (error 'package-symbol-types-error :types symbol-types))
+ (unless package (return-from package-iterator (constantly nil)))
+ (let* ((package-list (%package-list package))
+ (package (pop package-list))
+ (type (first symbol-types))
+ (type-list (rest symbol-types))
+ (iterator (hash-table-iterator (package-symbol-tables package type))))
+ #'(lambda ()
+ (loop
+ (multiple-value-bind (more name symbol) (funcall iterator)
+ (cond
+ (more
+ (unless (and (eq type :inherited) (shadowed-name-p name package))
+ (return (values more symbol type package))))
+ (t
+ (cond
+ (type-list (setq type (pop type-list)))
+ (package-list (setq type (first symbol-types)
+ type-list (rest symbol-types)
+ package (pop package-list)))
+ (t (return nil)))
+ (setq iterator
+ (hash-table-iterator (package-symbol-tables package
+ type))))))))))
+
+(defmacro with-package-iterator ((name package-list-form &rest symbol-types)
+ &body body)
+ (unless symbol-types (error 'package-symbol-types-error :types symbol-types))
+ (let ((iterator (gensym)))
+ `(let ((,iterator (package-iterator ,package-list-form ,@symbol-types)))
+ (macrolet ((,name () '(funcall ,iterator)))
+ ,@body))))
+
+(defmacro do-package-symbols ((var package result-form &rest type-list)
+ &body body)
+ (let ((get (gensym))
+ (more (gensym))
+ (type (gensym))
+ (pkg (gensym)))
+ (multiple-value-bind (declarations forms) (declarations-and-forms body)
+ `(with-package-iterator (,get ,package ,@type-list)
+ (loop
+ (multiple-value-bind (,more ,var ,type ,pkg) (,get)
+ (declare (ignore ,type ,pkg))
+ ,@declarations
+ (unless ,more (return ,result-form))
+ (tagbody
+ ,@forms)))))))
+
+(defmacro do-symbols ((var &optional (package-form '*package*)
+ result-form)
+ &body body)
+ (let ((package (gensym)))
+ `(let ((,package (%package ,package-form)))
+ (do-package-symbols (,var ,package ,result-form
+ :external :internal :inherited)
+ ,@body))))
+
+(defmacro do-external-symbols ((var &optional (package-form '*package*)
+ result-form)
+ &body body)
+ (let ((package (gensym)))
+ `(let ((,package (%package ,package-form)))
+ (do-package-symbols (,var ,package ,result-form :external)
+ ,@body))))
+
+(defmacro do-all-symbols ((var &optional result-form) &body body)
+ (let ((package (gensym))
+ (body-function (gensym)))
+ (multiple-value-bind (declarations forms) (declarations-and-forms body)
+ `(block nil
+ (flet ((,body-function (,var)
+ (declare (ignorable ,var))
+ ,@declarations
+ (tagbody ,@forms)))
+ (dolist (,package (list-all-packages) (let ((,var nil))
+ (declare (ignorable ,var))
+ ,@declarations
+ ,result-form))
+ (do-symbols (,var ,package nil)
+ (,body-function ,var))))))))
+
+(define-condition deleting-package-used-by-others-error (package-error)
+ ())
+
+(defun delete-package (package)
+ (let ((package (or (find-package package)
+ (return-from delete-package
+ (cerror "Return NIL." 'non-existent-package-name-error
+ :package package)))))
+ (when (package-name package)
+ (when (package-used-by-list package)
+ (cerror "Remove dependency in other packages."
+ 'deleting-package-used-by-others-error :package package)
+ (dolist (user (package-used-by-list package))
+ (unuse-package package user)))
+ (unuse-package (package-use-list package) package)
+ (do-symbols (symbol package)
+ (unintern symbol package))
+ (setf (package-%name package) nil)
+ (setq *all-packages* (remove package *all-packages*))
+ t)))
+
+(define-condition unsupported-defpackage-option-error (program-error)
+ ((option :reader unsupported-defpackage-option-error-option :initarg :option)))
+
+(define-condition non-accessible-symbol-name-error (package-error)
+ ((name :type string
+ :reader non-accessible-symbol-name-error-name :initarg :name)))
+
+(defun %accessible-symbols (name-list package)
+ (mapcar #'(lambda (name)
+ (loop
+ (multiple-value-bind (symbol status)
+ (find-symbol name package)
+ (when status
+ (return symbol))
+ (cerror "Intern this symbol." 'non-accessible-symbol-name-error
+ :package package :name name)
+ (intern (string name) package))))
+ name-list))
+
+(defun check-disjoint(&rest args)
+ ;; An arg is (:key . set)
+ (do ((list args (cdr list)))
+ ((endp list))
+ (loop
+ with x = (car list)
+ for y in (rest list)
+ for z = (remove-duplicates (intersection (cdr x)(cdr y) :test #'string=))
+ when z do (error 'program-error
+ :format-control "Parameters ~S and ~S must be disjoint ~
+ but have common elements ~% ~S"
+ :format-arguments (list (car x)(car y) z)))))
+
+(defmacro defpackage (package-name &rest options)
+ (let ((package-name (string package-name))
+ forms nicknames shadow shadowing-import-from use import-from intern
+ export documentation size)
+ (loop
+ for (key . values) in options
+ do
+ (case key
+ (:nicknames (setq nicknames (append nicknames values)))
+ (:documentation (setq documentation (first values)))
+ (:shadow (setq shadow (append shadow values)))
+ (:shadowing-import-from (push values shadowing-import-from))
+ (:use (setq use (append use values)))
+ (:import-from (push values import-from))
+ (:intern (setq intern (append intern values)))
+ (:export (setq export (append export values)))
+ (:size (setq size (first values)))
+ (t (error 'unsupported-defpackage-option :option (cons key values)))))
+ (check-disjoint `(:intern ,@intern)
+ `(:import-from ,@(apply #'append (mapcar #'rest
+ import-from)))
+ `(:shadow ,@shadow)
+ `(:shadowing-import-from
+ ,@(apply #'append (mapcar #'rest shadowing-import-from))))
+ (check-disjoint `(:intern ,@intern) `(:export ,@export))
+
+ (push `(let ((package (find-package ,package-name)))
+ (if package
+ (rename-package package
+ ,package-name (union ',(string-list nicknames)
+ (package-nicknames package)
+ :test #'string=))
+ (make-package ,package-name :nicknames ',nicknames :use nil)))
+ forms)
+ (when documentation
+ (push `(setf (documentation ,package-name 'package) ,documentation) forms))
+ (when shadow (push `(shadow ',(string-list shadow) ,package-name) forms))
+ (when shadowing-import-from
+ (loop for (from . names) in shadowing-import-from
+ do (push `(let ((names ',(string-list names)))
+ (shadowing-import (%accessible-symbols names ',from)
+ ,package-name))
+ forms)))
+ (when use (push `(use-package ',use ,package-name) forms))
+ (when import-from
+ (loop for (from . names) in import-from
+ do (push `(let ((names ',(string-list names)))
+ (import (%accessible-symbols names ',from) ,package-name))
+ forms)))
+ (when intern
+ (dolist (symbol intern)
+ (push `(intern ',symbol ,package-name) forms)))
+ (when export
+ (push `(export
+ (mapcar #'(lambda (name) (intern name ,package-name)) ',export)
+ ,package-name)
+ forms))
+ (push `(find-package ,package-name) forms)
+ `(eval-when (:load-toplevel :compile-toplevel :execute)
+ ,@(nreverse forms))))
+
+;;;
+(defun clone-package-system ()
+ (let ((src-list (mapcar #'cl:find-package
+ '("CL" "CL-USER" "KEYWORD" "TESTBED"))))
+ (dolist (src src-list)
+ (format t "Cloning the package ~S~%" src)
+ (let* ((name (cl:package-name src))
+ (nicknames (cl:package-nicknames src))
+ (dest (or (tb::find-package name)
+ (tb::make-package name :nicknames nicknames))))
+ (cl:with-package-iterator (get src :internal :external)
+ (loop
+ (multiple-value-bind (more symbol status package) (get)
+ (declare (ignore status package))
+ (unless more (return))
+ ;;(format t "shadowing symbols = ~S~%" (cl:package-shadowing-symbols src))
+ (if (member symbol (cl:package-shadowing-symbols src))
+ (shadowing-import (list symbol) dest)
+ (progn
+ ;;(format t "calling import~%")
+ (import (list symbol) dest)
+ ;;(format t "called import~%"
+ )))))
+ (cl:do-external-symbols (symbol src)
+ (export (list symbol) dest))))
+ (setq *package* (find-package (cl:package-name cl:*package*)))))
+
diff --git a/Sacla/printer.lisp b/Sacla/printer.lisp
new file mode 100644
index 0000000..fbdcf27
--- /dev/null
+++ b/Sacla/printer.lisp
@@ -0,0 +1,582 @@
+;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
+;; ALL RIGHTS RESERVED.
+;;
+;; $Id: printer.lisp,v 1.14 2004/03/01 05:18:11 yuji Exp $
+;;
+;; 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.
+;;
+;; 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.
+
+;;; Commentary:
+
+;; Need to load reader.lisp in advance for the function SYNTAX-TYPE.
+;;
+
+;;; printer control variables
+;; number
+(defvar *print-base* 10
+ "The radix in which the printer will print rationals.")
+(defvar *print-radix* nil
+ "If true, print a radix specifier when printing a rational number.")
+
+;; symbol
+(defvar *print-case* :upcase
+ "One of the symbols :upcase, :downcase, or :capitalize.")
+(defvar *print-gensym* t
+ "If true, print `#:' before apparently uninterned symbols.")
+
+;; container
+(defvar *print-array* t ; implementation-dependent
+ "If true, arrays are printed in readable #(...), #*, or #nA(...) syntax.")
+(defvar *print-level* nil
+ "Control how many levels deep a nested object will print.")
+(defvar *print-length* nil
+ "Control how many elements at a given level are printed.")
+(defvar *print-circle* nil
+ "If true, detect circularity and sharing in an object being printed.")
+
+;; symbol, string
+(defvar *print-escape* t
+ "If false, escape characters and package prefixes are not output.")
+
+;; readability
+;; *print-readably*
+;; true
+;; true: *print-escape*, *print-array*, and *print-gensym*
+;; false: *print-length*, *print-level*, and *print-lines*
+(defvar *print-readably* nil
+ "If true, print objects readably.")
+
+;; layout
+(defvar *print-pretty* t ; implementation-dependent
+ "If true, the pretty printer is used when printing.")
+;;(defvar *print-pprint-dispatch*
+;; )
+(defvar *print-lines* nil
+ "Limit on the number of output lines produced when pretty printing.")
+(defvar *print-miser-width* nil ; implementation-dependent
+ "Switch to a compact style of output whenever the width available for printing a substructure is less than or equal to this many ems when pretty printing.")
+(defvar *print-right-margin* nil
+ "Specify the right margin to use when the pretty printer is making layout decisions.")
+
+(defmacro with-standard-io-syntax (&rest forms)
+ "Bind all reader/printer control vars to the standard values then eval FORMS."
+ `(let ((*package* (find-package "CL-USER"))
+ (*print-array* t)
+ (*print-base* 10)
+ (*print-case* :upcase)
+ (*print-circle* nil)
+ (*print-escape* t)
+ (*print-gensym* t)
+ (*print-length* nil)
+ (*print-level* nil)
+ (*print-lines* nil)
+ (*print-miser-width* nil)
+ ;;(*print-pprint-dispatch* *standard-print-pprint-dispatch*)
+ (*print-pretty* nil)
+ (*print-radix* nil)
+ (*print-readably* t)
+ (*print-right-margin* nil)
+ (*read-base* 10)
+ (*read-default-float-format* 'single-float)
+ (*read-eval* t)
+ (*read-suppress* nil)
+ (*readtable* (copy-readtable nil)))
+ ,@forms))
+
+(defgeneric print-object (object stream))
+
+(defun write (object &key
+ ((:array *print-array*) *print-array*)
+ ((:base *print-base*) *print-base*)
+ ((:case *print-case*) *print-case*)
+ ((:circle *print-circle*) *print-circle*)
+ ((:escape *print-escape*) *print-escape*)
+ ((:gensym *print-gensym*) *print-gensym*)
+ ((:length *print-length*) *print-length*)
+ ((:level *print-level*) *print-level*)
+ ((:lines *print-lines*) *print-lines*)
+ ((:miser-width *print-miser-width*) *print-miser-width*)
+ ((:pprint-dispatch *print-pprint-dispatch*)
+ *print-pprint-dispatch*)
+ ((:pretty *print-pretty*) *print-pretty*)
+ ((:radix *print-radix*) *print-radix*)
+ ((:readably *print-readably*) *print-readably*)
+ ((:right-margin *print-right-margin*) *print-right-margin*)
+ (stream *standard-output*))
+ ;; http://www.lispworks.com/reference/HyperSpec/Body/22_ab.htm
+ ;; 22.1.2 Printer Dispatching
+ ;; The Lisp printer makes its determination of how to print an object as
+ ;; follows: If the value of *print-pretty* is true, printing is controlled
+ ;; by the current pprint dispatch table; see Section 22.2.1.4 (Pretty Print
+ ;; Dispatch Tables).
+ ;; Otherwise (if the value of *print-pretty* is false), the object's
+ ;; print-object method is used;
+ ;; see Section 22.1.3 (Default Print-Object Methods).
+ (if *print-pretty*
+ (print-object-prettily object stream)
+ (print-object object stream))
+ object)
+
+(defun write-to-string (object &key
+ ((:array *print-array*) *print-array*)
+ ((:base *print-base*) *print-base*)
+ ((:case *print-case*) *print-case*)
+ ((:circle *print-circle*) *print-circle*)
+ ((:escape *print-escape*) *print-escape*)
+ ((:gensym *print-gensym*) *print-gensym*)
+ ((:length *print-length*) *print-length*)
+ ((:level *print-level*) *print-level*)
+ ((:lines *print-lines*) *print-lines*)
+ ((:miser-width *print-miser-width*) *print-miser-width*)
+ ((:pprint-dispatch *print-pprint-dispatch*)
+ *print-pprint-dispatch*)
+ ((:pretty *print-pretty*) *print-pretty*)
+ ((:radix *print-radix*) *print-radix*)
+ ((:readably *print-readably*) *print-readably*)
+ ((:right-margin *print-right-margin*) *print-right-margin*))
+ (with-output-to-string (stream)
+ (if *print-pretty*
+ (print-object-prettily object stream)
+ (print-object object stream))))
+
+(defun prin1 (object &optional output-stream)
+ (write object :stream output-stream :escape t))
+
+(defun prin1-to-string (object) (write-to-string object :escape t))
+
+(defun princ (object &optional output-stream)
+ (write object :stream output-stream :escape nil :readably nil))
+
+(defun princ-to-string (object)
+ (write-to-string object :escape nil :readably nil))
+
+(defun print (object &optional output-stream)
+ (terpri output-stream)
+ (prin1 object output-stream)
+ (write-char #\Space output-stream)
+ object)
+
+(defun pprint (object &optional output-stream)
+ (terpri output-stream)
+ (write object :stream output-stream :pretty t :escape t)
+ (values))
+
+
+;; function pprint-dispatch
+;; macro pprint-logical-block
+;; local macro pprint-pop
+;; local macro pprint-exit-if-list-exhausted
+;; function pprint-newline
+;; function pprint-tab
+;; function pprint-fill, pprint-linear, pprint-tabular
+;; function pprint-indent
+
+(defun printer-escaping-enabled-p () (or *print-escape* *print-readably*))
+
+(defmethod print-object ((object integer) stream) (print-integer object stream))
+(defun print-integer (integer stream)
+ (let ((chars "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+ digits)
+ (loop with n = (abs integer)
+ do (multiple-value-bind (q r) (floor n *print-base*)
+ (push (char chars r) digits)
+ (setq n q))
+ until (zerop n))
+ (when *print-radix*
+ (case *print-base*
+ (2 (write-string "#b" stream))
+ (8 (write-string "#o" stream))
+ (16 (write-string "#x" stream))
+ (10 nil)
+ (t (write-char #\# stream)
+ (let ((base *print-base*)
+ (*print-base* 10)
+ (*print-radix* nil))
+ (print-integer base stream))
+ (write-char #\r stream))))
+ (write-string (concatenate 'string
+ (when (minusp integer) '(#\-))
+ digits
+ (when (and *print-radix* (= *print-base* 10))
+ "."))
+ stream)
+ integer))
+
+(defmethod print-object ((ratio ratio) stream)
+ ;; http://www.lispworks.com/reference/HyperSpec/Body/v_pr_bas.htm
+ ;; For integers, base ten is indicated by a trailing decimal point instead
+ ;; of a leading radix specifier; for ratios, #10r is used.
+ (if (and *print-radix* (= *print-base* 10))
+ (progn
+ (write-string "#10r" stream)
+ (let ((*print-radix* nil))
+ (print-integer (numerator ratio) stream)))
+ (print-integer (numerator ratio) stream))
+ (write-char #\/ stream)
+ (let ((*print-radix* nil)) (print-integer (denominator ratio) stream))
+ ratio)
+
+(defmethod print-object ((complex complex) stream)
+ (write-string "#C(" stream)
+ (print-object (realpart complex) stream)
+ (write-char #\Space stream)
+ (print-object (imagpart complex) stream)
+ (write-char #\))
+ complex)
+
+
+(defmethod print-object ((character character) stream)
+ (cond
+ ((printer-escaping-enabled-p)
+ (write-string "#\\" stream)
+ (if (and (graphic-char-p character) (not (char= character #\Space)))
+ (write-char character stream)
+ (write-string (char-name character) stream)))
+ (t (write-char character stream)))
+ character)
+
+(defun string-invert (str)
+ (cond
+ ((every #'(lambda (c) (or (not (alpha-char-p c)) (upper-case-p c))) str)
+ (map 'string #'char-downcase str))
+ ((every #'(lambda (c) (or (not (alpha-char-p c)) (lower-case-p c))) str)
+ (map 'string #'char-upcase str))
+ (t str)))
+
+(defun make-str (chars)
+ (make-array (length chars) :element-type 'character :initial-contents chars))
+
+(defun print-symbol-as-is (symbol stream)
+ (let ((name (symbol-name symbol)))
+ (ecase (readtable-case *readtable*)
+ (:upcase
+ (write-string
+ (ecase *print-case*
+ (:upcase name)
+ (:downcase (map 'string #'char-downcase name))
+ (:capitalize
+ (make-str (loop for c across name and prev = nil then c
+ collecting
+ (if (and (upper-case-p c) prev (alpha-char-p prev))
+ (char-downcase c)
+ c)))))
+ stream))
+ (:downcase
+ (write-string
+ (ecase *print-case*
+ (:upcase (map 'string #'char-upcase name))
+ (:downcase name)
+ (:capitalize
+ (make-str (loop for c across name and prev = nil then c
+ collecting
+ (if (and (lower-case-p c)
+ (or (null prev) (not (alpha-char-p prev))))
+ (char-upcase c)
+ c)))))
+ stream))
+ (:preserve (write-string name stream))
+ (:invert (write-string (string-invert name) stream)))
+ symbol))
+
+(defun print-name-escaping (name stream &key force-escaping)
+ (let ((readtable-case (readtable-case *readtable*)))
+ (if (or force-escaping
+ (loop with standard-table = (copy-readtable nil)
+ for c across name
+ thereis (not (and (eq (syntax-type c standard-table) :constituent)
+ (eq (syntax-type c) :constituent))))
+ (notevery #'graphic-char-p name)
+ (and (eq readtable-case :upcase) (some 'lower-case-p name))
+ (and (eq readtable-case :downcase) (some 'upper-case-p name)))
+ (let ((escaped (loop for c across name
+ if (find c '(#\\ #\|)) append (list #\\ c)
+ else collect c)))
+ (write-string (concatenate 'string "|" escaped "|") stream))
+ (write-string (case readtable-case
+ ((:upcase :downcase)
+ (ecase *print-case*
+ (:upcase (string-upcase name))
+ (:downcase (string-downcase name))
+ (:capitalize (string-capitalize name))))
+ (:invert
+ (cond
+ ((notany #'both-case-p name) name)
+ ((notany #'upper-case-p name) (string-upcase name))
+ ((notany #'lower-case-p name) (string-downcase name))
+ (t name)))
+ (t name))
+ stream))))
+
+(defun print-symbol-escaping (symbol stream)
+ (let* ((name (symbol-name symbol))
+ (accessible-p (eq symbol (find-symbol name))))
+ (cond
+ (accessible-p nil)
+ ((symbol-package symbol)
+ (let ((package-name (package-name (symbol-package symbol))))
+ (unless (string= package-name "KEYWORD")
+ (print-name-escaping package-name stream))
+ (multiple-value-bind (symbol status) (find-symbol name package-name)
+ (declare (ignore symbol))
+ (write-string (if (eq status :external) ":" "::") stream))))
+ ((or *print-readably* *print-gensym*) (write-string "#:" stream))
+ (t nil))
+ (print-name-escaping
+ name stream
+ :force-escaping (and accessible-p
+ (every #'(lambda (c) (digit-char-p c *print-base*))
+ name)))
+ symbol))
+
+(defmethod print-object ((symbol symbol) stream)
+ (funcall (if (printer-escaping-enabled-p)
+ #'print-symbol-escaping
+ #'print-symbol-as-is)
+ symbol
+ stream))
+
+
+(defvar *shared-object-table* (make-hash-table))
+(defvar *shared-object-label* (make-hash-table))
+(defvar *shared-object-label-counter* 0)
+(defvar *current-print-level* 0)
+
+(defun print-max-level-p ()
+ (and (not *print-readably*)
+ *print-level*
+ (= *current-print-level* *print-level*)))
+(defun print-max-length-p (n)
+ (and (not *print-readably*) *print-length* (= n *print-length*)))
+
+(defun inc-shared-object-reference (object)
+ (if (and (symbolp object) (symbol-package object))
+ 0
+ (multiple-value-bind (n present-p) (gethash object *shared-object-table*)
+ (if present-p
+ (progn (when (zerop n)
+ (setf (gethash object *shared-object-label*)
+ (incf *shared-object-label-counter*)))
+ (incf (gethash object *shared-object-table*)))
+ (setf (gethash object *shared-object-table*) 0)))))
+
+(defmethod search-shared-object :around ((object t))
+ (if (zerop *current-print-level*)
+ (progn (setq *shared-object-label* (clrhash *shared-object-label*)
+ *shared-object-table* (clrhash *shared-object-table*)
+ *shared-object-label-counter* 0)
+ (inc-shared-object-reference object)
+ (call-next-method object)
+ (maphash #'(lambda (object n)
+ (if (zerop n)
+ (remhash object *shared-object-table*)
+ (setf (gethash object *shared-object-table*)
+ 0)))
+ *shared-object-table*))
+ (when (zerop (inc-shared-object-reference object))
+ (call-next-method object))))
+
+(defun search-shared-element (object)
+ (let ((*current-print-level* (1+ *current-print-level*)))
+ (unless (print-max-level-p) (search-shared-object object))))
+
+(defmethod search-shared-object ((object t))) ; do nothing
+(defmethod search-shared-object ((list list))
+ (do ((x list)
+ (l 0 (1+ l)))
+ ((or (print-max-level-p) (print-max-length-p l) (atom x)))
+ (search-shared-element (car x))
+ (setq x (cdr x))
+ (when (plusp (inc-shared-object-reference x))
+ (return))))
+
+(defmethod search-shared-object ((vector vector))
+ (do ((i 0 (1+ i)))
+ ((or (= i (length vector)) (print-max-level-p) (print-max-length-p i)))
+ (search-shared-element (aref vector i))))
+
+(defmethod search-shared-object ((array array))
+ (do ((i 0 (1+ i)))
+ ((or (= i (array-total-size array))
+ (print-max-level-p) (print-max-length-p i)))
+ (search-shared-element (row-major-aref array i))))
+
+(defun print-element (object stream)
+ (let ((*current-print-level* (1+ *current-print-level*)))
+ (multiple-value-bind (n present-p) (gethash object *shared-object-table*)
+ (if (and present-p *print-circle*)
+ (if (zerop n)
+ (progn
+ (print-label object stream)
+ (print-object object stream))
+ (print-reference object stream))
+ (print-object object stream)))))
+
+(defun print-label (object stream)
+ (multiple-value-bind (n present-p) (gethash object *shared-object-label*)
+ (assert present-p)
+ (write-string "#" stream)
+ (let ((*print-base* 10) (*print-radix* nil)) (print-integer n stream))
+ (write-string "=" stream)
+ (incf (gethash object *shared-object-table*))))
+
+(defun print-reference (object stream)
+ (multiple-value-bind (n present-p) (gethash object *shared-object-label*)
+ (assert present-p)
+ (write-string "#" stream)
+ (let ((*print-base* 10) (*print-radix* nil)) (print-integer n stream))
+ (write-string "#" stream)))
+
+(defmethod print-object ((list cons) stream)
+ (when (and *print-circle* (zerop *current-print-level*))
+ (search-shared-object list))
+ (if (print-max-level-p)
+ (write-string "#" stream)
+ (let ((x list)
+ (l 0))
+ (multiple-value-bind (n present-p) (gethash x *shared-object-table*)
+ (when (and (zerop *current-print-level*) present-p *print-circle*)
+ (print-label x stream))
+ (write-string "(" stream)
+ (loop (when (atom x)
+ (when x
+ (write-string " . " stream)
+ (print-element x stream))
+ (write-string ")" stream)
+ (return))
+ (when (print-max-length-p l)
+ (write-string "...)" stream)
+ (return))
+ (print-element (car x) stream)
+ (setq x (cdr x)
+ l (1+ l))
+ (when (consp x)
+ (write-string " " stream)
+ (multiple-value-setq (n present-p)
+ (gethash x *shared-object-table*))
+ (when (and present-p *print-circle*)
+ (write-string ". " stream)
+ (if (zerop n)
+ (print-element x stream)
+ (print-reference x stream))
+ (write-string ")" stream)
+ (return))))))))
+
+(defmethod print-object :around ((array array) stream)
+ (cond
+ ((and (not *print-readably*) (not *print-array*) (not (stringp array)))
+ ;; 22.1.3.4 Printing Strings
+ ;; http://www.lispworks.com/reference/HyperSpec/Body/22_acd.htm
+ ;; The printing of strings is not affected by *print-array*.
+ (print-unreadable-object (array stream :type t :identity t)))
+ ((and (print-max-level-p) (not (stringp array)) (not (bit-vector-p array)))
+ ;; Variable *PRINT-LEVEL*, *PRINT-LENGTH*
+ ;; http://www.lispworks.com/reference/HyperSpec/Body/v_pr_lev.htm
+ ;; *print-level* and *print-length* affect the printing of
+ ;; an any object printed with a list-like syntax. They do not affect
+ ;; the printing of symbols, strings, and bit vectors.
+ (write-string "#" stream))
+ (t (when (and *print-circle* (zerop *current-print-level*)
+ (not (stringp array)) (not (bit-vector-p array)))
+ (search-shared-object array)
+ (multiple-value-bind (n present-p)
+ (gethash array *shared-object-table*)
+ (declare (ignore n))
+ (when present-p (print-label array stream))))
+ (call-next-method array stream))))
+
+(defmethod print-object ((vector vector) stream)
+ (let ((l 0)
+ (length (length vector)))
+ (write-string "#(" stream)
+ (loop (when (= l length)
+ (write-string ")" stream)
+ (return))
+ (when (print-max-length-p l)
+ (write-string "...)" stream)
+ (return))
+ (print-element (aref vector l) stream)
+ (setq l (1+ l))
+ (when (< l length) (write-string " " stream)))))
+
+(defmethod print-object ((array array) stream)
+ (let* ((dimensions (array-dimensions array))
+ (indices (make-list (array-rank array) :initial-element 0)))
+ (labels
+ ((p-array (i-list d-list)
+ (cond
+ ((print-max-level-p) (write-string "#" stream))
+ ((null i-list) (print-element (apply #'aref array indices) stream))
+ (t (write-string "(" stream)
+ (do ((i 0 (1+ i)))
+ ((= i (car d-list)))
+ (when (plusp i) (write-string " " stream))
+ (when (print-max-length-p i)
+ (write-string "..." stream)
+ (return))
+ (setf (car i-list) i)
+ (if (null (cdr i-list))
+ (print-element (apply #'aref array indices) stream)
+ (let ((*current-print-level* (1+ *current-print-level*)))
+ (p-array (cdr i-list) (cdr d-list)))))
+ (write-string ")" stream)))))
+ (write-string "#" stream)
+ (let ((*print-base* 10) (*print-radix* nil))
+ (print-integer (array-rank array) stream))
+ (write-string "A" stream)
+ (p-array indices dimensions))))
+
+(defmethod print-object ((string string) stream)
+ (let ((escape-p (printer-escaping-enabled-p)))
+ (when escape-p (write-char #\" stream))
+ (loop for c across string
+ if (and escape-p (member c '(#\" #\\))) do (write-char #\\ stream)
+ do (write-char c stream))
+ (when escape-p (write-char #\" stream))
+ string))
+
+(defmethod print-object ((bit-vector bit-vector) stream)
+ (if (or *print-array* *print-readably*)
+ (progn
+ (write-string "#*" stream)
+ (loop for bit across bit-vector
+ do (write-char (if (zerop bit) #\0 #\1) stream)))
+ (print-unreadable-object (bit-vector stream :type t :identity t)))
+ bit-vector)
+
+(defmethod print-object ((object t) stream)
+ (print-unreadable-object (object stream :type t :identity t)))
+
+(defun print-object-prettily (object stream)
+ (print-object object stream))
+
+
+
+;; format
+;; (defun format (destination format-control &rest args)
+;; (apply (if (stringp format-control) (formatter format-control) format-control)
+;; destination args))
+;;
+;;
+;; (defmacro formatter (control-string)
+;;
+;; )
diff --git a/Sacla/reader.lisp b/Sacla/reader.lisp
new file mode 100644
index 0000000..2c87418
--- /dev/null
+++ b/Sacla/reader.lisp
@@ -0,0 +1,797 @@
+;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
+;; ALL RIGHTS RESERVED.
+;;
+;; $Id: reader.lisp,v 1.13 2004/07/22 06:06:33 yuji Exp $
+;;
+;; 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.
+;;
+;; 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.
+
+
+(defstruct (readtable (:predicate readtablep) (:copier nil))
+ "Map characters into syntax types and reader macro functions."
+ (syntax (make-hash-table) :type hash-table)
+ (case :upcase :type (member :upcase :downcase :preserve :invert)))
+
+(defvar *read-base* '10
+ "The radix in which integers and ratios are to be read by the Lisp reader.")
+(defvar *read-default-float-format* 'single-float
+ "Used for a floating-point number having no exponent marker or e or E.")
+(defvar *read-eval* 't
+ "If true, the #. reader macro has its normal effect. If false, reader-error.")
+(defvar *read-suppress* 'nil
+ "If true, the reader reads an object and returns a primary value of nil.")
+(defvar *readtable* nil
+ "The current readtable. Control the parsing behavior of the Lisp reader.")
+
+
+(defvar *sharp-equal-alist* nil)
+(defvar *sharp-sharp-alist* nil)
+(defvar *consing-dot-allowed* nil)
+(defvar *consing-dot* (gensym))
+(defvar *preserve-whitespace-p* nil)
+(defvar *input-stream* nil)
+(defvar *backquote-level* 0)
+(defvar *dispatch-macro-char* nil)
+(defvar *standard-readtable*)
+
+(define-condition invalid-character-error (reader-error)
+ ((character :type character :reader invalid-character-error-character
+ :initarg :character))
+ (:report
+ (lambda (condition stream)
+ (format stream "Invalid character ~S is read."
+ (invalid-character-error-character condition)))))
+
+(defun reader-error (&optional format-control &rest format-arguments)
+ (error 'reader-error
+ :format-control format-control :format-arguments format-arguments))
+
+(defun copy-readtable (&optional (from-readtable *readtable*) to-readtable)
+ "Copy FROM-READTABLE. If TO-READTABLE is nil, a new table is to be created."
+ (flet ((copy-syntax (src)
+ (let ((new (make-hash-table)))
+ (maphash
+ #'(lambda (k v)
+ (let ((plist (copy-list v)))
+ (setf (gethash k new) plist)
+ (when (getf plist :dispatch-table)
+ (let ((hash (make-hash-table)))
+ (maphash #'(lambda (k v) (setf (gethash k hash) v))
+ (getf plist :dispatch-table))
+ (setf (getf plist :dispatch-table) hash)))))
+ src)
+ new)))
+ (let ((from (or from-readtable *standard-readtable*)))
+ (if to-readtable
+ (prog1 to-readtable
+ (setf (readtable-syntax to-readtable)
+ (copy-syntax (readtable-syntax from)))
+ (setf (readtable-case to-readtable) (readtable-case from)))
+ (make-readtable :syntax (copy-syntax (readtable-syntax from))
+ :case (readtable-case from))))))
+
+(defun syntax-type (char &optional (readtable *readtable*))
+ (let ((plist (gethash char (readtable-syntax readtable))))
+ (getf plist :syntax :constituent)))
+
+(defun get-macro-character (char &optional (readtable *readtable*))
+ "Return a macro function for CHAR and non-terminating-p as the secondary value."
+ (unless readtable (setq readtable *standard-readtable*))
+ (let ((plist (gethash char (readtable-syntax readtable))))
+ (case (syntax-type char readtable)
+ (:terminating-macro-char (values (getf plist :macro-function) nil))
+ (:non-terminating-macro-char (values (getf plist :macro-function) t))
+ (t (values nil nil)))))
+
+(defun set-macro-character (char new-function
+ &optional non-terminating-p (readtable *readtable*))
+ "Make CHAR a macro character associated with NEW-FUNCTION in READTABLE."
+ (check-type char character)
+ (check-type new-function function-designator)
+ (when (null readtable)
+ (error "Standard readtable must not be changed."))
+ (let ((plist (gethash char (readtable-syntax readtable))))
+ (setf (getf plist :syntax) (if non-terminating-p
+ :non-terminating-macro-char
+ :terminating-macro-char)
+ (getf plist :macro-function) new-function
+ (gethash char (readtable-syntax readtable)) plist))
+ t)
+
+(defun get-dispatch-macro-character (disp-char sub-char
+ &optional (readtable *readtable*))
+ "Retrieve the dispatch function for DISP-CHAR and SUB-CHAR in READTABLE."
+ (unless readtable (setq readtable *standard-readtable*))
+ (unless (eq (get-macro-character disp-char readtable)
+ 'dispatch-macro-character)
+ (error "~S is not a dispatching macro character." disp-char))
+ (let* ((syntax-table (readtable-syntax readtable))
+ (dispatch-table (getf (gethash disp-char syntax-table)
+ :dispatch-table))
+ (sub-char (char-upcase sub-char)))
+ (multiple-value-bind (value present-p) (gethash sub-char dispatch-table)
+ (cond
+ ((digit-char-p sub-char 10) nil)
+ (present-p value)
+ (t
+ #'(lambda (stream sub-char number)
+ (declare (ignore stream number))
+ (reader-error "No dispatch function defined for ~S."
+ sub-char)))))))
+
+(defun set-dispatch-macro-character (disp-char sub-char new-function
+ &optional (readtable *readtable*))
+ "Install NEW-FUNCTION as the dispatch function for DISP-CHAR and SUB-CHAR."
+ (when (null readtable) (error "Standard readtable must not be changed."))
+ (unless (eq (get-macro-character disp-char readtable)
+ 'dispatch-macro-character)
+ (error "~S is not a dispatch character." disp-char))
+ (let* ((syntax-table (readtable-syntax readtable))
+ (dispatch-table (getf (gethash disp-char syntax-table)
+ :dispatch-table))
+ (sub-char (char-upcase sub-char)))
+ (setf (gethash sub-char dispatch-table) new-function)
+ t))
+
+(defun make-dispatch-macro-character (char &optional non-terminating-p
+ (readtable *readtable*))
+ "Make CHAR be a dispatching macro character in READTABLE."
+ (when (null readtable) (error "Standard readtable must not be changed."))
+ (set-macro-character char 'dispatch-macro-character
+ non-terminating-p readtable)
+
+ (setf (getf (gethash char (readtable-syntax readtable)) :dispatch-table)
+ (make-hash-table))
+ t)
+
+(defun dispatch-macro-character (stream char)
+ (let ((n (when (digit-char-p (peek-char nil stream t nil t) 10)
+ (loop
+ with n = 0
+ for digit = (read-char stream t nil t)
+ do (setq n (+ (* n 10) (digit-char-p digit 10)))
+ while (digit-char-p (peek-char nil stream t nil t) 10)
+ finally (return n))))
+ (*dispatch-macro-char* char)
+ (sub-char (char-upcase (read-char stream t nil t))))
+ (funcall (get-dispatch-macro-character char sub-char) stream sub-char n)))
+
+(defun set-syntax-from-char (to-char from-char
+ &optional (to-readtable *readtable*)
+ (from-readtable *standard-readtable*))
+ "Make the syntax of TO-CHAR in TO-READTABLE be the same as that of FROM-CHAR."
+ (check-type to-char character)
+ (check-type from-char character)
+ (check-type to-readtable readtable)
+ (unless from-readtable (setq from-readtable *standard-readtable*))
+ (check-type from-readtable readtable)
+ (let ((plist (copy-list (gethash from-char
+ (readtable-syntax from-readtable)))))
+ (when (getf plist :dispatch-table)
+ (let ((hash (make-hash-table)))
+ (maphash #'(lambda (k v) (setf (gethash k hash) v))
+ (getf plist :dispatch-table))
+ (setf (getf plist :dispatch-table) hash)))
+ (setf (gethash to-char (readtable-syntax to-readtable)) plist)
+ t))
+
+(defun read-preserving-whitespace (&optional (input-stream *standard-input*)
+ (eof-error-p t) eof-value recursive-p)
+ "Read an object but preserves any whitespace character after it."
+ (let ((*preserve-whitespace-p* (if recursive-p *preserve-whitespace-p* t)))
+ (read-lisp-object input-stream eof-error-p eof-value recursive-p)))
+
+(defun read (&optional (input-stream *standard-input*)
+ (eof-error-p t) eof-value recursive-p)
+ "Parse a printed representation from INPUT-STREAM and return the object."
+ (let ((*preserve-whitespace-p* (when recursive-p *preserve-whitespace-p*)))
+ (read-lisp-object input-stream eof-error-p eof-value recursive-p)))
+
+(defun read-from-string (string &optional (eof-error-p t) eof-value
+ &key (start 0) end preserve-whitespace)
+ "Read an object from the subsequence of string bounded by START and END."
+ (let ((index nil))
+ (values (with-input-from-string (stream string :index index
+ :start start :end end)
+ (funcall (if preserve-whitespace
+ #'read-preserving-whitespace
+ #'read)
+ stream eof-error-p eof-value))
+ index)))
+
+(defun make-str (chars)
+ (make-array (length chars) :element-type 'character :initial-contents chars))
+
+(defun sharp-equal (stream sub-char n)
+ (declare (ignore sub-char))
+ (if *read-suppress*
+ (values)
+ (let* ((this (gensym))
+ (object (progn
+ (setq *sharp-sharp-alist* (acons n this
+ *sharp-sharp-alist*))
+ (read stream t nil t))))
+ (when (null n)
+ (reader-error "Missing label number for #=."))
+ (when (assoc this *sharp-equal-alist*)
+ (reader-error "#~D= is already defined." n))
+ (when (eq object this)
+ (reader-error "need to tag something more than just #~D#." n))
+ (setq *sharp-equal-alist* (acons this object *sharp-equal-alist*))
+ object)))
+
+(defun sharp-sharp (stream sub-char n)
+ (declare (ignore sub-char stream))
+ (unless *read-suppress*
+ (unless n (reader-error "Label is missing for ##."))
+ (let ((assoc (assoc n *sharp-sharp-alist*)))
+ (unless assoc
+ (reader-error "No object labeled ~D is seen." n))
+ (cdr assoc))))
+
+(defun read-delimited-list (char &optional (stream *standard-input*)
+ recursive-p)
+ "Read objects until CHAR appears, then return a list of objects read."
+ (let ((list (read-list char stream :allow-consing-dot nil)))
+ (unless *read-suppress* list)))
+
+(defun read-list (char &optional (stream *standard-input*)
+ &key allow-consing-dot)
+ (let ((*consing-dot-allowed* allow-consing-dot)
+ c stack values list)
+ (loop
+ (setq c (peek-char t stream t nil t))
+ (when (char= char c) ; found the closing parenthesis.
+ (when (eq (first stack) *consing-dot*)
+ (error "Nothing appears after . in list."))
+ (read-char stream t nil t)
+ (setq list (if (eq (second stack) *consing-dot*)
+ (nreconc (cddr stack) (first stack))
+ (nreverse stack)))
+ (return))
+ (when (setq values (multiple-value-list (lisp-object? stream t nil t)))
+ (if (eq (second stack) *consing-dot*)
+ (error "More than one object follows . in list.")
+ (push (car values) stack))))
+ list))
+
+(defun lisp-object? (stream eof-error-p eof-value recursive-p)
+ (loop
+ (let* ((c (read-char stream eof-error-p eof-value recursive-p)))
+ (when (and (not eof-error-p) (eq c eof-value)) (return eof-value))
+ (ecase (syntax-type c)
+ (:invalid (error 'invalid-character-error :character c))
+ (:whitespace 'skip)
+ ((:single-escape :multiple-escape :constituent)
+ (return (read-number-or-symbol stream c)))
+ ((:terminating-macro-char :non-terminating-macro-char)
+ (return (funcall (get-macro-character c) stream c)))))))
+
+(defmethod general-nsublis ((alist list) (object t))
+ object)
+
+(defmethod general-nsublis :around ((alist cons) (object t))
+ (let ((assoc (assoc object alist :test #'eq)))
+ (if assoc
+ (cdr assoc)
+ (call-next-method alist object))))
+
+(defmethod general-nsublis ((alist cons) (object cons))
+ (setf (car object) (general-nsublis alist (car object)))
+ (setf (cdr object) (general-nsublis alist (cdr object)))
+ object)
+
+(defmethod general-nsublis ((alist cons) (object array))
+ (do ((i 0 (1+ i)))
+ ((= i (array-total-size object)) object)
+ (setf (row-major-aref object i)
+ (general-nsublis alist (row-major-aref object i)))))
+
+(defun read-lisp-object (stream eof-error-p eof-value recursive-p)
+ (unless recursive-p
+ (setq *sharp-equal-alist* nil
+ *sharp-sharp-alist* nil))
+ (let ((object (loop
+ (let ((values (multiple-value-list
+ (lisp-object? stream
+ eof-error-p eof-value
+ recursive-p))))
+ (when values
+ (return (unless *read-suppress* (car values))))))))
+ (if (and (not recursive-p) *sharp-equal-alist*)
+ (general-nsublis *sharp-equal-alist* object)
+ object)))
+
+(defun read-ch () (read-char *input-stream* nil nil t))
+(defun read-ch-or-die () (read-char *input-stream* t nil t))
+(defun unread-ch (c) (unread-char c *input-stream*))
+
+(defun collect-escaped-lexemes (c)
+ (ecase (syntax-type c)
+ (:invalid (error 'invalid-character-error :character c))
+ (:multiple-escape nil)
+ (:single-escape (cons (read-ch-or-die)
+ (collect-escaped-lexemes (read-ch-or-die))))
+ ((:constituent
+ :whitespace :terminating-macro-char :non-terminating-macro-char)
+ (cons c (collect-escaped-lexemes (read-ch-or-die))))))
+
+(defun collect-lexemes (c &optional (stream *input-stream*))
+ (let ((*input-stream* stream))
+ (when c
+ (ecase (syntax-type c)
+ (:invalid (error 'invalid-character-error :character c))
+ (:whitespace (when *preserve-whitespace-p* (unread-ch c)))
+ (:terminating-macro-char (unread-ch c))
+ (:multiple-escape (cons (collect-escaped-lexemes (read-ch-or-die))
+ (collect-lexemes (read-ch))))
+ (:single-escape (cons (list (read-ch-or-die))
+ (collect-lexemes (read-ch))))
+ ((:constituent :non-terminating-macro-char)
+ (cons c (collect-lexemes (read-ch))))))))
+
+;; integer ::= [sign] decimal-digit+ decimal-point
+;; | [sign] digit+
+;; ratio ::= [sign] {digit}+ slash {digit}+
+;; float ::= [sign] {decimal-digit}* decimal-point {decimal-digit}+ [exponent]
+;; | [sign] {decimal-digit}+ [decimal-point {decimal-digit}*] exponent
+;; exponent::= exponent-marker [sign] {digit}+
+
+(defun construct-number (chars)
+ (labels ((sign ()
+ (let ((c (and chars (car chars))))
+ (cond
+ ((eql c #\-) (pop chars) -1)
+ ((eql c #\+) (pop chars) +1)
+ (t +1))))
+ (digit* (&optional (base *read-base*))
+ (let ((pos (or (position-if-not #'(lambda (d)
+ (digit-char-p d base))
+ chars)
+ (length chars))))
+ (prog1 (subseq chars 0 pos)
+ (setq chars (subseq chars pos)))))
+ (int? (sign digits &optional (base *read-base*))
+ (when (and digits
+ (every #'(lambda (d) (digit-char-p d base)) digits))
+ (* sign (reduce #'(lambda (a b) (+ (* base a) b))
+ (mapcar #'(lambda (d) (digit-char-p d base))
+ digits)))))
+ (float? (sign)
+ (let* ((int (digit* 10))
+ (fraction (when (eql (car chars) #\.)
+ (pop chars) (digit* 10)))
+ (exp-marker (when (and chars
+ (find (char-upcase (car chars))
+ '(#\D #\E #\F #\L #\S)))
+ (char-upcase (pop chars))))
+ (exp-sign (and exp-marker (sign)))
+ (exp-digits (and exp-sign (digit*))))
+ (when (and (null chars)
+ (or fraction (and int exp-marker exp-digits)))
+ (float (* (int? sign (append int fraction) 10)
+ (expt 10 (- (or (int? exp-sign exp-digits 10) 0)
+ (length fraction))))
+ (ecase (or exp-marker *read-default-float-format*)
+ (#\E 1.0e0)
+ ((#\D double-float) 1.0d0)
+ ((#\F single-float) 1.0f0)
+ ((#\L long-float) 1.0l0)
+ ((#\S short-float) 1.0s0)))))))
+ (let ((sign (sign))
+ pos numerator denominator)
+ (when chars
+ (or
+ ;; [sign] digit+
+ (int? sign chars)
+ ;; [sign] decimal-digit+ decimal-point
+ (and (eql (car (last chars)) #\.) (int? sign (butlast chars) 10))
+ ;; [sign] {digit}+ slash {digit}+
+ (and (setq pos (position #\/ chars))
+ (setq numerator (int? sign (subseq chars 0 pos)))
+ (setq denominator (int? 1 (subseq chars (1+ pos))))
+ (not (zerop denominator))
+ (/ numerator denominator))
+ ;; [sign] {decimal-digit}* decimal-point {decimal-digit}+ [exponent]
+ ;; [sign] {decimal-digit}+ [decimal-point {decimal-digit}*] exponent
+ (float? sign))))))
+
+
+
+(defun ensure-external-symbol (name package)
+ (multiple-value-bind (symbol status) (find-symbol name package)
+ (unless (eq status :external)
+ (cerror (if (null status)
+ "Intern and export symbol ~S in package ~S."
+ "Export symbol ~S in package ~S.")
+ "There is no external symbol by the name of ~S in package ~S."
+ name package)
+ (export (setq symbol (intern name package)) package))
+ symbol))
+
+(defun construct-symbol (lexemes &key uninterned-symbol-wanted)
+ (labels ((up (x) (if (listp x) (copy-list x) (list (char-upcase x))))
+ (down (x) (if (listp x) (copy-list x) (list (char-downcase x))))
+ (chars (lexemes)
+ (ecase (readtable-case *readtable*)
+ (:upcase (mapcan #'up lexemes))
+ (:downcase (mapcan #'down lexemes))
+ (:invert
+ (let ((unescaped (remove-if-not #'alpha-char-p
+ (remove-if #'listp lexemes))))
+ (mapcan (cond
+ ((every #'upper-case-p unescaped) #'down)
+ ((every #'lower-case-p unescaped) #'up)
+ (t #'(lambda (x)
+ (if (listp x) (copy-list x) (list x)))))
+ lexemes)))
+ (:preserve (mapcan #'(lambda (x)
+ (if (listp x) (copy-list x) (list x)))
+ lexemes))))
+ (name (lexemes)
+ (when (find #\: lexemes) (error "Too many package markers."))
+ (make-str (chars lexemes))))
+ (let* ((pos (position #\: lexemes))
+ (external-p (and pos (not (eql (nth (1+ pos) lexemes) #\:))))
+ (package (when pos (name (subseq lexemes 0 pos))))
+ (name (name (subseq lexemes
+ (if pos (+ pos (if external-p 1 2)) 0)))))
+ (values (cond
+ (uninterned-symbol-wanted
+ (if package
+ (reader-error)
+ (make-symbol name)))
+ (external-p
+ (ensure-external-symbol name package))
+ (t (intern name (or package *package*))))))))
+
+(defun read-number-or-symbol (stream c)
+ (let ((lexemes (collect-lexemes c stream)))
+ (assert lexemes)
+ (unless *read-suppress*
+ (cond
+ ((and lexemes (every #'(lambda (x) (eql x #\.)) lexemes))
+ (when (rest lexemes)
+ (reader-error "Tokens consisting of only dots are invalid."))
+ (when (not *consing-dot-allowed*)
+ (reader-error "Consing dot is not allowed."))
+ *consing-dot*)
+ (t
+ (or (and (every #'characterp lexemes) (construct-number lexemes))
+ (construct-symbol lexemes)))))))
+
+
+;; backquote
+
+(defconstant backquote (gensym))
+(defconstant backquote-comma (gensym))
+(defconstant backquote-comma-at (gensym))
+(defconstant backquote-comma-dot (gensym))
+(defun backquoted-expression-type (exp)
+ (if (atom exp)
+ :normal
+ (cond
+ ((eq (first exp) backquote-comma) :comma)
+ ((eq (first exp) backquote-comma-at) :comma-at)
+ ((eq (first exp) backquote-comma-dot) :comma-dot)
+ (t :normal))))
+
+(defmacro backquote (object)
+ (if (atom object)
+ (if (simple-vector-p object)
+ (list 'apply #'vector (list backquote (concatenate 'list object)))
+ (list 'quote object))
+ (let* ((list (copy-list object))
+ (last (loop for x = list then (cdr x)
+ until (or (atom (cdr x))
+ (find (cadr x) (list backquote
+ backquote-comma
+ backquote-comma-at
+ backquote-comma-dot)))
+ finally (return (prog1 (cdr x) (setf (cdr x) nil)))))
+ (types (mapcar #'backquoted-expression-type list)))
+ (append
+ (cons (if (notany #'(lambda (x) (eq x :comma-at)) types) 'nconc 'append)
+ (mapcar #'(lambda (x)
+ (ecase (backquoted-expression-type x)
+ (:normal (list 'list (list 'backquote x)))
+ (:comma (list 'list x))
+ ((:comma-at :comma-dot) x)))
+ list))
+ (list (ecase (backquoted-expression-type last)
+ (:normal (list 'quote last))
+ (:comma last)
+ (:comma-at (error ",@ after dot"))
+ (:comma-dot (error ",. after dot"))))))))
+
+(defmacro backquote-comma (obj) obj)
+(setf (macro-function backquote) (macro-function 'backquote))
+(setf (macro-function backquote-comma) (macro-function 'backquote-comma))
+(setf (macro-function backquote-comma-at) (macro-function 'backquote-comma))
+(setf (macro-function backquote-comma-dot) (macro-function 'backquote-comma))
+
+
+(defun read-comma-form (stream c)
+ (declare (ignore c))
+ (unless (> *backquote-level* 0)
+ (error "Comma must be used in a backquoted expression."))
+ (let ((*backquote-level* (1- *backquote-level*)))
+ (case (peek-char t stream t nil t)
+ (#\@ (read-char stream t nil t)
+ (list backquote-comma-at (read stream t nil t)))
+ (#\. (read-char stream t nil t)
+ (list backquote-comma-dot (read stream t nil t)))
+ (t (list backquote-comma (read stream t nil t))))))
+
+(defun read-backquoted-expression (stream c)
+ (declare (ignore c))
+ (let ((*backquote-level* (1+ *backquote-level*)))
+ (list backquote (read stream t nil t))))
+
+
+(defun sharp-backslash (stream sub-char n)
+ (declare (ignore n))
+ (let* ((lexemes (collect-lexemes sub-char stream))
+ (str (make-str (mapcan #'(lambda (x)
+ (if (listp x) (copy-list x) (list x)))
+ lexemes))))
+ (unless *read-suppress*
+ (cond
+ ((= 1 (length str)) (char str 0))
+ ((name-char str))
+ (t (reader-error "Unrecognized character name: ~S" str))))))
+
+(defun sharp-single-quote (stream sub-char n)
+ (declare (ignore sub-char n))
+ `(function ,(read stream t nil t)))
+
+(defun sharp-left-parenthesis (stream sub-char n)
+ (declare (ignore sub-char))
+ (let ((list (read-delimited-list #\) stream t)))
+ (unless *read-suppress*
+ (when (and n (> (length list) n))
+ (reader-error "vector is longer than specified length #~A*~A."
+ n list))
+ (apply #'vector
+ (if (and n (< (length list) n))
+ (append list (make-list (- n (length list))
+ :initial-element (car (last list))))
+ list)))))
+
+(defun sharp-asterisk (stream sub-char n)
+ (declare (ignore sub-char))
+ (let* ((*input-stream* stream)
+ (lexemes (collect-lexemes (read-ch)))
+ (bits (mapcar #'(lambda (d)
+ (unless (characterp d)
+ (error "Binary digit must be given"))
+ (digit-char-p d 2)) lexemes)))
+ (unless *read-suppress*
+ (unless (every #'(lambda (d) (digit-char-p d 2)) lexemes)
+ (reader-error "Illegal bit vector format."))
+ (when (and n (> (length bits) n))
+ (reader-error "Bit vector is longer than specified length #~A*~A."
+ n (make-str lexemes)))
+ (when (and n (> n 0) (zerop (length bits)))
+ (reader-error
+ "At least one bit must be given for non-zero #* bit-vectors."))
+ (make-array (or n (length bits)) :element-type 'bit
+ :initial-contents
+ (if (and n (< (length bits) n))
+ (append bits
+ (make-list (- n (length bits))
+ :initial-element (car (last bits))))
+ bits)))))
+
+(defun sharp-colon (stream sub-char n)
+ (declare (ignore sub-char n))
+ (let* ((*input-stream* stream)
+ (lexemes (collect-lexemes (read-ch))))
+ (unless *read-suppress*
+ (construct-symbol lexemes :uninterned-symbol-wanted t))))
+
+(defun sharp-dot (stream sub-char n)
+ (declare (ignore sub-char n))
+ (let ((object (read stream t nil t)))
+ (unless *read-suppress*
+ (unless *read-eval*
+ (reader-error "Attempt to read #. while *READ-EVAL* is bound to NIL."))
+ (eval object))))
+
+(defun sharp-b (stream sub-char n)
+ (declare (ignore n))
+ (sharp-r stream sub-char 2))
+
+(defun sharp-o (stream sub-char n)
+ (declare (ignore n))
+ (sharp-r stream sub-char 8))
+
+(defun sharp-x (stream sub-char n)
+ (declare (ignore n))
+ (sharp-r stream sub-char 16))
+
+(defun sharp-r (stream sub-char n)
+ (cond
+ (*read-suppress* (read stream t nil t))
+ ((not n) (reader-error "Radix missing in #R."))
+ ((not (<= 2 n 36)) (reader-error "Illegal radix for #R: ~D." n))
+ (t (let ((rational (let ((*read-base* n)) (read stream t nil t))))
+ (unless (typep rational 'rational)
+ (reader-error "#~A (base ~D) value is not a rational: ~S."
+ sub-char n rational))
+ rational))))
+
+
+(defun sharp-c (stream sub-char n)
+ (declare (ignore sub-char n))
+ (let ((pair (read stream t nil t)))
+ (unless *read-suppress*
+ (unless (and (listp pair) (= (length pair) 2))
+ (reader-error "Illegal complex number format: #C~S" pair))
+ (complex (first pair) (second pair)))))
+
+(defun sharp-a (stream sub-char rank)
+ (declare (ignore sub-char))
+ (cond
+ (*read-suppress* (read stream t nil t))
+ ((null rank)
+ (reader-error "Rank for #A notation is missing."))
+ (t (let* ((contents (read stream t nil t))
+ (dimensions (loop repeat rank
+ for x = contents then (first x)
+ collect (length x))))
+ (make-array dimensions :initial-contents contents)))))
+
+
+(defun find-default-constructor (name)
+ (declare (ignore name)))
+
+(defun sharp-s (stream sub-char n)
+ (declare (ignore sub-char n))
+ (let ((structure-spec (read stream t nil t)))
+ (unless *read-suppress*
+ (unless (listp structure-spec)
+ (reader-error "Non list follows #S."))
+ (unless (symbolp (first structure-spec))
+ (reader-error "Structure type is not a symbol: ~S"
+ (car structure-spec)))
+ (let* ((name (first structure-spec))
+ (plist (loop
+ for list on (rest structure-spec) by #'cddr
+ append (list (intern (string (first list)) "KEYWORD")
+ (second list))))
+ (class (find-class name nil)))
+ (unless (typep class 'structure-class)
+ (reader-error "~S is not a defined structure type." name))
+ (let ((constructor (find-default-constructor name)))
+ (apply constructor plist))))))
+
+(defun sharp-p (stream sub-char n)
+ (declare (ignore sub-char n))
+ (let ((namestring (read stream t nil t)))
+ (unless *read-suppress* (parse-namestring namestring))))
+
+
+
+(defun featurep (x)
+ (if (atom x)
+ (member x *features*)
+ (ecase (first x)
+ (:not (not (featurep (second x))))
+ (:and (every #'featurep (rest x)))
+ (:or (some #'featurep (rest x))))))
+
+(defun read-feature-test (stream)
+ (let ((*package* (or (find-package "KEYWORD")
+ (error "KEYWORD package not found."))))
+ (read stream t nil t)))
+
+(defun sharp-plus (stream sub-char n)
+ (declare (ignore sub-char n))
+ (if (featurep (read-feature-test stream))
+ (read stream t nil t)
+ (let ((*read-suppress* t)) (read stream t nil t) (values))))
+
+(defun sharp-minus (stream sub-char n)
+ (declare (ignore sub-char n))
+ (if (not (featurep (read-feature-test stream)))
+ (read stream t nil t)
+ (let ((*read-suppress* t)) (read stream t nil t) (values))))
+
+(defun sharp-vertical-bar (stream sub-char n)
+ (declare (ignore sub-char n))
+ (loop for c = (read-char stream t nil t)
+ if (and (char= c #\#) (char= (read-char stream t nil t) #\|))
+ do (sharp-vertical-bar stream #\| nil)
+ until (and (char= c #\|) (char= (read-char stream t nil t) #\#)))
+ (values))
+
+
+(defvar *standard-syntax-table*
+ (let ((table (make-hash-table)))
+ (mapc #'(lambda (x)
+ (let ((syntax (first x))
+ (chars (rest x)))
+ (dolist (c chars)
+ (setf (gethash c table) `(:syntax ,syntax)))))
+ '((:whitespace #\Tab #\Newline #\Linefeed #\Page #\Return #\Space)
+ (:single-escape #\\)
+ (:multiple-escape #\|)))
+ table))
+
+(setq *standard-readtable* (make-readtable :syntax *standard-syntax-table*))
+
+(set-macro-character #\` 'read-backquoted-expression nil *standard-readtable*)
+(set-macro-character #\, 'read-comma-form nil *standard-readtable*)
+
+(set-macro-character #\( #'(lambda (stream char)
+ (declare (ignore char))
+ (read-list #\) stream :allow-consing-dot t))
+ nil *standard-readtable*)
+
+(set-macro-character #\) #'(lambda (stream char)
+ (declare (ignore stream char))
+ (error "Unmatched close parenthesis."))
+ nil *standard-readtable*)
+
+(set-macro-character #\' #'(lambda (stream char)
+ (declare (ignore char))
+ `(quote ,(read stream t nil t)))
+ nil *standard-readtable*)
+
+(set-macro-character #\; #'(lambda (stream char)
+ (declare (ignore char))
+ (loop
+ for c = (read-char stream nil nil t)
+ until (or (null c) (eql c #\Newline)))
+ (values))
+ nil *standard-readtable*)
+
+(set-macro-character #\" #'(lambda (stream char)
+ (declare (ignore char))
+ (loop
+ for c = (read-char stream t nil t)
+ until (char= c #\")
+ if (eq :single-escape (syntax-type c))
+ collect (read-char stream t nil t) into chars
+ else
+ collect c into chars
+ finally
+ (return (make-array (length chars)
+ :element-type 'character
+ :initial-contents chars))))
+ nil *standard-readtable*)
+
+
+(make-dispatch-macro-character #\# t *standard-readtable*)
+(mapc
+ #'(lambda (pair)
+ (set-dispatch-macro-character #\# (first pair) (second pair)
+ *standard-readtable*))
+ '((#\\ sharp-backslash) (#\' sharp-single-quote) (#\( sharp-left-parenthesis)
+ (#\* sharp-asterisk) (#\: sharp-colon) (#\. sharp-dot) (#\b sharp-b)
+ (#\o sharp-o) (#\x sharp-x) (#\r sharp-r) (#\c sharp-c) (#\a sharp-a)
+ (#\s sharp-s) (#\p sharp-p) (#\= sharp-equal) (#\# sharp-sharp)
+ (#\+ sharp-plus) (#\- sharp-minus) (#\| sharp-vertical-bar)))
+
+(setq *readtable* (copy-readtable nil))
diff --git a/Sacla/sequence.lisp b/Sacla/sequence.lisp
new file mode 100644
index 0000000..07b6684
--- /dev/null
+++ b/Sacla/sequence.lisp
@@ -0,0 +1,677 @@
+;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
+;; ALL RIGHTS RESERVED.
+;;
+;; $Id: sequence.lisp,v 1.42 2004/02/20 07:23:42 yuji Exp $
+;;
+;; 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.
+;;
+;; 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.
+
+
+(defun length (sequence)
+ "Return the number of elements in SEQUENCE."
+ (cond ;; can't use etypecase for setf
+ ((typep sequence 'list)
+ (let ((length (list-length sequence)))
+ (or length (error-circular-list sequence))))
+ ((typep sequence 'vector)
+ (if (array-has-fill-pointer-p sequence)
+ (fill-pointer sequence)
+ (array-dimension sequence 0)))
+ (t
+ (error 'type-error :datum sequence :expected-type 'sequence))))
+
+(defun check-sequence-access (sequence index)
+ (check-type sequence proper-sequence)
+ (check-type index (integer 0))
+ (unless (< index (length sequence))
+ (error-index-too-large sequence index)))
+
+(defun check-subsequence (sequence start end)
+ (check-type sequence proper-sequence)
+ (check-type start (integer 0))
+ (check-type end (integer 0)))
+
+(defun elt (sequence index)
+ "Return the element of SEQUENCE specified by INDEX."
+ (check-sequence-access sequence index)
+ (if (consp sequence)
+ (nth index sequence)
+ (aref sequence index)))
+
+(defsetf elt (sequence index) (value)
+ "Set the element of SEQUENCE specified by INDEX."
+ (let ((seq (gensym))
+ (idx (gensym)))
+ `(let ((,seq ,sequence)
+ (,idx ,index))
+ (check-sequence-access ,seq ,idx)
+ (if (consp ,seq)
+ (progn (rplaca (nthcdr ,idx ,seq) ,value) ,value)
+ (setf (aref ,seq ,idx) ,value)))))
+
+(defun reverse (sequence)
+ "Return a new sequence containing the same elements but in reverse order."
+ (check-type sequence proper-sequence)
+ (cond
+ ((null sequence) nil)
+ ((consp sequence) (do ((x sequence (cdr x))
+ (result nil (cons (car x) result)))
+ ((null x) result)))
+ (t (let* ((length (length sequence))
+ (result (make-array length
+ :element-type (array-element-type sequence))))
+ (do ((i 0 (1+ i))
+ (j (1- length) (1- j)))
+ ((>= i length) result)
+ (setf (aref result i) (aref sequence j)))))))
+
+(defun nreverse (sequence)
+ "Modyfy SEQUENCE so that the elements are in reverse order."
+ (check-type sequence proper-sequence)
+ (cond
+ ((null sequence) nil)
+ ((consp sequence) (do ((1st (cdr sequence) (cdr 1st))
+ (2nd sequence 1st)
+ (3rd '() 2nd))
+ ((null 2nd) 3rd)
+ (rplacd 2nd 3rd)))
+ (t (let ((length (length sequence)))
+ (do ((i 0 (1+ i))
+ (j (1- length) (1- j)))
+ ((>= i j) sequence)
+ (rotatef (aref sequence i) (aref sequence j)))))))
+
+(defun count-if (predicate sequence &key from-end (start 0) end key)
+ "Count the number of elements in SEQUENCE which satisfy PREDICATE."
+ (let ((count 0))
+ (do-subsequence (element sequence start end from-end count)
+ (when (funcall predicate (apply-key key element))
+ (incf count)))))
+
+(defun count-if-not (predicate sequence &key from-end (start 0) end key)
+ "Count the number of elements in SEQUENCE which do not satisfy PREDICATE."
+ (count-if (complement predicate)
+ sequence :from-end from-end :start start :end end :key key))
+
+(defun count (item sequence
+ &key from-end (start 0) end key (test #'eql) test-not)
+ "Count the number of ITEM in SEQUENCE bounded by START and END."
+ (when test-not (setq test (complement test-not)))
+ (count-if #'(lambda (arg) (funcall test item arg))
+ sequence :from-end from-end :start start :end end :key key))
+
+(defun find-if (predicate sequence &key from-end (start 0) end key)
+ "Return the first element in SEQUENCE satisfying PREDICATE."
+ (do-subsequence (element sequence start end from-end nil)
+ (when (funcall predicate (apply-key key element))
+ (return element))))
+
+(defun find-if-not (predicate sequence &key from-end (start 0) end key)
+ "Return the first element in SEQUENCE not satisfying PREDICATE."
+ (find-if (complement predicate) sequence
+ :from-end from-end :start start :end end :key key))
+
+(defun find (item sequence
+ &key from-end (test #'eql) test-not (start 0) end key)
+ "Return the first element in SEQUENCE satisfying TEST or TEST-NOT."
+ (when test-not (setq test (complement test-not)))
+ (find-if #'(lambda (arg) (funcall test item arg))
+ sequence :from-end from-end :start start :end end :key key))
+
+(defun position-if (predicate sequence &key from-end (start 0) end key)
+ "Return the position of an element in SEQUENCE satisfying PREDICATE."
+ (unless end (setq end (length sequence)))
+ (let ((i (if from-end (1- end) start))
+ (step (if from-end -1 1)))
+ (do-subsequence (element sequence start end from-end nil)
+ (when (funcall predicate (apply-key key element))
+ (return i))
+ (incf i step))))
+
+(defun position-if-not (predicate sequence &key from-end (start 0) end key)
+ "Return the position of an element in SEQUENCE not satisfying PREDICATE."
+ (position-if (complement predicate) sequence
+ :from-end from-end :start start :end end :key key))
+
+(defun position (item sequence
+ &key from-end (test #'eql) test-not (start 0) end key)
+ "Return the position of an element in SEQUENCE equal to ITEM by TEST."
+ (when test-not (setq test (complement test-not)))
+ (position-if #'(lambda (arg) (funcall test item arg))
+ sequence :from-end from-end :start start :end end :key key))
+
+(defun make-iterator (sequence start end length from-end)
+ (check-subsequence sequence start end)
+ (if (listp sequence)
+ (let* ((head (if from-end
+ (nthcdr (- length end) (reverse sequence))
+ (nthcdr start sequence)))
+ (x head))
+ (values #'(lambda () (prog1 (car x) (setq x (cdr x))))
+ #'(lambda () (setq x head))))
+ (let* ((from (if from-end (1- end) start))
+ (i from)
+ (step (if from-end -1 1)))
+ (values #'(lambda () (prog1 (aref sequence i) (setq i (+ i step))))
+ #'(lambda () (setq i from))))))
+
+(defun search (sequence1 sequence2 &key from-end (test #'eql) test-not key
+ (start1 0) (start2 0) end1 end2)
+ "Return the first position in SEQUENCE2 that matches SEQUENCE1."
+ (when test-not (setq test (complement test-not)))
+ (let* ((length1 (length sequence1))
+ (end1 (or end1 length1))
+ (end2 (or end2 (length sequence2)))
+ (width1 (- end1 start1))
+ (last-match nil))
+ (multiple-value-bind (get1 reset1)
+ (make-iterator sequence1 start1 end1 length1 nil)
+ (etypecase sequence2
+ (null (when (zerop length1) 0))
+ (cons (do ((x (nthcdr start2 sequence2) (cdr x))
+ (i start2 (1+ i)))
+ ((> i (- end2 width1)) (when from-end last-match))
+ (funcall reset1)
+ (do ((xx x (cdr xx))
+ (j 0 (1+ j)))
+ ((>= j width1) (if from-end
+ (setq last-match i)
+ (return-from search i)))
+ (unless (funcall test (apply-key key (funcall get1))
+ (apply-key key (car xx)))
+ (return)))))
+ (vector (do ((i start2 (1+ i)))
+ ((> i (- end2 width1)) (when from-end last-match))
+ (funcall reset1)
+ (do ((ii i (1+ ii))
+ (j 0 (1+ j)))
+ ((>= j width1) (if from-end
+ (setq last-match i)
+ (return-from search i)))
+ (unless (funcall test (apply-key key (funcall get1))
+ (apply-key key (aref sequence2 ii)))
+ (return)))))))))
+
+(defun mismatch (sequence1 sequence2 &key from-end (test #'eql) test-not key
+ (start1 0) (start2 0) end1 end2)
+ "Return the first position where SEQUENCE1 and SEQUENCE2 differ."
+ (when test-not (setq test (complement test-not)))
+ (let* ((length1 (length sequence1))
+ (length2 (length sequence2))
+ (end1 (or end1 length1))
+ (end2 (or end2 length2))
+ (width1 (- end1 start1))
+ (width2 (- end2 start2))
+ (width (min width1 width2))
+ (s1 (if from-end (- end1 width) start1))
+ (e1 (if from-end end1 (+ start1 width))))
+ (multiple-value-bind (get2 reset2)
+ (make-iterator sequence2 start2 end2 length2 from-end)
+ (declare (ignore reset2))
+ (let ((i1 (if from-end (1- end1) start1))
+ (step (if from-end -1 1)))
+ (do-subsequence (element1 sequence1 s1 e1 from-end
+ (cond ((= width1 width2) nil)
+ ((< width1 width2) (if from-end 0 end1))
+ (t (if from-end
+ (- end1 width2)
+ (+ start1 width2)))))
+ (unless (funcall test (apply-key key element1)
+ (apply-key key (funcall get2)))
+ (return (if from-end (1+ i1) i1)))
+ (incf i1 step))))))
+
+(defun replace (sequence1 sequence2 &key (start1 0) end1 (start2 0) end2)
+ "Modify SEQUENCE1 destructively by replacing elements with those of SUBSEQUENCE2."
+ (let* ((length2 (length sequence2))
+ (end1 (or end1 (length sequence1)))
+ (end2 (or end2 length2))
+ (width1 (- end1 start1))
+ (width2 (- end2 start2))
+ (width (min width1 width2))
+ (from-end nil))
+ (when (< start2 start1 (+ start2 width))
+ (setq sequence2 (copy-seq sequence2)))
+ (multiple-value-bind (get2 reset2)
+ (make-iterator sequence2 start2 end2 length2 from-end)
+ (declare (ignore reset2))
+ (do-subsequence (element1 sequence1 start1 (+ start1 width) from-end)
+ (setf element1 (funcall get2)))
+ sequence1)))
+
+
+(defun subseq (sequence start &optional end)
+ "Return a copy of the subsequence of SEQUENCE bounded by START and END."
+ (unless end (setq end (length sequence)))
+ (check-subsequence sequence start end)
+ (etypecase sequence
+ (list (do* ((x (nthcdr start sequence) (cdr x))
+ (i start (1+ i))
+ (result (list nil))
+ (splice result))
+ ((>= i end) (cdr result))
+ (setq splice (cdr (rplacd splice (list (car x)))))))
+ (vector (let* ((width (- end start))
+ (result (make-array width
+ :element-type
+ (array-element-type sequence))))
+ (do ((i 0 (1+ i))
+ (j start (1+ j)))
+ ((>= i width) result)
+ (setf (aref result i) (aref sequence j)))))))
+
+(defsetf subseq (sequence start &optional (end nil)) (new-subsequence)
+ "Replace destructively the subsequence of SEQUENCE with NEW-SUBSEQUENCE."
+ `(progn
+ (check-type ,new-subsequence sequence)
+ (replace ,sequence ,new-subsequence :start1 ,start :end1 ,end)
+ ,new-subsequence))
+
+(defun copy-seq (sequence)
+ "Create a copy of SEQUENCE."
+ (subseq sequence 0))
+
+(defun nsubstitute-if (newitem predicate sequence &key from-end
+ (start 0) end count key)
+ "Modify SEQUENCE substituting NEWITEM for elements satisfying PREDICATE."
+ (when (or (null count) (plusp count))
+ (do-subsequence (element sequence start end from-end)
+ (when (funcall predicate (apply-key key element))
+ (setf element newitem)
+ (when (and count (zerop (setq count (1- count))))
+ (return)))))
+ sequence)
+
+(defun nsubstitute (newitem olditem sequence &key from-end (test #'eql) test-not
+ (start 0) end count key)
+ "Modify SEQUENCE substituting NEWITEM for elements euqal to OLDITEM."
+ (when test-not (setq test (complement test-not)))
+ (nsubstitute-if newitem #'(lambda (item) (funcall test olditem item))
+ sequence :from-end from-end :start start :end end
+ :count count :key key))
+
+(defun nsubstitute-if-not (newitem predicate sequence &key from-end
+ (start 0) end count key)
+ "Modify SEQUENCE substituting NEWITEM for elements not satisfying PREDICATE."
+ (nsubstitute-if newitem (complement predicate) sequence :from-end from-end
+ :start start :end end :count count :key key))
+
+(defun substitute (newitem olditem sequence &key from-end (test #'eql) test-not
+ (start 0) end count key)
+ "Return a copy of SEQUENCE with elements euqal to OLDITEM replaced with NEWITEM."
+ (nsubstitute newitem olditem (copy-seq sequence) :from-end from-end :test test
+ :test-not test-not :start start :end end :count count :key key))
+
+(defun substitute-if (newitem predicate sequence &key from-end (start 0) end
+ count key)
+ "Return a copy of SEQUENCE with elements satisfying PREDICATE replaced with NEWITEM."
+ (nsubstitute-if newitem predicate (copy-seq sequence) :from-end from-end
+ :start start :end end :count count :key key))
+
+(defun substitute-if-not (newitem predicate sequence &key from-end (start 0) end
+ count key)
+ "Return a copy of SEQUENCE with elements not satisfying PREDICATE replaced with NEWITEM."
+ (nsubstitute-if-not newitem predicate (copy-seq sequence) :from-end from-end
+ :start start :end end :count count :key key))
+
+(defun fill (sequence item &key (start 0) end)
+ "Replace the elements of SEQUENCE bounded by START and END with ITEM."
+ (nsubstitute-if item (constantly t) sequence :start start :end end))
+
+(defun concatenate (result-type &rest sequences)
+ "Return a sequence of RESULT-TYPE that have all the elements of SEQUENCES."
+ (cond
+ ((subtypep result-type 'list)
+ (let* ((list (list nil))
+ (splice list))
+ (dolist (seq sequences (cdr list))
+ (do-subsequence (element seq 0)
+ (setq splice (cdr (rplacd splice (cons element nil))))))))
+ ((subtypep result-type 'vector)
+ (let ((vector (make-sequence result-type
+ (apply #'+ (mapcar #'length sequences))))
+ (i 0))
+ (dolist (seq sequences vector)
+ (do-subsequence (element seq 0)
+ (setf (aref vector i) element)
+ (incf i)))))
+ (t
+ (error 'type-error
+ :datum result-type
+ :expected-type '(or null sequence)))))
+
+(defun merge-lists (list1 list2 predicate key)
+ (let* ((list (list nil))
+ (splice list))
+ (do ((x1 list1)
+ (x2 list2))
+ ((or (endp x1) (endp x2)) (rplacd splice (or x1 x2)) (cdr list))
+ (if (funcall predicate (apply-key key (car x2))
+ (apply-key key (car x1)))
+ (setq splice (cdr (rplacd splice x2))
+ x2 (cdr x2))
+ (setq splice (cdr (rplacd splice x1))
+ x1 (cdr x1))))))
+
+(defun merge (result-type sequence1 sequence2 predicate &key key)
+ "Merge SEQUENCE1 with SEQUENCE2 destructively according to an order determined by the PREDICATE."
+ (let ((merged-list (merge-lists (coerce sequence1 'list)
+ (coerce sequence2 'list) predicate key)))
+ (cond ((subtypep result-type 'list) merged-list)
+ ((subtypep result-type 'vector) (coerce merged-list result-type))
+ (t (error 'type-error
+ :datum result-type
+ :expected-type '(or null sequence))))))
+
+(defun quicksort-vector (vector predicate key)
+ (labels ((quicksort (left right)
+ (if (<= right left)
+ vector
+ (let ((v (partition left right)))
+ (quicksort left (1- v))
+ (quicksort (1+ v) right))))
+ (partition (left right)
+ (let ((pivot (apply-key key (aref vector right)))
+ (l left)
+ (r (1- right)))
+ (loop (loop (unless (funcall predicate
+ (apply-key key (aref vector l))
+ pivot)
+ (return))
+ (incf l))
+ (loop (when (or (>= l r)
+ (funcall predicate
+ (apply-key key (aref vector r))
+ pivot))
+ (return))
+ (decf r))
+ (when (>= l r)
+ (return))
+ (rotatef (aref vector l) (aref vector r)))
+ (rotatef (aref vector l) (aref vector right))
+ l)))
+ (quicksort 0 (1- (length vector)))))
+
+(defun sort (sequence predicate &key key)
+ "Sort SEQUENCE destructively according to the order determined by PREDICATE."
+ (if (vectorp sequence)
+ (quicksort-vector sequence predicate key)
+ (let ((vector (quicksort-vector (make-array (length sequence)
+ :initial-contents sequence)
+ predicate key)))
+ (do ((x sequence (cdr x))
+ (i 0 (1+ i)))
+ ((endp x) sequence)
+ (rplaca x (aref vector i))))))
+
+(defun mergesort-list (list predicate key)
+ (labels ((mergesort (list length)
+ (if (<= length 1)
+ list
+ (let* ((length1 (floor (/ length 2)))
+ (length2 (- length length1))
+ (list1 list)
+ (last1 (nthcdr (1- length1) list))
+ (list2 (cdr last1)))
+ (rplacd last1 nil)
+ (merge 'list
+ (mergesort list1 length1) (mergesort list2 length2)
+ predicate :key key)))))
+ (mergesort list (length list))))
+
+(defun stable-sort (sequence predicate &key key)
+ "Sort SEQUENCE destructively guaranteeing the stability of equal elements' order."
+ (if (listp sequence)
+ (mergesort-list sequence predicate key)
+ (let ((list (mergesort-list (coerce sequence 'list) predicate key)))
+ (do ((x list (cdr x))
+ (i 0 (1+ i)))
+ ((endp x) sequence)
+ (setf (aref sequence i) (car x))))))
+
+(defun 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)))))))
+
+(defun 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)))))
+
+(defun 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)))))
+
+(defun 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))
+
+(defun 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))
+
+(defun 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))
+
+(defun 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))
+
+(defun 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))
+
+
+(defun list-delete-duplicates (test list start end key)
+ (check-type list proper-list)
+ (let* ((head (cons nil list))
+ (splice head)
+ (tail (when end (nthcdr end list))))
+ (flet ((list-member (list)
+ (do ((x (cdr list) (cdr x))
+ (item (car list)))
+ ((eq x tail) nil)
+ (when (funcall test (apply-key key item) (apply-key key (car x)))
+ (return t)))))
+ (do ((i 0 (1+ i))
+ (x list (cdr x)))
+ ((endp x) (rplacd splice nil) (cdr head))
+ (unless (and (<= start i) (or (null end) (< i end)) (list-member x))
+ (setq splice (cdr (rplacd splice x))))))))
+
+(defun vector-delete-duplicates (test vector start end key)
+ (let* ((length (length vector))
+ (end (or end length))
+ (i 0))
+ (flet ((vector-member (item j)
+ (do ((k (1+ j) (1+ k)))
+ ((>= k end) nil)
+ (when (funcall test (apply-key key item)
+ (apply-key key (aref vector k)))
+ (return t)))))
+ (do* ((j 0 (1+ j))
+ element)
+ ((>= j length))
+ (setq element (aref vector j))
+ (unless (and (<= start j) (< j end) (vector-member element j))
+ (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))))))
+
+(defun delete-duplicates (sequence &key from-end (test #'eql) test-not
+ (start 0) end key)
+ "Modify SEQUENCE deleting redundant elements."
+ (when test-not (setq test (complement test-not)))
+ (if from-end
+ (let ((length (length sequence)))
+ (nreverse (delete-duplicates (nreverse sequence) :test test :key key
+ :start (- length (or end length))
+ :end (- length start))))
+ (etypecase sequence
+ (null nil)
+ (cons (list-delete-duplicates test sequence start end key))
+ (vector (vector-delete-duplicates test sequence start end key)))))
+
+(defun remove-duplicates (sequence &key from-end (test #'eql) test-not
+ (start 0) end key)
+ "Return a copy of SEQUENCE with redundant elements removed."
+ (delete-duplicates (copy-seq sequence) :from-end from-end :key key
+ :test test :test-not test-not :start start :end end))
+
+(defun reduce (function sequence &key key from-end (start 0) end
+ (initial-value nil initial-value-supplied))
+ "Use a binary operation FUNCTION to combine the elements of SEQUENCE."
+ (unless end (setq end (length sequence)))
+ (check-subsequence sequence start end)
+ (if (= start end)
+ (if initial-value-supplied initial-value (funcall function))
+ (let ((fun (if from-end #'(lambda (a b) (funcall function b a)) function))
+ (value (if initial-value-supplied
+ initial-value
+ (apply-key key (if from-end
+ (elt sequence (decf end))
+ (prog1 (elt sequence start)
+ (incf start)))))))
+ (do-subsequence (element sequence start end from-end value)
+ (setq value (funcall fun value (apply-key key element)))))))
+
+(defmacro do-sequences ((var sequences &optional (result nil)) &body body)
+ (let ((seq-list (gensym))
+ (i (gensym))
+ (min (gensym)))
+ `(let* ((,seq-list (copy-seq ,sequences))
+ (,var (make-list (list-length ,seq-list) :initial-element nil))
+ (,min (if ,seq-list (reduce #'min ,seq-list :key #'length) 0)))
+ (dotimes (,i ,min ,result)
+ (do* ((src ,seq-list (cdr src))
+ (seq (car src) (car src))
+ (dest ,var (cdr dest)))
+ ((null src))
+ (rplaca dest (if (consp seq)
+ (progn
+ (rplaca src (cdr seq))
+ (car seq))
+ (aref seq ,i))))
+ ,@body))))
+
+(defun map-into (result-sequence function &rest sequences)
+ "Modify RESULT-SEQUENCE, applying FUNCTION to the elements of SEQUENCES."
+ (etypecase result-sequence
+ (null nil)
+ (cons (let ((x result-sequence))
+ (do-sequences (args sequences result-sequence)
+ (when (endp x) (return result-sequence))
+ (rplaca x (apply function args))
+ (setq x (cdr x)))))
+ (vector (let ((i 0)
+ (length (array-dimension result-sequence 0)))
+ (do-sequences (args sequences)
+ (when (= i length) (return))
+ (setf (aref result-sequence i) (apply function args))
+ (setq i (1+ i)))
+ (when (array-has-fill-pointer-p result-sequence)
+ (setf (fill-pointer result-sequence) i))
+ result-sequence))))
+
+(defun map (result-type function sequence &rest more-sequences)
+ "Apply FUNCTION to the successive elements of SEQUENCE and MORE-SEQUENCES."
+ (if (null result-type)
+ (do-sequences (args (cons sequence more-sequences) nil)
+ (apply function args))
+ (let* ((sequences (cons sequence more-sequences))
+ (seq (make-sequence result-type
+ (reduce #'min sequences :key #'length))))
+ (apply #'map-into seq function sequences))))
+
+
+(defun every (predicate sequence &rest more-sequences)
+ "Return true if and only if every invocation of PREDICATE on SEQUENCE returns true."
+ (do-sequences (args (cons sequence more-sequences) t)
+ (unless (apply predicate args)
+ (return nil))))
+
+(defun some (predicate sequence &rest more-sequences)
+ "Return true if and only if some invocation of PREDICATE on SEQUENCE returns true."
+ (do-sequences (args (cons sequence more-sequences) nil)
+ (when (apply predicate args)
+ (return t))))
+
+(defun notevery (predicate sequence &rest more-sequences)
+ "Return true if and only if some invocation of PREDICATE on SEQUENCE returns false."
+ (not (apply #'every predicate sequence more-sequences)))
+
+(defun notany (predicate sequence &rest more-sequences)
+ "Return true if and only if every invocation of PREDICATE on SEQUENCE returns false."
+ (not (apply #'some predicate sequence more-sequences)))
diff --git a/Sacla/share.lisp b/Sacla/share.lisp
new file mode 100644
index 0000000..8c9d3e1
--- /dev/null
+++ b/Sacla/share.lisp
@@ -0,0 +1,184 @@
+;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
+;; ALL RIGHTS RESERVED.
+;;
+;; $Id: share.lisp,v 1.10 2004/09/02 06:59:43 yuji Exp $
+;;
+;; 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.
+;;
+;; 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.
+
+(deftype proper-list () '(satisfies proper-list-p))
+(deftype proper-sequence () '(satisfies proper-sequence-p))
+(deftype string-designator () '(or character symbol string))
+(deftype package-designator () '(or string-designator package))
+(deftype function-designator () '(or symbol function))
+(deftype extended-function-designator ()
+ '(or function (satisfies function-name-p)))
+(deftype character-designator-simbol ()
+ '(satisfies character-designator-symbol-p))
+
+(defun character-designator-symbol-p (object)
+ (and (symbolp object) (= (length (symbol-name object)) 1)))
+
+(defun function-name-p (object)
+ (or (symbolp object)
+ (and (consp object)
+ (eq (car object) 'setf)
+ (symbolp (cadr object))
+ (null (cddr object)))))
+
+(defun proper-list-p (object)
+ (when (listp object)
+ (do ((fast object (cddr fast))
+ (slow object (cdr slow)))
+ (nil)
+ (when (atom fast)
+ (return (null fast)))
+ (when (atom (cdr fast))
+ (return (null (cdr fast))))
+ (when (and (eq fast slow) (not (eq fast object)))
+ (return nil)))))
+
+(defun proper-sequence-p (object)
+ (or (vectorp object) (proper-list-p object)))
+
+(defun error-circular-list (list)
+ (error 'type-error :datum list :expected-type 'proper-list))
+
+(defun error-index-too-large (sequence index)
+ (error 'type-error
+ :datum index
+ :expected-type `(integer 0 ,(1- (length sequence)))))
+
+(defmacro apply-key (key element)
+ `(if ,key
+ (funcall ,key ,element)
+ ,element))
+
+
+(defmacro do-sublist ((var list start end from-end result) &body body)
+ (let ((rev (gensym))
+ (i (gensym))
+ (x (gensym)))
+ `(symbol-macrolet ((,var (car ,x)))
+ (if ,from-end
+ (let ((,rev nil))
+ (do ((x (nthcdr ,start ,list) (cdr x))
+ (i ,start (1+ i)))
+ ((>= i ,end))
+ (setq ,rev (cons x ,rev)))
+ (do* ((,rev ,rev (cdr ,rev))
+ (,x (car ,rev) (car ,rev)))
+ ((null ,rev) ,result)
+ ,@body))
+ (do ((,x (nthcdr ,start ,list) (cdr ,x))
+ (,i ,start (1+ ,i)))
+ ((>= ,i ,end) ,result)
+ ,@body)))))
+
+(defmacro do-subvector ((var vector start end from-end result) &body body)
+ (let ((i (gensym))
+ (step (gensym))
+ (limit (gensym)))
+ `(symbol-macrolet ((,var (aref ,vector ,i)))
+ (let ((,step (if ,from-end -1 1))
+ (,limit (if ,from-end (1- ,start) ,end)))
+ (do ((,i (if ,from-end (1- ,end) ,start) (+ ,i ,step)))
+ ((= ,i ,limit) ,result)
+ ,@body)))))
+
+(defmacro do-subsequence ((var sequence-form start-form &optional end-form
+ from-end-form result-form) &body body)
+ (let ((sequence (gensym))
+ (start (gensym))
+ (end (gensym)))
+ `(let* ((,sequence ,sequence-form)
+ (,start ,start-form)
+ (,end (or ,end-form (length ,sequence))))
+ (check-subsequence ,sequence ,start ,end)
+ (etypecase ,sequence
+ (list
+ (do-sublist (,var ,sequence ,start ,end ,from-end-form ,result-form)
+ ,@body))
+ (vector
+ (do-subvector (,var ,sequence ,start ,end ,from-end-form ,result-form)
+ ,@body))))))
+
+(defun declarationp (expr)
+ (and (consp expr) (eq (car expr) 'declare)))
+
+(defun declarations-and-forms (body)
+ (block nil
+ (let ((decls nil)
+ (forms body))
+ (tagbody
+ top
+ (when (not (declarationp (car forms)))
+ (return (values (reverse decls) forms)))
+ (push (car forms) decls) (psetq forms (cdr forms))
+ (go top)))))
+
+
+(defun required-argument ()
+ (error "required argument not specified."))
+
+
+(defun %symbol (designator)
+ (if (symbolp designator)
+ designator
+ (error 'type-error :datum designator :expected-type 'symbol)))
+(defun %keyword (designator)
+ (intern (string designator) "KEYWORD"))
+(defun %list (designator)
+ (if (listp designator)
+ designator
+ (list designator)))
+(defun symbol-list (designator) (mapcar #'%symbol (%list designator)))
+(defun string-list (designator) (mapcar #'string (%list designator)))
+
+
+
+(defun store-value-report (stream place)
+ (format stream "Supply a new value for ~S." place))
+(defun store-value-interactive ()
+ (format *query-io* "~&Type a form to be evaluated:~%")
+ (list (eval (read *query-io*))))
+
+
+
+(defun mapappend (function &rest lists)
+ (apply #'append (apply #'mapcar function lists)))
+
+(define-condition simple-program-error (simple-condition program-error) ())
+
+(define-modify-macro appendf (&rest args)
+ append "Append onto list")
+
+
+(defvar *message-prefix* "")
+;; for debug
+(defvar *error-function* #'error)
+(defun error (datum &rest arguments)
+ (if (stringp datum)
+ (let ((format-control (concatenate 'string *message-prefix* datum)))
+ (apply *error-function* format-control arguments))
+ (apply *error-function* datum arguments)))
diff --git a/Sacla/stand-in.lisp b/Sacla/stand-in.lisp
new file mode 100644
index 0000000..425ae9d
--- /dev/null
+++ b/Sacla/stand-in.lisp
@@ -0,0 +1,44 @@
+;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
+;; ALL RIGHTS RESERVED.
+;;
+;; $Id: stand-in.lisp,v 1.1 2004/07/22 07:47:14 yuji Exp $
+;;
+;; 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.
+;;
+;; 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.
+
+;;; Commentary:
+;; Supply a customized DEFUN which forces replacement of function definitions
+;; even if the target symbol is in the COMMON-LISP package.
+
+(defpackage "STAND-IN"
+ (:shadow "DEFUN")
+ (:use "COMMON-LISP"))
+
+(in-package "STAND-IN")
+
+#+clisp
+(defmacro defun (&rest args)
+ `(handler-bind ((system::simple-package-error (invoke-restart 'continue)))
+ (cl:defun ,@args)))
+#+cmu
+(error "stand-in::defun is not define for cmucl.")
diff --git a/Sacla/stream.lisp b/Sacla/stream.lisp
new file mode 100644
index 0000000..3d78263
--- /dev/null
+++ b/Sacla/stream.lisp
@@ -0,0 +1,106 @@
+;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
+;; ALL RIGHTS RESERVED.
+;;
+;; $Id: stream.lisp,v 1.7 2004/05/26 07:57:52 yuji Exp $
+;;
+;; 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.
+;;
+;; 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.
+
+(defun terpri (&optional output-stream)
+ (write-char #\Newline output-stream)
+ nil)
+
+(defun read-line (&optional input-stream eof-error-p eof-value recursive-p)
+ (let ((str (make-array 160
+ :element-type 'character
+ :fill-pointer 0
+ :adjustable t))
+ char)
+ (loop
+ (setq char (read-char input-stream eof-error-p eof-value recursive-p))
+ (when (eql char eof-value)
+ (return (values str t)))
+ (vector-push-extend char str)
+ (when (char= char #\Newline)
+ (return (values str nil))))))
+
+
+(defun write-string (string &optional output-stream &key (start 0) end)
+ (unless end (setq end (length string)))
+ (do ((i start (1+ i)))
+ ((= i end) string)
+ (write-char (char string i) output-stream)))
+
+(defun write-line (string &optional output-stream &key (start 0) end)
+ (write-string string output-stream :start start :end end)
+ (write-char #\Newline output-stream)
+ string)
+
+(defun read-sequence (sequence stream &key (start 0) end)
+ (let ((pos start)
+ (read-element (if (subtypep (stream-element-type stream) 'character)
+ #'read-char
+ #'read-byte))
+ new)
+ (do-subsequence (element sequence start end nil pos)
+ (unless (setq new (funcall read-element stream))
+ (return pos))
+ (setf element new)
+ (incf pos))))
+
+
+(defun write-sequence (sequence stream &key (start 0) end)
+ (let ((write-element (if (subtypep (stream-element-type stream) 'character)
+ #'write-char
+ #'write-byte)))
+ (do-subsequence (element sequence start end)
+ (funcall write-element element stream))
+ sequence))
+
+
+(defmacro with-open-file ((stream filespec &rest options) &body body)
+ (let ((abortp (gensym)))
+ (multiple-value-bind (decls forms) (declarations-and-forms body)
+ `(let ((,var (open filespec ,@options))
+ (,abortp t))
+ ,@decls
+ (unwind-protect
+ (multiple-value-prog1
+ (progn ,@forms)
+ (setq ,abortp nil))
+ (when ,var
+ (close ,var :abort ,abortp)))))))
+
+(defmacro with-open-stream ((var stream) &body body)
+ (let ((abortp (gensym)))
+ (multiple-value-bind (decls forms) (declarations-and-forms body)
+ `(let ((,var ,stream)
+ (,abortp t))
+ ,@decls
+ (unwind-protect
+ (multiple-value-prog1
+ (progn ,@forms)
+ (setq ,abortp nil))
+ (when ,var
+ (close ,var :abort ,abortp)))))))
+
diff --git a/Sacla/string.lisp b/Sacla/string.lisp
new file mode 100644
index 0000000..f671fb7
--- /dev/null
+++ b/Sacla/string.lisp
@@ -0,0 +1,323 @@
+;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
+;; ALL RIGHTS RESERVED.
+;;
+;; $Id: string.lisp,v 1.5 2004/02/20 07:23:42 yuji Exp $
+;;
+;; 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.
+;;
+;; 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.
+
+
+(defun stringp (object)
+ "Return true if OBJECT is of type string; otherwise, return false."
+ (and (vectorp object)
+ (subtypep (array-element-type object) 'character)))
+
+(defun simple-string-p (object)
+ "Return true if OBJECT is of type simple-string; otherwise, returns false."
+ (and (stringp object)
+ (typep object 'simple-array)))
+
+
+(defun string (x)
+ "Return a string described by X; X can be a string, a symbol, or a character."
+ (etypecase x
+ (string x)
+ (symbol (symbol-name x))
+ (character (make-array 1 :element-type 'character :initial-element x))))
+
+(defun string-upcase (string &key (start 0) end)
+ "Return a copy of STRING upcasing all lowercase chars between START and END."
+ (unless (stringp string)
+ (setq string (string string)))
+ (unless end
+ (setq end (length string)))
+ (let ((str (make-array (length string)
+ :element-type 'character
+ :initial-contents string)))
+ (do ((i start (1+ i)))
+ ((>= i end) str)
+ (setf (schar str i) (char-upcase (schar str i))))))
+
+(defun string-downcase (string &key (start 0) end)
+ "Return a copy of STRING downcasing all uppercase chars between START and END."
+ (unless (stringp string)
+ (setq string (string string)))
+ (unless end
+ (setq end (length string)))
+ (let ((str (make-array (length string)
+ :element-type 'character
+ :initial-contents string)))
+ (do ((i start (1+ i)))
+ ((>= i end) str)
+ (setf (schar str i) (char-downcase (schar str i))))))
+
+
+(defun string-capitalize (string &key (start 0) end)
+ "Return a copy of STRING capitalizing all words between START and END."
+ (unless (stringp string)
+ (setq string (string string)))
+ (unless end
+ (setq end (length string)))
+ (let ((str (make-array (length string)
+ :element-type 'character
+ :initial-contents string))
+ (in-a-word nil))
+ (do ((i start (1+ i))
+ c)
+ ((>= i end) str)
+ (setq c (schar str i))
+ (if (alphanumericp c)
+ (if in-a-word
+ (setq c (char-downcase c))
+ (setq c (char-upcase c)
+ in-a-word t))
+ (when in-a-word
+ (setq in-a-word nil)))
+ (setf (schar str i) c))))
+
+
+(defun nstring-upcase (string &key (start 0) end)
+ "Modify STRING to make all lowercase chars between START and END uppercase."
+ (unless end
+ (setq end (length string)))
+ (do ((i start (1+ i)))
+ ((>= i end) string)
+ (setf (char string i) (char-upcase (char string i)))))
+
+
+(defun nstring-downcase (string &key (start 0) end)
+ "Modify STRING to make all uppercase chars between START and END lowercase."
+ (unless end
+ (setq end (length string)))
+ (do ((i start (1+ i)))
+ ((>= i end) string)
+ (setf (char string i) (char-downcase (char string i)))))
+
+(defun nstring-capitalize (string &key (start 0) end)
+ "Modify STRING capitalizing all words between START and END."
+ (unless end
+ (setq end (length string)))
+ (do ((i start (1+ i))
+ (in-a-word nil)
+ c)
+ ((>= i end) string)
+ (setq c (char string i))
+ (if (alphanumericp c)
+ (if in-a-word
+ (setq c (char-downcase c))
+ (setq c (char-upcase c)
+ in-a-word t))
+ (when in-a-word
+ (setq in-a-word nil)))
+ (setf (char string i) c)))
+
+
+(defun string-left-trim (character-bag string)
+ "Return a copy of STRING stripping chars in CHARACTER-BAG off the beginning."
+ (unless (stringp string)
+ (setq string (string string)))
+ (dotimes (i (length string) (make-string 0 :element-type 'character))
+ (unless (find (char string i) character-bag)
+ (return (subseq string i)))))
+
+(defun string-right-trim (character-bag string)
+ "Return a copy of STRING stripping chars in CHARACTER-BAG off the end."
+ (unless (stringp string)
+ (setq string (string string)))
+ (do ((i (1- (length string)) (1- i)))
+ ((minusp i) (make-string 0 :element-type 'character))
+ (unless (find (char string i) character-bag)
+ (return (subseq string 0 (1+ i))))))
+
+(defun string-trim (character-bag string)
+ "Return a copy of STRING stripping chars in CHARACTER-BAG off the both ends."
+ (string-left-trim character-bag (string-right-trim character-bag string)))
+
+
+
+(defun string= (string1 string2 &key (start1 0) end1 (start2 0) end2)
+ "Return true if the specified substrings are the same in terms of char=."
+ (unless (stringp string1) (setq string1 (string string1)))
+ (unless (stringp string2) (setq string2 (string string2)))
+ (unless end1 (setq end1 (length string1)))
+ (unless end2 (setq end2 (length string2)))
+ (when (= (- end1 start1) (- end2 start2))
+ (do ((i1 start1 (1+ i1))
+ (i2 start2 (1+ i2)))
+ ((= i1 end1) t)
+ (unless (char= (char string1 i1) (char string2 i2))
+ (return nil)))))
+
+(defun string-equal (string1 string2 &key (start1 0) end1 (start2 0) end2)
+ "Return true if the specified substrings are the same in terms of char-equal."
+ (unless (stringp string1) (setq string1 (string string1)))
+ (unless (stringp string2) (setq string2 (string string2)))
+ (unless end1 (setq end1 (length string1)))
+ (unless end2 (setq end2 (length string2)))
+ (when (= (- end1 start1) (- end2 start2))
+ (do ((i1 start1 (1+ i1))
+ (i2 start2 (1+ i2)))
+ ((= i1 end1) t)
+ (unless (char-equal (char string1 i1) (char string2 i2))
+ (return nil)))))
+
+
+(defun string/= (string1 string2 &key (start1 0) end1 (start2 0) end2)
+ "Return true if the specified substrings are not the same in terms of char=."
+ (unless (stringp string1) (setq string1 (string string1)))
+ (unless (stringp string2) (setq string2 (string string2)))
+ (unless end1 (setq end1 (length string1)))
+ (unless end2 (setq end2 (length string2)))
+ (do ((i1 start1 (1+ i1))
+ (i2 start2 (1+ i2)))
+ ((or (= i1 end1) (= i2 end2)) (if (and (= i1 end1) (= i2 end2)) nil i1))
+ (unless (char= (char string1 i1) (char string2 i2))
+ (return i1))))
+
+(defun string-not-equal (string1 string2 &key (start1 0) end1 (start2 0) end2)
+ "Return true if the specified substrs aren't the same in terms of char-equal."
+ (unless (stringp string1) (setq string1 (string string1)))
+ (unless (stringp string2) (setq string2 (string string2)))
+ (unless end1 (setq end1 (length string1)))
+ (unless end2 (setq end2 (length string2)))
+ (do ((i1 start1 (1+ i1))
+ (i2 start2 (1+ i2)))
+ ((or (= i1 end1) (= i2 end2)) (if (and (= i1 end1) (= i2 end2)) nil i1))
+ (unless (char-equal (char string1 i1) (char string2 i2))
+ (return i1))))
+
+
+(defun string< (string1 string2 &key (start1 0) end1 (start2 0) end2)
+ "Return true if substring1 is less than substring2 in terms of char<."
+ (unless (stringp string1) (setq string1 (string string1)))
+ (unless (stringp string2) (setq string2 (string string2)))
+ (unless end1 (setq end1 (length string1)))
+ (unless end2 (setq end2 (length string2)))
+ (do ((i1 start1 (1+ i1))
+ (i2 start2 (1+ i2)))
+ ((or (= i1 end1) (= i2 end2)) (when (and (= i1 end1) (/= i2 end2)) end1))
+ (unless (char= (char string1 i1) (char string2 i2))
+ (return (if (char< (char string1 i1) (char string2 i2)) i1 nil)))))
+
+(defun string-lessp (string1 string2 &key (start1 0) end1 (start2 0) end2)
+ "Return true if substring1 is less than substring2 in terms of char-lessp."
+ (unless (stringp string1) (setq string1 (string string1)))
+ (unless (stringp string2) (setq string2 (string string2)))
+ (unless end1 (setq end1 (length string1)))
+ (unless end2 (setq end2 (length string2)))
+ (do ((i1 start1 (1+ i1))
+ (i2 start2 (1+ i2)))
+ ((or (= i1 end1) (= i2 end2)) (when (and (= i1 end1) (/= i2 end2)) end1))
+ (unless (char-equal (char string1 i1) (char string2 i2))
+ (return (if (char-lessp (char string1 i1) (char string2 i2)) i1 nil)))))
+
+
+(defun string> (string1 string2 &key (start1 0) end1 (start2 0) end2)
+ "Return true if substring1 is greater than substring2 in terms of char>."
+ (unless (stringp string1) (setq string1 (string string1)))
+ (unless (stringp string2) (setq string2 (string string2)))
+ (unless end1 (setq end1 (length string1)))
+ (unless end2 (setq end2 (length string2)))
+ (do ((i1 start1 (1+ i1))
+ (i2 start2 (1+ i2)))
+ ((or (= i1 end1) (= i2 end2)) (when (and (/= i1 end1) (= i2 end2)) i1))
+ (unless (char= (char string1 i1) (char string2 i2))
+ (return (if (char> (char string1 i1) (char string2 i2)) i1 nil)))))
+
+(defun string-greaterp (string1 string2 &key (start1 0) end1 (start2 0) end2)
+ "Return true if substr1 is greater than substr2 in terms of char-greaterp."
+ (unless (stringp string1) (setq string1 (string string1)))
+ (unless (stringp string2) (setq string2 (string string2)))
+ (unless end1 (setq end1 (length string1)))
+ (unless end2 (setq end2 (length string2)))
+ (do ((i1 start1 (1+ i1))
+ (i2 start2 (1+ i2)))
+ ((or (= i1 end1) (= i2 end2)) (when (and (/= i1 end1) (= i2 end2)) i1))
+ (unless (char-equal (char string1 i1) (char string2 i2))
+ (return (if (char-greaterp (char string1 i1) (char string2 i2))
+ i1
+ nil)))))
+
+
+(defun string<= (string1 string2 &key (start1 0) end1 (start2 0) end2)
+ "Return true if substr1 is less than or equal to subst2 in terms of char<=."
+ (unless (stringp string1) (setq string1 (string string1)))
+ (unless (stringp string2) (setq string2 (string string2)))
+ (unless end1 (setq end1 (length string1)))
+ (unless end2 (setq end2 (length string2)))
+ (do ((i1 start1 (1+ i1))
+ (i2 start2 (1+ i2)))
+ ((or (= i1 end1) (= i2 end2)) (when (= i1 end1) end1))
+ (unless (char= (char string1 i1) (char string2 i2))
+ (return (if (char<= (char string1 i1) (char string2 i2)) i1 nil)))))
+
+(defun string-not-greaterp (string1 string2 &key
+ (start1 0) end1 (start2 0) end2)
+ "Return true if substr1 is not greater than subst2 in terms of char-not-greaterp."
+ (unless (stringp string1) (setq string1 (string string1)))
+ (unless (stringp string2) (setq string2 (string string2)))
+ (unless end1 (setq end1 (length string1)))
+ (unless end2 (setq end2 (length string2)))
+ (do ((i1 start1 (1+ i1))
+ (i2 start2 (1+ i2)))
+ ((or (= i1 end1) (= i2 end2)) (when (= i1 end1) end1))
+ (unless (char-equal (char string1 i1) (char string2 i2))
+ (return (if (char-not-greaterp (char string1 i1) (char string2 i2))
+ i1
+ nil)))))
+
+
+(defun string>= (string1 string2 &key (start1 0) end1 (start2 0) end2)
+ "Return true if substr1 is greater than or equal to subst2 in terms of char>=."
+ (unless (stringp string1) (setq string1 (string string1)))
+ (unless (stringp string2) (setq string2 (string string2)))
+ (unless end1 (setq end1 (length string1)))
+ (unless end2 (setq end2 (length string2)))
+ (do ((i1 start1 (1+ i1))
+ (i2 start2 (1+ i2)))
+ ((or (= i1 end1) (= i2 end2)) (unless (and (= i1 end1) (/= i2 end2)) i1))
+ (unless (char= (char string1 i1) (char string2 i2))
+ (return (if (char>= (char string1 i1) (char string2 i2)) i1 nil)))))
+
+
+(defun string-not-lessp (string1 string2 &key (start1 0) end1 (start2 0) end2)
+ "Return true if substr1 is not less than subst2 in terms of char-not-lessp."
+ (unless (stringp string1) (setq string1 (string string1)))
+ (unless (stringp string2) (setq string2 (string string2)))
+ (unless end1 (setq end1 (length string1)))
+ (unless end2 (setq end2 (length string2)))
+ (do ((i1 start1 (1+ i1))
+ (i2 start2 (1+ i2)))
+ ((or (= i1 end1) (= i2 end2)) (unless (and (= i1 end1) (/= i2 end2)) i1))
+ (unless (char-equal (char string1 i1) (char string2 i2))
+ (return (if (char-not-lessp (char string1 i1) (char string2 i2))
+ i1
+ nil)))))
+
+
+
+(defun make-string (size &key
+ (initial-element #\Space)
+ (element-type 'character))
+ "Return a simple string of SIZE, ELEMENT-TYPE initialized to INITIAL-ELEMENT."
+ (make-array size :element-type element-type :initial-element initial-element))
diff --git a/Sacla/symbol.lisp b/Sacla/symbol.lisp
new file mode 100644
index 0000000..f508704
--- /dev/null
+++ b/Sacla/symbol.lisp
@@ -0,0 +1,102 @@
+;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
+;; ALL RIGHTS RESERVED.
+;;
+;; $Id: symbol.lisp,v 1.8 2004/02/20 07:23:42 yuji Exp $
+;;
+;; 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.
+;;
+;; 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.
+
+(defun keywordp (object)
+ "Return true if OBJECT is a keyword; otherwise, return false."
+ (and (symbolp object)
+ (symbol-package object)
+ (eq (symbol-package object)
+ (find-package "KEYWORD"))))
+
+(defun copy-symbol (symbol &optional copy-properties)
+ "Returns a fresh, uninterned symbol whose name is string= to SYMBOL's."
+ (let ((copy (make-symbol (symbol-name symbol))))
+ (when copy-properties
+ (when (boundp symbol)
+ (setf (symbol-value copy) (symbol-value symbol)))
+ (when (fboundp symbol)
+ (setf (symbol-function copy) (symbol-function symbol)))
+ (setf (symbol-plist copy) (copy-list (symbol-plist symbol))))
+ copy))
+
+
+(defun counter-to-str (x)
+ (flet ((digit-to-str (digit)
+ (string (char "0123456789" digit))))
+ (do* ((x x (floor x 10))
+ (digits (list (digit-to-str (mod x 10)))
+ (cons (digit-to-str (mod x 10)) digits)))
+ ((zerop (floor x 10)) (apply #'concatenate
+ 'string
+ digits)))))
+
+;;(defvar *gensym-counter* 0
+;; "Counter for generating unique GENSYM symbols.")
+;;
+;;(defun gensym (&optional (x "G"))
+;; "Return a fresh, uninterned symbol whose name is determined using X."
+;; (multiple-value-bind (prefix index)
+;; (etypecase x
+;; ((integer 0) (values "G" x))
+;; ((string) (multiple-value-prog1
+;; (values x *gensym-counter*)
+;; (setq *gensym-counter* (1+ *gensym-counter*)))))
+;; (make-symbol (concatenate 'string prefix (counter-to-str index)))))
+
+(defvar *gentemp-counter* 0)
+
+(defun gentemp (&optional (prefix "T") (package *package*))
+ "Return a fresh symbol, newly interned in PACKAGE."
+ (flet ((make-name (prefix)
+ (prog1
+ (concatenate 'string
+ prefix
+ (counter-to-str *gentemp-counter*))
+ (setq *gentemp-counter* (1+ *gentemp-counter*)))))
+ (do ((name (make-name prefix) (make-name prefix)))
+ (nil)
+ (multiple-value-bind (symbol status)
+ (find-symbol name package)
+ (declare (ignore symbol))
+ (when (eq status nil)
+ (return (intern name package)))))))
+
+(defsetf symbol-value
+ set
+ "Change the contents of the value cell of symbol to the given value.")
+
+(defun get (symbol indicator &optional default)
+ (getf (symbol-plist symbol) indicator default))
+
+(defsetf get (symbol indicator &optional default) (value)
+ `(setf (getf (symbol-plist ,symbol) ,indicator ,default) ,value))
+
+
+(defun remprop (symbol indicator)
+ (remf (symbol-plist symbol) indicator))
+
diff --git a/Sacla/testbed.lisp b/Sacla/testbed.lisp
new file mode 100644
index 0000000..6d5e54a
--- /dev/null
+++ b/Sacla/testbed.lisp
@@ -0,0 +1,217 @@
+;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
+;; ALL RIGHTS RESERVED.
+;;
+;; $Id: testbed.lisp,v 1.4 2004/09/02 06:59:43 yuji Exp $
+;;
+;; 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.
+;;
+;; 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.
+
+(defpackage "TESTBED"
+ (:nicknames "TB")
+ (:shadow "DEFMACRO" "DEFINE-CONDITION")
+ (:use "COMMON-LISP"))
+
+(in-package "TESTBED")
+
+(defun shadow-cl-symbol (name &optional type)
+ (multiple-value-bind (cl-symbol status) (find-symbol name "CL")
+ (when (eq status :external)
+ (let ((symbol (progn (shadow name) (intern name "TB"))))
+ ;; type
+ (when (and (not (eq type :condition))
+ (or (member cl-symbol
+ '(not and mod satisfies eql not values member or))
+ (subtypep cl-symbol t))
+ (not (member cl-symbol '(error))))
+ (eval `(deftype ,symbol (&rest rest)
+ (if rest
+ (cons ',cl-symbol rest)
+ ',cl-symbol))))
+ ;; function
+ (when (and (not (eq type :function)) (fboundp cl-symbol)
+ (not (fboundp symbol)))
+ (setf (symbol-function symbol) (symbol-function cl-symbol)))
+ ;; variable
+ (when (and (not (eq type :variable)) (boundp cl-symbol)
+ (not (boundp symbol)))
+ (setf (symbol-value symbol) (symbol-value cl-symbol)))
+ ;; (setf name)
+ (when (and (not (eq type :setf)) (fboundp `(setf ,cl-symbol))
+ (not (fboundp `(setf ,symbol))))
+ (setf (fdefinition `(setf ,symbol)) (fdefinition `(setf ,cl-symbol)))))
+ t)))
+
+(defvar *testbed-compile* nil)
+
+(cl:defmacro defmacro (symbol &rest rest)
+ "testbed::defmacro"
+ (let ((name (symbol-name symbol)))
+ (shadow-cl-symbol name :function)
+ (cond
+ ((string= name "DEFINE-CONDITION")
+ `(cl:defmacro new-define-condition ,@rest))
+ (t `(progn
+ (cl:defmacro ,(intern name) ,@rest)
+ #-cmu
+ (when *testbed-compile*
+ (compile ',(intern name))) ;; cmucl 18e fails
+ )))))
+
+(cl:defmacro define-condition (symbol parent-types &rest rest)
+ (let ((name (symbol-name symbol)))
+ (shadow-cl-symbol name :condition)
+ (if (fboundp 'new-define-condition)
+ `(new-define-condition ,(intern name) ,parent-types ,@rest)
+ (progn
+ (setq parent-types (cond
+ ((null parent-types) (list (intern "CONDITION")))
+ (t parent-types)))
+ `(cl:define-condition ,(intern name) ,parent-types ,@rest)))))
+
+(defmacro defvar (symbol &rest rest)
+ "testbed::defvar"
+ (let ((name (symbol-name symbol)))
+ (shadow-cl-symbol name :variable)
+ `(cl:defvar ,(intern name) ,@rest)))
+
+(defmacro defun (function-name &rest rest)
+ "testbed::defun"
+ (if (symbolp function-name)
+ (let ((name (symbol-name function-name)))
+ (shadow-cl-symbol name :function)
+ `(progn
+ (cl:defun ,(intern name) ,@rest)
+ (when *testbed-compile*
+ (compile ',(intern name)))))
+ `(cl:defun (setf ,(cadr function-name)) ,@rest)))
+
+(defmacro defsetf (symbol &rest rest)
+ "testbed::defsetf"
+ (let ((name (symbol-name symbol)))
+ (shadow-cl-symbol name :setf)
+ (fmakunbound `(setf ,(intern name)))
+ `(cl:defsetf ,(intern name) ,@rest)))
+
+(defmacro define-setf-expander (symbol &rest rest)
+ "testbed::define-setf-expander"
+ (let ((name (symbol-name symbol)))
+ (shadow-cl-symbol name :setf)
+ (fmakunbound `(setf ,(intern name)))
+ `(cl:define-setf-expander ,(intern name) ,@rest)))
+
+(defun clone-package-system ()
+ (error "clone-package-system is not defined in testbed.lisp."))
+
+(defun ld (name)
+ (cond
+ ((string= name "cons")
+ ;;(shadow '("CONS" "CONSP" "CAR" "CDR"))
+ )
+ ((string= name "hash-table")
+ (shadow '("HASH-TABLE" "HASH-TABLE-P" "HASH-TABLE-COUNT"
+ "HASH-TABLE-REHASH-SIZE" "HASH-TABLE-REHASH-THRESHOLD"
+ "HASH-TABLE-SIZE" "HASH-TABLE-TEST") "TB"))
+ ((string= name "package") ; needs hash-table
+ (shadow '("PACKAGE" "PACKAGEP" "MAKE-PACKAGE" "FIND-PACKAGE"
+ "SHADOWING-IMPORT" "IMPORT" "USE-PACKAGE" "*PACKAGE*"
+ "DELETE-PACKAGE" "EXPORT") "TB")
+ (defun symbol-package (symbol)
+ (get symbol 'symbol-package))
+
+ (defsetf symbol-package (symbol) (new-package)
+ `(setf (get ,symbol 'symbol-package) ,new-package))
+ )
+ ((string= name "loop") ; needs hash-table and package
+ )
+ ((string= name "condition")
+ (shadow '("CONDITION"
+ "BREAK" "ASSERT"
+ "CERROR" "ERROR" "SIGNAL" "WARN"
+
+ "TYPE-ERROR-DATUM" "TYPE-ERROR-EXPECTED-TYPE"
+ "PACKAGE-ERROR-PACKAGE" "PRINT-NOT-READABLE-OBJECT"
+ "FILE-ERROR-PATHNAME" "STREAM-ERROR-STREAM"
+ "CELL-ERROR-NAME" "UNBOUND-SLOT-INSTANCE"
+ "ARITHMETIC-ERROR-OPERATION" "ARITHMETIC-ERROR-OPERANDS"
+ "SIMPLE-CONDITION-FORMAT-CONTROL"
+ "SIMPLE-CONDITION-FORMAT-ARGUMENTS"
+
+ "CHECK-TYPE" "HANDLER-BIND" "HANDLER-CASE"
+ "INVOKE-RESTART" "RESTART" "MAKE-RESTART"
+ "RESTART-NAME" "RESTART-FUNCTION" "RESTART-REPORT-FUNCTION"
+ "RESTART-INTERACTIVE-FUNCTION" "RESTART-TEST-FUNCTION"
+ "RESTART-CASE" "RESTART-BIND"
+ "ABORT" "MUFFLE-WARNING" "CONTINUE" "STORE-VALUE" "USE-VALUE"
+ )
+ "TB")
+
+ (eval `(cl:define-condition ,(intern "CONDITION") (cl:condition) ()))
+
+ )
+ ((string= name "reader")
+ (shadow '("READTABLE" "READTABLEP" "READTABLE-CASE" "*READTABLE*"
+ "READER-ERROR") "TB"))
+ ((string= name "printer") ; needs reader
+ (shadow '("PRINT-OBJECT")))
+ ((string= name "sequence")
+ (shadow '("SEARCH")))
+ ((string= name "clos")
+ )
+ )
+ (let ((*package* (find-package "TESTBED")))
+ (funcall #'load (concatenate 'string cl-user::*sacla-lisp-dir* "/" name))
+
+ (cond
+ ((string= name "package")
+ (format t "~%Cloning the package system!~%")
+ (clone-package-system))
+ ((string= name "loop")
+ )))
+ )
+
+(defun test (name)
+ (let ((tests (with-open-file (in (concatenate 'string
+ cl-user::*sacla-lisp-tests-dir*
+ "/" name ".lisp"))
+ (loop for sexp = (read in nil)
+ while sexp
+ collect sexp))))
+ (format t "Testing ~d tests in ~S~%" (length tests) name)
+ (do* ((count 1 (1+ count))
+ (failed 0)
+ (skipped 0)
+ (err nil nil)
+ (tests tests (cdr tests)))
+ ((null tests)
+ (format t "~%All = ~d~%OK = ~d~%Skipped = ~d~%Failed = ~d~%"
+ (1- count) (- count 1 skipped failed) skipped failed)
+ (return (zerop failed)))
+ (format t "~d " count)
+ (case (handler-case (eval (first tests)) (error (e) (setq err e) nil))
+ ((nil)
+ (format t "Failed : ~S~%" (first tests))
+ (when err (print err))
+ (incf failed))
+ (skipped
+ (format t "Skipped ")
+ (incf skipped))))))
diff --git a/Sacla/tests/ansi-tests.lisp b/Sacla/tests/ansi-tests.lisp
new file mode 100644
index 0000000..5245a61
--- /dev/null
+++ b/Sacla/tests/ansi-tests.lisp
@@ -0,0 +1,89 @@
+;; Copyright (C) 2004 Yuji Minejima <ggb01164@nifty.ne.jp>
+;; ALL RIGHTS RESERVED.
+;;
+;; $Id: ansi-tests.lisp,v 1.3 2004/09/28 01:53:23 yuji Exp $
+;;
+;; 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.
+;;
+;; 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.
+
+;;; Commentary:
+
+;; Support routines for Paul Dietz's ANSI testsuite.
+;;
+;; When testing loop.lisp, do the following.
+;; (load "loop.lisp")
+;; (load "tests/ansi-tests.lisp")
+;; (in-package "CL-TEST")
+;; (shadowing-import '(sacla-loop:loop sacla-loop:loop-finish))
+
+
+(defpackage "CL-TEST"
+ (:use "COMMON-LISP"))
+
+(in-package "CL-TEST")
+
+(defmacro deftest (name form &rest values)
+ `(equal (multiple-value-list ,form) ',values))
+
+
+
+;;;; from ansi-aux.lsp of GCL's ANSI-TESTS
+;;;; Author: Paul Dietz
+;;;; Created: Sat Mar 28 17:10:18 1998
+;;;; License: GPL
+(defmacro classify-error* (form)
+"Evaluate form in safe mode, returning its value if there is no error.
+If an error does occur, return a symbol classify the error, or allow
+the condition to go uncaught if it cannot be classified."
+`(locally (declare (optimize (safety 3)))
+ (handler-case ,form
+ (undefined-function () 'undefined-function)
+ (program-error () 'program-error)
+ (package-error () 'package-error)
+ (type-error () 'type-error)
+ (control-error () 'control-error)
+ (stream-error () 'stream-error)
+ (reader-error () 'reader-error)
+ (file-error () 'file-error)
+ (control-error () 'control-error)
+ (cell-error () 'cell-error)
+ (error () 'error)
+ )))
+
+(defun classify-error** (form)
+ (handler-bind ((warning #'(lambda (c) (declare (ignore c))
+ (muffle-warning))))
+ (classify-error* (eval form))))
+
+(defmacro classify-error (form)
+ `(classify-error** ',form))
+
+(defun notnot (x) (not (not x)))
+(defun eqlt (x y)
+ "Like EQL, but guaranteed to return T for true."
+ (apply #'values (mapcar #'notnot (multiple-value-list (eql x y)))))
+(defun equalt (x y)
+ "Like EQUAL, but guaranteed to return T for true."
+ (apply #'values (mapcar #'notnot (multiple-value-list (equal x y)))))
+(defun symbol< (x &rest args)
+ (apply #'string< (symbol-name x) (mapcar #'symbol-name args)))
diff --git a/Sacla/tests/desirable-printer.lisp b/Sacla/tests/desirable-printer.lisp
new file mode 100644
index 0000000..7ccee09
--- /dev/null
+++ b/Sacla/tests/desirable-printer.lisp
@@ -0,0 +1,223 @@
+;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
+;; ALL RIGHTS RESERVED.
+;;
+;; $Id: desirable-printer.lisp,v 1.4 2004/02/20 07:23:42 yuji Exp $
+;;
+;; 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.
+;;
+;; 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.
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :upcase)
+ (string= (write-to-string '|ZEBRA| :pretty nil :readably t :case :upcase)
+ "ZEBRA"))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :upcase)
+ (string= (write-to-string '|Zebra| :pretty nil :readably t :case :upcase)
+ "|Zebra|"))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :upcase)
+ (string= (write-to-string '|zebra| :pretty nil :readably t :case :upcase)
+ "|zebra|"))
+
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :upcase)
+ (string= (write-to-string '|ZEBRA| :pretty nil :readably t :case :downcase)
+ "zebra"))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :upcase)
+ (string= (write-to-string '|Zebra| :pretty nil :readably t :case :downcase)
+ "|Zebra|"))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :upcase)
+ (string= (write-to-string '|zebra| :pretty nil :readably t :case :downcase)
+ "|zebra|"))
+
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :upcase)
+ (string= (write-to-string '|ZEBRA| :pretty nil :readably t :case :capitalize)
+ "Zebra"))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :upcase)
+ (string= (write-to-string '|Zebra| :pretty nil :readably t :case :capitalize)
+ "|Zebra|"))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :upcase)
+ (string= (write-to-string '|zebra| :pretty nil :readably t :case :capitalize)
+ "|zebra|"))
+
+;;
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :downcase)
+ (string= (write-to-string '|ZEBRA| :pretty nil :readably t :case :upcase)
+ "|ZEBRA|"))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :downcase)
+ (string= (write-to-string '|Zebra| :pretty nil :readably t :case :upcase)
+ "|Zebra|"))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :downcase)
+ (string= (write-to-string '|zebra| :pretty nil :readably t :case :upcase)
+ "ZEBRA"))
+
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :downcase)
+ (string= (write-to-string '|ZEBRA| :pretty nil :readably t :case :downcase)
+ "|ZEBRA|"))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :downcase)
+ (string= (write-to-string '|Zebra| :pretty nil :readably t :case :downcase)
+ "|Zebra|"))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :downcase)
+ (string= (write-to-string '|zebra| :pretty nil :readably t :case :downcase)
+ "zebra"))
+
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :downcase)
+ (string= (write-to-string '|ZEBRA| :pretty nil :readably t :case :capitalize)
+ "|ZEBRA|"))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :downcase)
+ (string= (write-to-string '|Zebra| :pretty nil :readably t :case :capitalize)
+ "|Zebra|"))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :downcase)
+ (string= (write-to-string '|zebra| :pretty nil :readably t :case :capitalize)
+ "Zebra"))
+
+
+;;
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :preserve)
+ (string= (write-to-string '|ZEBRA| :pretty nil :readably t :case :upcase)
+ "ZEBRA"))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :preserve)
+ (string= (write-to-string '|Zebra| :pretty nil :readably t :case :upcase)
+ "Zebra"))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :preserve)
+ (string= (write-to-string '|zebra| :pretty nil :readably t :case :upcase)
+ "zebra"))
+
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :preserve)
+ (string= (write-to-string '|ZEBRA| :pretty nil :readably t :case :downcase)
+ "ZEBRA"))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :preserve)
+ (string= (write-to-string '|Zebra| :pretty nil :readably t :case :downcase)
+ "Zebra"))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :preserve)
+ (string= (write-to-string '|zebra| :pretty nil :readably t :case :downcase)
+ "zebra"))
+
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :preserve)
+ (string= (write-to-string '|ZEBRA| :pretty nil :readably t :case :capitalize)
+ "ZEBRA"))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :preserve)
+ (string= (write-to-string '|Zebra| :pretty nil :readably t :case :capitalize)
+ "Zebra"))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :preserve)
+ (string= (write-to-string '|zebra| :pretty nil :readably t :case :capitalize)
+ "zebra"))
+
+
+;;
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :invert)
+ (string= (write-to-string '|ZEBRA| :pretty nil :readably t :case :upcase)
+ "zebra"))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :invert)
+ (string= (write-to-string '|Zebra| :pretty nil :readably t :case :upcase)
+ "Zebra"))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :invert)
+ (string= (write-to-string '|zebra| :pretty nil :readably t :case :upcase)
+ "ZEBRA"))
+
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :invert)
+ (string= (write-to-string '|ZEBRA| :pretty nil :readably t :case :downcase)
+ "zebra"))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :invert)
+ (string= (write-to-string '|Zebra| :pretty nil :readably t :case :downcase)
+ "Zebra"))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :invert)
+ (string= (write-to-string '|zebra| :pretty nil :readably t :case :downcase)
+ "ZEBRA"))
+
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :invert)
+ (string= (write-to-string '|ZEBRA| :pretty nil :readably t :case :capitalize)
+ "zebra"))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :invert)
+ (string= (write-to-string '|Zebra| :pretty nil :readably t :case :capitalize)
+ "Zebra"))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :invert)
+ (string= (write-to-string '|zebra| :pretty nil :readably t :case :capitalize)
+ "ZEBRA"))
+
+
diff --git a/Sacla/tests/must-array.lisp b/Sacla/tests/must-array.lisp
new file mode 100644
index 0000000..205f577
--- /dev/null
+++ b/Sacla/tests/must-array.lisp
@@ -0,0 +1,2297 @@
+;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
+;; ALL RIGHTS RESERVED.
+;;
+;; $Id: must-array.lisp,v 1.9 2004/08/09 02:49:54 yuji Exp $
+;;
+;; 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.
+;;
+;; 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.
+
+(arrayp (make-array nil))
+(arrayp (make-array 10))
+(vectorp (make-array 10))
+(arrayp (make-array '(1 2)))
+(arrayp (make-array '(1 2 3)))
+(arrayp (make-array '(1 2 3 4)))
+(arrayp (make-array '(1 2 3 4 5)))
+(arrayp (make-array '(3 3 3)))
+(arrayp (make-array '(3 0 3)))
+(arrayp (make-array '5 :element-type 'character :displaced-to "array"))
+(arrayp "")
+(arrayp "array")
+(arrayp (make-array '(2 3 4) :adjustable t))
+(arrayp (make-array 6))
+(arrayp #*1011)
+(arrayp "hi")
+(not (arrayp 'hi))
+(not (arrayp 12))
+
+
+
+(let ((array (make-array '(2 3) :initial-contents '((0 1 2) (3 4 5)))))
+ (and (eql (aref array 0 0) 0)
+ (eql (aref array 0 1) 1)
+ (eql (aref array 0 2) 2)
+ (eql (aref array 1 0) 3)
+ (eql (aref array 1 1) 4)
+ (eql (aref array 1 2) 5)))
+
+(let ((array (make-array '(3 2 1)
+ :initial-contents '(((0) (1)) ((2) (3)) ((4) (5))))))
+ (and (eql (aref array 0 0 0) 0)
+ (eql (aref array 0 1 0) 1)
+ (eql (aref array 1 0 0) 2)
+ (eql (aref array 1 1 0) 3)
+ (eql (aref array 2 0 0) 4)
+ (eql (aref array 2 1 0) 5)))
+
+(let ((array (make-array '(2 2 2 2)
+ :initial-contents
+ '((((0 1) (2 3)) ((4 5) (6 7)))
+ (((8 9) (10 11)) ((12 13) (14 15)))))))
+ (and (eql (aref array 0 0 0 0) 0)
+ (eql (aref array 0 0 0 1) 1)
+ (eql (aref array 0 0 1 0) 2)
+ (eql (aref array 0 0 1 1) 3)
+ (eql (aref array 0 1 0 0) 4)
+ (eql (aref array 0 1 0 1) 5)
+ (eql (aref array 0 1 1 0) 6)
+ (eql (aref array 0 1 1 1) 7)
+ (eql (aref array 1 0 0 0) 8)
+ (eql (aref array 1 0 0 1) 9)
+ (eql (aref array 1 0 1 0) 10)
+ (eql (aref array 1 0 1 1) 11)
+ (eql (aref array 1 1 0 0) 12)
+ (eql (aref array 1 1 0 1) 13)
+ (eql (aref array 1 1 1 0) 14)
+ (eql (aref array 1 1 1 1) 15)))
+
+(let ((array (make-array '(3 3 3 3 3 3) :initial-element nil)))
+ (dotimes (i 729)
+ (setf (row-major-aref array i) i))
+ (dotimes (i 729 t)
+ (unless (= (aref array
+ (floor i (* 3 3 3 3 3))
+ (floor (mod i (* 3 3 3 3 3)) (* 3 3 3 3))
+ (floor (mod i (* 3 3 3 3)) (* 3 3 3))
+ (floor (mod i (* 3 3 3)) (* 3 3))
+ (floor (mod i (* 3 3)) (* 3))
+ (mod i 3))
+ i)
+ (return nil))))
+
+
+(zerop (aref (make-array '() :initial-contents 0)))
+(let ((array (make-array 10 :initial-contents '(0 1 2 3 4 5 6 7 8 9)))
+ (ok t))
+ (dotimes (i 10)
+ (unless (eql (aref array i) i)
+ (setq ok nil)
+ (return)))
+ ok)
+
+(let ((array (vector 0 1 2 3 4 5 6 7 8 9))
+ (ok t))
+ (dotimes (i 10)
+ (unless (eql (aref array i) i)
+ (setq ok nil)
+ (return)))
+ ok)
+
+(let ((array "0123456789")
+ (ok t))
+ (dotimes (i 10)
+ (unless (char= (aref array i) (char "0123456789" i))
+ (setq ok nil)
+ (return)))
+ ok)
+
+
+(let ((array (make-array '(2 3) :initial-contents '((0 1 2) (3 4 5)))))
+ (equal (array-dimensions array) '(2 3)))
+
+(equal (array-dimensions (make-array 4)) '(4))
+(equal (array-dimensions (make-array '(2 3))) '(2 3))
+(equal (array-dimensions (make-array 4 :fill-pointer 2)) '(4))
+(equal (array-dimensions (make-array '(2 3 4 5 6))) '(2 3 4 5 6))
+
+(eql (array-dimension (make-array 4) 0) 4)
+(eql (array-dimension (make-array '(2 3)) 1) 3)
+(eql (array-dimension (make-array '(2 3 4)) 2) 4)
+
+(eq (array-element-type (make-array 4)) t)
+(equal (array-element-type (make-array 12 :element-type '(unsigned-byte 8)))
+ (upgraded-array-element-type '(unsigned-byte 8)))
+
+
+(let ((array (make-array '())))
+ (multiple-value-bind (displaced-to displaced-index-offset)
+ (array-displacement array)
+ (and (not displaced-to)
+ (zerop displaced-index-offset))))
+
+(let ((array (make-array '10)))
+ (multiple-value-bind (displaced-to displaced-index-offset)
+ (array-displacement array)
+ (and (not displaced-to)
+ (zerop displaced-index-offset))))
+
+(let ((array (make-array '(2 3) :initial-contents '((0 1 2) (3 4 5)))))
+ (multiple-value-bind (displaced-to displaced-index-offset)
+ (array-displacement array)
+ (and (not displaced-to)
+ (zerop displaced-index-offset))))
+
+(let* ((source (make-array '(2 5)
+ :initial-contents '((1 2 3 4 5) (11 12 13 14 15))))
+ (array (make-array 10 :displaced-to source)))
+ (multiple-value-bind (displaced-to displaced-index-offset)
+ (array-displacement array)
+ (and (eq displaced-to source)
+ (zerop displaced-index-offset))))
+
+(let* ((source (make-array '10 :initial-element 0))
+ (array (make-array '(5 2) :displaced-to source)))
+ (multiple-value-bind (displaced-to displaced-index-offset)
+ (array-displacement array)
+ (and (eq displaced-to source)
+ (zerop displaced-index-offset))))
+
+(let* ((e0-0 (list 0 0))
+ (e0-1 (list 0 1))
+ (e1-0 (list 1 0))
+ (e1-1 (list 1 1))
+ (source (make-array '(2 2)
+ :initial-contents (list (list e0-0 e0-1)
+ (list e1-0 e1-1))))
+ (array (make-array 4 :displaced-to source)))
+ (multiple-value-bind (displaced-to displaced-index-offset)
+ (array-displacement array)
+ (and (eq displaced-to source)
+ (zerop displaced-index-offset)
+ (eq (aref array 0) e0-0)
+ (eq (aref array 1) e0-1)
+ (eq (aref array 2) e1-0)
+ (eq (aref array 3) e1-1))))
+
+
+(let* ((e0-0 (list 0 0))
+ (e0-1 (list 0 1))
+ (e1-0 (list 1 0))
+ (e1-1 (list 1 1))
+ (source (make-array '(2 2)
+ :initial-contents (list (list e0-0 e0-1)
+ (list e1-0 e1-1))))
+ (array (make-array 2 :displaced-to source :displaced-index-offset 1)))
+ (multiple-value-bind (displaced-to displaced-index-offset)
+ (array-displacement array)
+ (and (eq displaced-to source)
+ (eql displaced-index-offset 1)
+ (eq (aref array 0) e0-1)
+ (eq (aref array 1) e1-0))))
+
+(let ((array (make-array 4
+ :element-type 'character
+ :displaced-to "0123456789"
+ :displaced-index-offset 6)))
+ (multiple-value-bind (displaced-to displaced-index-offset)
+ (array-displacement array)
+ (and (string= displaced-to "0123456789")
+ (eql displaced-index-offset 6)
+ (eql (aref array 0) #\6)
+ (eql (aref array 1) #\7)
+ (eql (aref array 2) #\8)
+ (eql (aref array 3) #\9))))
+
+(let ((array (make-array '(1 2 5)
+ :element-type 'character
+ :displaced-to "0123456789")))
+ (multiple-value-bind (displaced-to displaced-index-offset)
+ (array-displacement array)
+ (and (string= displaced-to "0123456789")
+ (eql displaced-index-offset 0)
+ (eql (aref array 0 0 0) #\0)
+ (eql (aref array 0 0 1) #\1)
+ (eql (aref array 0 0 2) #\2)
+ (eql (aref array 0 0 3) #\3)
+ (eql (aref array 0 0 4) #\4)
+ (eql (aref array 0 1 0) #\5)
+ (eql (aref array 0 1 1) #\6)
+ (eql (aref array 0 1 2) #\7)
+ (eql (aref array 0 1 3) #\8)
+ (eql (aref array 0 1 4) #\9))))
+
+(let* ((source (make-array '(2 5)
+ :initial-contents '("love&" "peace")
+ :element-type 'character))
+ (array (make-array 10 :displaced-to source :element-type 'character)))
+ (multiple-value-bind (displaced-to displaced-index-offset)
+ (array-displacement array)
+ (and (eq displaced-to source)
+ (eql displaced-index-offset 0)
+ (string= array "love&peace"))))
+
+(array-in-bounds-p (make-array 5) 4)
+(not (array-in-bounds-p (make-array 5) -1))
+(let ((a (make-array '(7 11) :element-type 'string-char)))
+ (and (array-in-bounds-p a 0 0)
+ (array-in-bounds-p a 6 10)
+ (not (array-in-bounds-p a 0 -1))
+ (not (array-in-bounds-p a 0 11))
+ (not (array-in-bounds-p a 7 0))))
+
+
+
+
+(let ((array (make-array '(2 3) :initial-contents '((0 1 2) (3 4 5)))))
+ (eql (array-rank array) 2))
+
+(zerop (array-rank (make-array '())))
+(eql (array-rank (make-array 10)) 1)
+(eql (array-rank (make-array '(2 10))) 2)
+(eql (array-rank (make-array '(2 10 1))) 3)
+(eql (array-rank (make-array '(2 10 1 3))) 4)
+(eql (array-rank "") 1)
+(eql (array-rank "a") 1)
+
+(zerop (array-row-major-index (make-array '())))
+(zerop (array-row-major-index (make-array '5) 0))
+(eql (array-row-major-index (make-array '5) 4) 4)
+(eql (array-row-major-index (make-array '10) 3) 3)
+(zerop (array-row-major-index (make-array '(3 4)) 0 0))
+(eql (array-row-major-index (make-array '(3 4)) 2 3) 11)
+(zerop (array-row-major-index (make-array '(3 4 5)) 0 0 0))
+(eql (array-row-major-index (make-array '(3 4 5)) 2 3 4) 59)
+
+
+(let ((array (make-array '(2 3) :initial-contents '((0 1 2) (3 4 5)))))
+ (eql (array-total-size array) 6))
+
+(eql (array-total-size (make-array 4)) 4)
+(eql (array-total-size (make-array 4 :fill-pointer 2)) 4)
+(eql (array-total-size (make-array 0)) 0)
+(eql (array-total-size (make-array '(4 2))) 8)
+(eql (array-total-size (make-array '(4 0))) 0)
+(eql (array-total-size (make-array '())) 1)
+(eql (array-total-size (make-array '(2 3 4 5))) (* 2 3 4 5))
+
+
+(let ((array (make-array 10
+ :initial-contents '(0 1 2 3 4 5 6 7 8 9)
+ :fill-pointer 0)))
+ (dotimes (i 10 t)
+ (unless (eql (aref array i) i)
+ (return nil))))
+
+(let ((array (make-array '(10 10) :element-type 'number :initial-element 0)))
+ (dotimes (i 10)
+ (dotimes (j 10)
+ (unless (zerop (aref array i j))
+ (return nil))
+ (setf (aref array i j) (+ (* i 10) j))))
+ (dotimes (i 100 t)
+ (unless (eql (row-major-aref array i) i)
+ (return nil))))
+
+(let ((array (make-array '())))
+ (setf (aref array) 100)
+ (eql (aref array) 100))
+
+(let ((array (make-array 10 :initial-contents '(a b c d e f g h i j))))
+ (setf (aref array 0) #\a)
+ (setf (aref array 2) #\c)
+ (setf (aref array 4) #\e)
+ (setf (aref array 6) #\g)
+ (setf (aref array 8) #\i)
+ (and (eql (aref array 0) #\a) (eql (aref array 1) 'b)
+ (eql (aref array 2) #\c) (eql (aref array 3) 'd)
+ (eql (aref array 4) #\e) (eql (aref array 5) 'f)
+ (eql (aref array 6) #\g) (eql (aref array 7) 'h)
+ (eql (aref array 8) #\i) (eql (aref array 9) 'j)))
+
+(let ((array (vector 'a 'b 'c 'd 'e 'f 'g 'h 'i 'j)))
+ (setf (aref array 0) #\a)
+ (setf (aref array 2) #\c)
+ (setf (aref array 4) #\e)
+ (setf (aref array 6) #\g)
+ (setf (aref array 8) #\i)
+ (and (eql (aref array 0) #\a) (eql (aref array 1) 'b)
+ (eql (aref array 2) #\c) (eql (aref array 3) 'd)
+ (eql (aref array 4) #\e) (eql (aref array 5) 'f)
+ (eql (aref array 6) #\g) (eql (aref array 7) 'h)
+ (eql (aref array 8) #\i) (eql (aref array 9) 'j)))
+
+(let ((array (make-array '(3 4 5) :initial-element 0 :element-type 'number)))
+ (setf (aref array 0 0 0) 0)
+ (setf (aref array 1 1 1) 1)
+ (setf (aref array 2 2 2) 2)
+ (dotimes (i 3 t)
+ (unless (eql (aref array i i i) i)
+ (return nil))))
+
+(let* ((array (make-array '(3 4 5 6 7)
+ :initial-element 0 :element-type 'number))
+ (array2 (make-array (* 3 4 5 6 7) :displaced-to array)))
+ (setf (aref array 2 3 4 5 6) 100)
+ (setf (aref array 0 0 0 0 0) 200)
+ (eql (reduce #'+ array2) 300))
+
+(adjustable-array-p (make-array 5
+ :element-type 'character
+ :adjustable t
+ :fill-pointer 3))
+
+(let ((array (adjust-array (make-array '(2 3)
+ :initial-contents '((0 1 2) (3 4 5))
+ :adjustable t)
+ '(3 2) :initial-element 'undefined)))
+ (and (eql (aref array 0 0) 0)
+ (eql (aref array 0 1) 1)
+ (eql (aref array 1 0) 3)
+ (eql (aref array 1 1) 4)
+ (eql (aref array 2 0) 'undefined)
+ (eql (aref array 2 1) 'undefined)))
+
+(let ((array (adjust-array (make-array '(2 3)
+ :initial-contents '((0 1 2) (3 4 5))
+ :adjustable t)
+ '(3 2) :initial-element 'undefined)))
+ (equal (array-dimensions array) '(3 2)))
+
+(let ((array (adjust-array (make-array '(2 3)
+ :initial-contents '((0 1 2) (3 4 5))
+ :adjustable t)
+ '(3 2) :initial-element 'undefined)))
+ (not (array-has-fill-pointer-p array)))
+
+(let ((array (make-array '(2 3) :initial-contents '((0 1 2) (3 4 5)))))
+ (not (array-has-fill-pointer-p array)))
+
+(array-has-fill-pointer-p (make-array 10 :fill-pointer 0))
+(array-has-fill-pointer-p (make-array 8 :fill-pointer 0 :initial-element 8))
+(not (array-has-fill-pointer-p (make-array '(2 3 4))))
+
+
+
+(let ((array (adjust-array (make-array '(2 3)
+ :initial-contents '((0 1 2) (3 4 5))
+ :adjustable t)
+ '(3 2) :initial-element 'undefined)))
+ (multiple-value-bind (displaced-to displaced-index-offset)
+ (array-displacement array)
+ (and (not displaced-to)
+ (zerop displaced-index-offset))))
+
+(let ((array (adjust-array (make-array '(2 3)
+ :initial-contents '((0 1 2) (3 4 5))
+ :adjustable t)
+ '(3 2) :initial-element 'undefined)))
+ (eql (array-rank array) 2))
+
+(let ((array (adjust-array (make-array '(2 3)
+ :initial-contents '((0 1 2) (3 4 5))
+ :adjustable t)
+ '(3 2) :initial-element 'undefined)))
+ (eql (array-total-size array) 6))
+
+
+(eql (fill-pointer (make-array 8 :fill-pointer 4)) 4)
+(let ((array (make-array 8 :fill-pointer 4 :initial-element nil)))
+ (and (eql (length array) 4)
+ (setf (fill-pointer array) 3)
+ (eql (fill-pointer array) 3)
+ (eql (length array) 3)))
+
+(let ((vector (make-array 10
+ :fill-pointer 0
+ :initial-element #\Space
+ :element-type 'character)))
+ (and (eql (vector-push #\a vector) 0)
+ (eql (vector-push #\b vector) 1)
+ (eql (vector-push #\c vector) 2)
+ (string= vector "abc")))
+
+(let ((vector (make-array 3 :fill-pointer t :initial-contents '(a b c))))
+ (and (eql (array-dimension vector 0) (fill-pointer vector))
+ (equal (concatenate 'list vector) '(a b c))
+ (zerop (setf (fill-pointer vector) 0))
+ (null (concatenate 'list vector))
+ (eql (vector-push 'x vector) 0)
+ (equal (concatenate 'list vector) '(x))
+ (eq (vector-pop vector) 'x)
+ (zerop (length vector))))
+
+(let ((vector (make-array 10 :fill-pointer 0 :initial-element nil)))
+ (and (eql (length vector) 0)
+ (setf (fill-pointer vector) 10)
+ (eql (length vector) 10)
+ (setf (fill-pointer vector) 5)
+ (eql (length vector) 5)))
+
+
+(let ((array (make-array '(3 2 1)
+ :initial-contents '(((0) (1)) ((2) (3)) ((4) (5))))))
+ (and (eql (aref array 0 0 0) (row-major-aref array 0))
+ (eql (aref array 0 1 0) (row-major-aref array 1))
+ (eql (aref array 1 0 0) (row-major-aref array 2))
+ (eql (aref array 1 1 0) (row-major-aref array 3))
+ (eql (aref array 2 0 0) (row-major-aref array 4))
+ (eql (aref array 2 1 0) (row-major-aref array 5))))
+
+(let ((array (make-array '(3 2 1)
+ :initial-contents '(((0) (1)) ((2) (3)) ((4) (5))))))
+ (and (eql 0 (row-major-aref array 0))
+ (eql 1 (row-major-aref array 1))
+ (eql 2 (row-major-aref array 2))
+ (eql 3 (row-major-aref array 3))
+ (eql 4 (row-major-aref array 4))
+ (eql 5 (row-major-aref array 5))))
+
+
+(let* ((array0 (make-array '(3 2 1)
+ :initial-contents '(((0) (1)) ((2) (3)) ((4) (5)))))
+ (array1 (make-array 6 :displaced-to array0)))
+ (and (eql (aref array1 0) (row-major-aref array0 0))
+ (eql (aref array1 1) (row-major-aref array0 1))
+ (eql (aref array1 2) (row-major-aref array0 2))
+ (eql (aref array1 3) (row-major-aref array0 3))
+ (eql (aref array1 4) (row-major-aref array0 4))
+ (eql (aref array1 5) (row-major-aref array0 5))))
+
+(let* ((array0 (make-array 6
+ :element-type 'character
+ :initial-contents "abcdef"))
+ (array1 (make-array '(3 2 1)
+ :displaced-to array0
+ :element-type 'character)))
+ (and (eql (aref array0 0) (row-major-aref array1 0))
+ (eql (aref array0 1) (row-major-aref array1 1))
+ (eql (aref array0 2) (row-major-aref array1 2))
+ (eql (aref array0 3) (row-major-aref array1 3))
+ (eql (aref array0 4) (row-major-aref array1 4))
+ (eql (aref array0 5) (row-major-aref array1 5))))
+
+(let* ((array0 (make-array 6
+ :element-type 'character
+ :initial-contents "abcdef"))
+ (array1 (make-array '(3 2 1)
+ :displaced-to array0
+ :element-type 'character)))
+ (and (eql #\a (row-major-aref array1 0))
+ (eql #\b (row-major-aref array1 1))
+ (eql #\c (row-major-aref array1 2))
+ (eql #\d (row-major-aref array1 3))
+ (eql #\e (row-major-aref array1 4))
+ (eql #\f (row-major-aref array1 5))))
+
+(let ((array (make-array '(3 2 1) :initial-element nil)))
+ (setf (row-major-aref array 0) 'a)
+ (setf (row-major-aref array 1) 'b)
+ (setf (row-major-aref array 2) 'c)
+ (setf (row-major-aref array 3) 'd)
+ (setf (row-major-aref array 4) 'e)
+ (and (eql (aref array 0 0 0) 'a)
+ (eql (aref array 0 1 0) 'b)
+ (eql (aref array 1 0 0) 'c)
+ (eql (aref array 1 1 0) 'd)
+ (eql (aref array 2 0 0) 'e)
+ (eql (aref array 2 1 0) 'nil)))
+
+(let ((str "abcdefg"))
+ (dotimes (i 7 t)
+ (unless (eql (char str 0) (row-major-aref str 0))
+ (return nil))))
+
+(let ((str (make-array 5 :initial-contents "abcde")))
+ (dotimes (i 3)
+ (setf (row-major-aref str i) (row-major-aref str (- 4 i))))
+ (and (char= (row-major-aref str 0) #\e)
+ (char= (row-major-aref str 1) #\d)
+ (char= (row-major-aref str 2) #\c)
+ (char= (row-major-aref str 3) #\d)
+ (char= (row-major-aref str 4) #\e)))
+
+
+(eq (upgraded-array-element-type t) t)
+(and (subtypep (upgraded-array-element-type 'bit) 'bit)
+ (subtypep 'bit (upgraded-array-element-type 'bit)))
+(and (subtypep (upgraded-array-element-type 'base-char) 'base-char)
+ (subtypep 'base-char (upgraded-array-element-type 'base-char)))
+(and (subtypep (upgraded-array-element-type 'character) 'character)
+ (subtypep 'character (upgraded-array-element-type 'character)))
+
+
+(simple-vector-p (make-array 6))
+(not (simple-vector-p "aaaaaa"))
+
+(let ((sv (make-array 10)))
+ (dotimes (i 10)
+ (setf (svref sv i) (* i i)))
+ (dotimes (i 10 t)
+ (unless (eql (svref sv i) (* i i))
+ (return nil))))
+
+(let ((sv (vector 'a 'b 'c 'd 'e 'f)))
+ (and (eq (svref sv 0) 'a)
+ (eq (svref sv 1) 'b)
+ (eq (svref sv 2) 'c)
+ (eq (svref sv 3) 'd)
+ (eq (svref sv 4) 'e)
+ (eq (svref sv 5) 'f)))
+
+(let ((sv (make-array 3 :initial-contents '(1 2 last))))
+ (and (simple-vector-p sv)
+ (eq (svref sv 2) 'last)
+ (eql (svref sv 1) 2)
+ (eql (svref sv 0) 1)
+ (eql (setf (svref sv 1) 'last-but-one) 'last-but-one)
+ (eq (svref sv 1) 'last-but-one)))
+
+
+(let ((vec (vector 1 2 'last)))
+ (and (arrayp vec)
+ (vectorp vec)
+ (simple-vector-p vec)
+ (eql (length vec) 3)
+ (equal (concatenate 'list vec) '(1 2 last))))
+
+(eq (vector-pop (make-array 3 :initial-contents '(a b c) :fill-pointer t)) 'c)
+(eq (vector-pop (make-array 3 :initial-contents '(a b c) :fill-pointer 3)) 'c)
+(eq (vector-pop (make-array 3 :initial-contents '(a b c) :fill-pointer 2)) 'b)
+(eq (vector-pop (make-array 3 :initial-contents '(a b c) :fill-pointer 1)) 'a)
+
+(let ((vec (make-array 3 :fill-pointer 0)))
+ (and (eql (vector-push 'a vec) 0)
+ (eql (vector-push 'b vec) 1)
+ (eql (vector-push 'c vec) 2)
+ (eq (vector-pop vec) 'c)
+ (eq (vector-pop vec) 'b)
+ (eq (vector-pop vec) 'a)))
+
+(let ((vec (make-array 3 :fill-pointer t :initial-contents '(a b c))))
+ (and (setf (fill-pointer vec) 1)
+ (eql (vector-push 'y vec) 1)
+ (eql (vector-push 'z vec) 2)
+ (eq (vector-pop vec) 'z)
+ (eq (vector-pop vec) 'y)
+ (eq (vector-pop vec) 'a)
+ (eql (fill-pointer vec) 0)))
+
+(let ((vec (make-array 3 :fill-pointer t :initial-contents '(a b c))))
+ (and (not (vector-push 'x vec))
+ (not (vector-push 'y vec))
+ (eql (setf (fill-pointer vec) 0) 0)
+ (eql (vector-push 'x vec) 0)
+ (eql (vector-push 'y vec) 1)
+ (eql (vector-push 'z vec) 2)
+ (not (vector-push 'l vec))))
+
+
+
+(let ((vec (make-array 3
+ :fill-pointer 2
+ :initial-contents '(a b l)
+ :adjustable t)))
+ (and (eql (length vec) 2)
+ (eql (vector-push-extend 'c vec) 2)
+ (eql (length vec) 3)
+ (eq (vector-pop vec) 'c)
+ (eql (vector-push-extend 'c vec) 2)
+ (eql (vector-push-extend 'x vec) 3)
+ (eql (vector-push-extend 'y vec) 4)
+ (eql (vector-push-extend 'z vec) 5)
+ (eql (length vec) 6)))
+
+
+(let ((vec (make-array 0
+ :fill-pointer t
+ :adjustable t)))
+ (dotimes (i 50)
+ (vector-push-extend (* i i) vec))
+ (dotimes (i 50 t)
+ (unless (eql (vector-pop vec) (* (- 49 i) (- 49 i)))
+ (return nil))))
+
+(let ((vec (make-array 10
+ :element-type 'character
+ :initial-contents "abcdefghij"
+ :adjustable t
+ :fill-pointer t)))
+ (and (eql (vector-push-extend #\x vec) 10)
+ (eql (vector-push-extend #\y vec) 11)
+ (eql (vector-push-extend #\z vec) 12)
+ (string= vec "abcdefghijxyz")))
+
+(vectorp "aaaaaa")
+(vectorp (make-array 6 :fill-pointer t))
+(not (vectorp (make-array '(2 3 4))))
+(vectorp #*11)
+(not (vectorp #b11))
+(vectorp (make-array 3 :displaced-to "abc" :element-type 'character))
+
+(eql (bit (make-array 8 :element-type 'bit :initial-element 1) 3)
+ 1)
+(eql (sbit (make-array 8 :element-type 'bit :initial-element 1) 3)
+ 1)
+
+(let ((ba (make-array 8
+ :element-type 'bit
+ :initial-contents '(0 1 0 1 0 1 0 1))))
+ (dotimes (i 8 t)
+ (unless (or (and (evenp i) (zerop (bit ba i)))
+ (and (oddp i) (eql (bit ba i) 1)))
+ (return nil))))
+
+(let ((ba (make-array 8
+ :element-type 'bit
+ :initial-contents '(0 1 0 1 0 1 0 1))))
+ (dotimes (i 8 t)
+ (unless (or (and (evenp i) (zerop (sbit ba i)))
+ (and (oddp i) (eql (sbit ba i) 1)))
+ (return nil))))
+
+(let ((ba (make-array '(3 3)
+ :element-type 'bit
+ :initial-contents '((0 1 0) (1 0 1) (0 1 0)))))
+ (and (zerop (bit ba 0 0))
+ (eql (bit ba 0 1) 1)
+ (zerop (bit ba 0 2))
+ (eql (bit ba 1 0) 1)
+ (zerop (bit ba 1 1))
+ (eql (bit ba 1 2) 1)
+ (zerop (bit ba 2 0))
+ (eql (bit ba 2 1) 1)
+ (zerop (bit ba 2 2))))
+
+(let ((ba (make-array '(3 3)
+ :element-type 'bit
+ :initial-contents '((0 1 0) (1 0 1) (0 1 0)))))
+ (and (zerop (sbit ba 0 0))
+ (eql (sbit ba 0 1) 1)
+ (zerop (sbit ba 0 2))
+ (eql (sbit ba 1 0) 1)
+ (zerop (sbit ba 1 1))
+ (eql (sbit ba 1 2) 1)
+ (zerop (sbit ba 2 0))
+ (eql (sbit ba 2 1) 1)
+ (zerop (sbit ba 2 2))))
+
+(let ((ba (make-array '(3 3 3) :element-type 'bit)))
+ (dotimes (i (* 3 3 3))
+ (setf (bit ba
+ (floor i 9)
+ (floor (mod i 9) 3)
+ (mod i 3))
+ (if (evenp i) 0 1)))
+ (dotimes (i (* 3 3 3) t)
+ (unless (eql (row-major-aref ba i) (if (evenp i) 0 1))
+ (return nil))))
+
+(let ((ba (make-array '(3 3 3) :element-type 'bit)))
+ (dotimes (i (* 3 3 3))
+ (setf (sbit ba
+ (floor i 9)
+ (floor (mod i 9) 3)
+ (mod i 3))
+ (if (evenp i) 0 1)))
+ (dotimes (i (* 3 3 3) t)
+ (unless (eql (row-major-aref ba i) (if (evenp i) 0 1))
+ (return nil))))
+
+(let ((ba (make-array '(1 2 3 4 5) :element-type 'bit)))
+ (dotimes (i (* 1 2 3 4 5))
+ (setf (bit ba
+ (floor i (* 1 2 3 4 5))
+ (floor (mod i (* 2 3 4 5)) (* 3 4 5))
+ (floor (mod i (* 3 4 5)) (* 4 5))
+ (floor (mod i (* 4 5)) 5)
+ (mod i 5))
+ (if (evenp i) 0 1)))
+ (dotimes (i (* 1 2 3 4 5) t)
+ (unless (eql (row-major-aref ba i) (if (evenp i) 0 1))
+ (return nil))))
+
+(let ((ba (make-array '(1 2 3 4 5) :element-type 'bit)))
+ (dotimes (i (* 1 2 3 4 5))
+ (setf (sbit ba
+ (floor i (* 1 2 3 4 5))
+ (floor (mod i (* 2 3 4 5)) (* 3 4 5))
+ (floor (mod i (* 3 4 5)) (* 4 5))
+ (floor (mod i (* 4 5)) 5)
+ (mod i 5))
+ (if (evenp i) 0 1)))
+ (dotimes (i (* 1 2 3 4 5) t)
+ (unless (eql (row-major-aref ba i) (if (evenp i) 0 1))
+ (return nil))))
+
+(let ((ba (make-array 8 :element-type 'bit :initial-element 1)))
+ (and (eql (setf (bit ba 3) 0) 0)
+ (eql (bit ba 3) 0)
+ (eql (sbit ba 5) 1)
+ (eql (setf (sbit ba 5) 0) 0)
+ (eql (sbit ba 5) 0)))
+
+
+(let ((ba (make-array 10 :element-type 'bit :fill-pointer 0)))
+ (dotimes (i 10)
+ (vector-push (if (oddp i) 0 1) ba))
+ (dotimes (i 10 t)
+ (unless (and (eql (bit ba i) (if (oddp i) 0 1))
+ (or (not (simple-vector-p ba))
+ (eql (sbit ba i) (if (oddp i) 0 1)))
+ (eql (aref ba i) (if (oddp i) 0 1)))
+ (return nil))))
+
+(let ((ba (make-array 10 :element-type 'bit :fill-pointer 0)))
+ (dotimes (i 10)
+ (vector-push (if (oddp i) 0 1) ba))
+ (dotimes (j 10 t)
+ (let ((i (- 9 j)))
+ (unless (and (eql (bit ba i) (if (oddp i) 0 1))
+ (or (not (simple-vector-p ba))
+ (eql (sbit ba i) (if (oddp i) 0 1)))
+ (eql (aref ba i) (if (oddp i) 0 1))
+ (eql (vector-pop ba) (if (oddp i) 0 1)))
+ (return nil)))))
+
+
+(equal (bit-and #*11101010 #*01101011) #*01101010)
+(equal (bit-and #*11101010 #*01101011 nil) #*01101010)
+(equal (bit-and (make-array 8 :element-type 'bit :initial-contents #*11101010)
+ #*01101011 t)
+ #*01101010)
+(equal (bit-and #*11101010
+ #*01101011
+ (make-array 8 :element-type 'bit))
+ #*01101010)
+
+(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*11101010))
+ (ba2 (make-array 8 :element-type 'bit :initial-contents #*01101011))
+ (ba (bit-and ba1 ba2)))
+ (and (not (eq ba1 ba))
+ (not (eq ba2 ba))
+ (not (eq ba1 ba2))
+ (equal ba #*01101010)))
+
+(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01010101))
+ (ba (bit-and ba1 #*10101010 t)))
+ (and (eq ba1 ba)
+ (equal ba1 #*00000000)))
+
+(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01110001))
+ (ba (bit-and ba1 #*00111110 t)))
+ (and (eq ba1 ba)
+ (equal ba1 #*00110000)))
+
+(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01110001))
+ (ba2 (make-array 8 :element-type 'bit :initial-contents #*00111110))
+ (ba3 (make-array 8 :element-type 'bit))
+ (ba4 (bit-and ba1 ba2 ba3)))
+ (and (eq ba3 ba4)
+ (equal ba3 #*00110000)
+ (not (eq ba1 ba3))
+ (not (eq ba1 ba4))
+ (not (eq ba2 ba3))
+ (not (eq ba2 ba4))))
+
+(equalp (bit-and (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101))
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010)))
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*000 #*000)))
+
+(equalp (bit-and (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101))
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010))
+ nil)
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*000 #*000)))
+
+
+(equalp (bit-and (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101))
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010))
+ t)
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*000 #*000)))
+
+(equalp (bit-and (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101))
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010))
+ (make-array '(2 3)
+ :element-type 'bit))
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*000 #*000)))
+
+(let* ((ba1 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101)))
+ (ba2 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010)))
+ (ba (bit-and ba1 ba2)))
+ (and (not (eq ba1 ba))
+ (not (eq ba2 ba))
+ (not (eq ba1 ba2))
+ (equalp ba (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*000 #*000)))))
+
+
+(let* ((ba1 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101)))
+ (ba2 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010)))
+ (ba (bit-and ba1 ba2 t)))
+ (and (eq ba1 ba)
+ (equalp ba1 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*000 #*000)))))
+
+
+(let* ((ba1 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101)))
+ (ba2 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010)))
+ (ba3 (make-array '(2 3)
+ :element-type 'bit))
+ (ba4 (bit-and ba1 ba2 ba3)))
+ (and (eq ba3 ba4)
+ (equalp ba3 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*000 #*000)))
+ (not (eq ba1 ba3))
+ (not (eq ba1 ba4))
+ (not (eq ba2 ba3))
+ (not (eq ba2 ba4))))
+
+
+(equal (bit-andc1 #*11101010 #*01101011) #*00000001)
+(equal (bit-andc1 #*11101010 #*01101011 nil) #*00000001)
+(equal (bit-andc1 (make-array 8 :element-type 'bit :initial-contents #*11101010)
+ #*01101011 t)
+ #*00000001)
+(equal (bit-andc1 #*11101010
+ #*01101011
+ (make-array 8 :element-type 'bit))
+ #*00000001)
+
+(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*11101010))
+ (ba2 (make-array 8 :element-type 'bit :initial-contents #*01101011))
+ (ba (bit-andc1 ba1 ba2)))
+ (and (not (eq ba1 ba))
+ (not (eq ba2 ba))
+ (not (eq ba1 ba2))
+ (equal ba #*00000001)))
+
+(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01010101))
+ (ba (bit-andc1 ba1 #*10101010 t)))
+ (and (eq ba1 ba)
+ (equal ba1 #*10101010)))
+
+(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01110001))
+ (ba (bit-andc1 ba1 #*00111110 t)))
+ (and (eq ba1 ba)
+ (equal ba1 #*00001110)))
+
+(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01110001))
+ (ba2 (make-array 8 :element-type 'bit :initial-contents #*00111110))
+ (ba3 (make-array 8 :element-type 'bit))
+ (ba4 (bit-andc1 ba1 ba2 ba3)))
+ (and (eq ba3 ba4)
+ (equal ba3 #*00001110)
+ (not (eq ba1 ba3))
+ (not (eq ba1 ba4))
+ (not (eq ba2 ba3))
+ (not (eq ba2 ba4))))
+
+(equalp (bit-andc1 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101))
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010)))
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010)))
+
+(equalp (bit-andc1 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101))
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010))
+ nil)
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010)))
+
+(equalp (bit-andc1 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101))
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010))
+ t)
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010)))
+
+(equalp (bit-andc1 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101))
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010))
+ (make-array '(2 3)
+ :element-type 'bit))
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010)))
+
+(let* ((ba1 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101)))
+ (ba2 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010)))
+ (ba (bit-andc1 ba1 ba2)))
+ (and (not (eq ba1 ba))
+ (not (eq ba2 ba))
+ (not (eq ba1 ba2))
+ (equalp ba (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010)))))
+
+(let* ((ba1 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101)))
+ (ba2 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010)))
+ (ba (bit-andc1 ba1 ba2 t)))
+ (and (eq ba1 ba)
+ (equalp ba1 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010)))))
+
+(let* ((ba1 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101)))
+ (ba2 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010)))
+ (ba3 (make-array '(2 3)
+ :element-type 'bit))
+ (ba4 (bit-andc1 ba1 ba2 ba3)))
+ (and (eq ba3 ba4)
+ (equalp ba3 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010)))
+ (not (eq ba1 ba3))
+ (not (eq ba1 ba4))
+ (not (eq ba2 ba3))
+ (not (eq ba2 ba4))))
+
+
+(equal (bit-andc2 #*11101010 #*01101011) #*10000000)
+(equal (bit-andc2 #*11101010 #*01101011 nil) #*10000000)
+(equal (bit-andc2 (make-array 8 :element-type 'bit :initial-contents #*11101010)
+ #*01101011 t)
+ #*10000000)
+(equal (bit-andc2 #*11101010
+ #*01101011
+ (make-array 8 :element-type 'bit))
+ #*10000000)
+(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*11101010))
+ (ba2 (make-array 8 :element-type 'bit :initial-contents #*01101011))
+ (ba (bit-andc2 ba1 ba2)))
+ (and (not (eq ba1 ba))
+ (not (eq ba2 ba))
+ (not (eq ba1 ba2))
+ (equal ba #*10000000)))
+
+(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01010101))
+ (ba (bit-andc2 ba1 #*10101010 t)))
+ (and (eq ba1 ba)
+ (equal ba1 #*01010101)))
+
+(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01110001))
+ (ba (bit-andc2 ba1 #*00111110 t)))
+ (and (eq ba1 ba)
+ (equal ba1 #*01000001)))
+
+(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01110001))
+ (ba2 (make-array 8 :element-type 'bit :initial-contents #*00111110))
+ (ba3 (make-array 8 :element-type 'bit))
+ (ba4 (bit-andc2 ba1 ba2 ba3)))
+ (and (eq ba3 ba4)
+ (equal ba3 #*01000001)
+ (not (eq ba1 ba3))
+ (not (eq ba1 ba4))
+ (not (eq ba2 ba3))
+ (not (eq ba2 ba4))))
+
+(equalp (bit-andc2 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101))
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010)))
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101)))
+
+(equalp (bit-andc2 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101))
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010))
+ nil)
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101)))
+
+(equalp (bit-andc2 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101))
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010))
+ t)
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101)))
+
+(equalp (bit-andc2 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101))
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010))
+ (make-array '(2 3)
+ :element-type 'bit))
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101)))
+
+(let* ((ba1 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101)))
+ (ba2 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010)))
+ (ba (bit-andc2 ba1 ba2)))
+ (and (not (eq ba1 ba))
+ (not (eq ba2 ba))
+ (not (eq ba1 ba2))
+ (equalp ba (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101)))))
+
+(let* ((ba1 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101)))
+ (ba2 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010)))
+ (ba (bit-andc2 ba1 ba2 t)))
+ (and (eq ba1 ba)
+ (equalp ba1 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101)))))
+
+(let* ((ba1 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101)))
+ (ba2 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010)))
+ (ba3 (make-array '(2 3)
+ :element-type 'bit))
+ (ba4 (bit-andc2 ba1 ba2 ba3)))
+ (and (eq ba3 ba4)
+ (equalp ba3 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101)))
+ (not (eq ba1 ba3))
+ (not (eq ba1 ba4))
+ (not (eq ba2 ba3))
+ (not (eq ba2 ba4))))
+
+
+(equal (bit-eqv #*11101010 #*01101011) #*01111110)
+(equal (bit-eqv #*11101010 #*01101011 nil) #*01111110)
+(equal (bit-eqv (make-array 8 :element-type 'bit :initial-contents #*11101010)
+ #*01101011 t)
+ #*01111110)
+(equal (bit-eqv #*11101010
+ #*01101011
+ (make-array 8 :element-type 'bit))
+ #*01111110)
+(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*11101010))
+ (ba2 (make-array 8 :element-type 'bit :initial-contents #*01101011))
+ (ba (bit-eqv ba1 ba2)))
+ (and (not (eq ba1 ba))
+ (not (eq ba2 ba))
+ (not (eq ba1 ba2))
+ (equal ba #*01111110)))
+
+(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01010101))
+ (ba (bit-eqv ba1 #*10101010 t)))
+ (and (eq ba1 ba)
+ (equal ba1 #*00000000)))
+
+(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01110001))
+ (ba (bit-eqv ba1 #*00111110 t)))
+ (and (eq ba1 ba)
+ (equal ba1 #*10110000)))
+
+(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01110001))
+ (ba2 (make-array 8 :element-type 'bit :initial-contents #*00111110))
+ (ba3 (make-array 8 :element-type 'bit))
+ (ba4 (bit-eqv ba1 ba2 ba3)))
+ (and (eq ba3 ba4)
+ (equal ba3 #*10110000)
+ (not (eq ba1 ba3))
+ (not (eq ba1 ba4))
+ (not (eq ba2 ba3))
+ (not (eq ba2 ba4))))
+
+(equalp (bit-eqv (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101))
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010)))
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*000 #*000)))
+
+(equalp (bit-eqv (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101))
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010))
+ nil)
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*000 #*000)))
+
+
+(equalp (bit-eqv (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101))
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010))
+ t)
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*000 #*000)))
+
+(equalp (bit-eqv (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101))
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010))
+ (make-array '(2 3)
+ :element-type 'bit))
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*000 #*000)))
+
+(let* ((ba1 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101)))
+ (ba2 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010)))
+ (ba (bit-eqv ba1 ba2)))
+ (and (not (eq ba1 ba))
+ (not (eq ba2 ba))
+ (not (eq ba1 ba2))
+ (equalp ba (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*000 #*000)))))
+
+
+(let* ((ba1 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101)))
+ (ba2 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010)))
+ (ba (bit-eqv ba1 ba2 t)))
+ (and (eq ba1 ba)
+ (equalp ba1 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*000 #*000)))))
+
+(let* ((ba1 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101)))
+ (ba2 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010)))
+ (ba3 (make-array '(2 3)
+ :element-type 'bit))
+ (ba4 (bit-eqv ba1 ba2 ba3)))
+ (and (eq ba3 ba4)
+ (equalp ba3 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*000 #*000)))
+ (not (eq ba1 ba3))
+ (not (eq ba1 ba4))
+ (not (eq ba2 ba3))
+ (not (eq ba2 ba4))))
+
+
+
+
+(equal (bit-ior #*11101010 #*01101011) #*11101011)
+(equal (bit-ior #*11101010 #*01101011 nil) #*11101011)
+(equal (bit-ior (make-array 8 :element-type 'bit :initial-contents #*11101010)
+ #*01101011 t)
+ #*11101011)
+(equal (bit-ior #*11101010
+ #*01101011
+ (make-array 8 :element-type 'bit))
+ #*11101011)
+(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*11101010))
+ (ba2 (make-array 8 :element-type 'bit :initial-contents #*01101011))
+ (ba (bit-ior ba1 ba2)))
+ (and (not (eq ba1 ba))
+ (not (eq ba2 ba))
+ (not (eq ba1 ba2))
+ (equal ba #*11101011)))
+
+(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01010101))
+ (ba (bit-ior ba1 #*10101010 t)))
+ (and (eq ba1 ba)
+ (equal ba1 #*11111111)))
+
+(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01110001))
+ (ba (bit-ior ba1 #*00111110 t)))
+ (and (eq ba1 ba)
+ (equal ba1 #*01111111)))
+(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01110001))
+ (ba2 (make-array 8 :element-type 'bit :initial-contents #*00111110))
+ (ba3 (make-array 8 :element-type 'bit))
+ (ba4 (bit-ior ba1 ba2 ba3)))
+ (and (eq ba3 ba4)
+ (equal ba3 #*01111111)
+ (not (eq ba1 ba3))
+ (not (eq ba1 ba4))
+ (not (eq ba2 ba3))
+ (not (eq ba2 ba4))))
+
+(equalp (bit-ior (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101))
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010)))
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*111 #*111)))
+
+(equalp (bit-ior (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101))
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010))
+ nil)
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*111 #*111)))
+
+(equalp (bit-ior (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101))
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010))
+ t)
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*111 #*111)))
+(equalp (bit-ior (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101))
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010))
+ (make-array '(2 3)
+ :element-type 'bit))
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*111 #*111)))
+(let* ((ba1 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101)))
+ (ba2 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010)))
+ (ba (bit-ior ba1 ba2)))
+ (and (not (eq ba1 ba))
+ (not (eq ba2 ba))
+ (not (eq ba1 ba2))
+ (equalp ba (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*111 #*111)))))
+
+
+(let* ((ba1 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101)))
+ (ba2 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010)))
+ (ba (bit-ior ba1 ba2 t)))
+ (and (eq ba1 ba)
+ (equalp ba1 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*111 #*111)))))
+(let* ((ba1 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101)))
+ (ba2 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010)))
+ (ba3 (make-array '(2 3)
+ :element-type 'bit))
+ (ba4 (bit-ior ba1 ba2 ba3)))
+ (and (eq ba3 ba4)
+ (equalp ba3 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*111 #*111)))
+ (not (eq ba1 ba3))
+ (not (eq ba1 ba4))
+ (not (eq ba2 ba3))
+ (not (eq ba2 ba4))))
+
+
+
+
+(equal (bit-nand #*11101010 #*01101011) #*10010101)
+(equal (bit-nand #*11101010 #*01101011 nil) #*10010101)
+(equal (bit-nand (make-array 8 :element-type 'bit :initial-contents #*11101010)
+ #*01101011 t)
+ #*10010101)
+(equal (bit-nand #*11101010
+ #*01101011
+ (make-array 8 :element-type 'bit))
+ #*10010101)
+(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*11101010))
+ (ba2 (make-array 8 :element-type 'bit :initial-contents #*01101011))
+ (ba (bit-nand ba1 ba2)))
+ (and (not (eq ba1 ba))
+ (not (eq ba2 ba))
+ (not (eq ba1 ba2))
+ (equal ba #*10010101)))
+
+(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01010101))
+ (ba (bit-nand ba1 #*10101010 t)))
+ (and (eq ba1 ba)
+ (equal ba1 #*11111111)))
+
+(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01110001))
+ (ba (bit-nand ba1 #*00111110 t)))
+ (and (eq ba1 ba)
+ (equal ba1 #*11001111)))
+(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01110001))
+ (ba2 (make-array 8 :element-type 'bit :initial-contents #*00111110))
+ (ba3 (make-array 8 :element-type 'bit))
+ (ba4 (bit-nand ba1 ba2 ba3)))
+ (and (eq ba3 ba4)
+ (equal ba3 #*11001111)
+ (not (eq ba1 ba3))
+ (not (eq ba1 ba4))
+ (not (eq ba2 ba3))
+ (not (eq ba2 ba4))))
+(equalp (bit-nand (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101))
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010)))
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*111 #*111)))
+
+(equalp (bit-nand (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101))
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010))
+ nil)
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*111 #*111)))
+
+(equalp (bit-nand (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101))
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010))
+ t)
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*111 #*111)))
+(equalp (bit-nand (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101))
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010))
+ (make-array '(2 3)
+ :element-type 'bit))
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*111 #*111)))
+(let* ((ba1 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101)))
+ (ba2 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010)))
+ (ba (bit-nand ba1 ba2)))
+ (and (not (eq ba1 ba))
+ (not (eq ba2 ba))
+ (not (eq ba1 ba2))
+ (equalp ba (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*111 #*111)))))
+
+(let* ((ba1 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101)))
+ (ba2 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010)))
+ (ba (bit-nand ba1 ba2 t)))
+ (and (eq ba1 ba)
+ (equalp ba1 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*111 #*111)))))
+(let* ((ba1 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101)))
+ (ba2 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010)))
+ (ba3 (make-array '(2 3)
+ :element-type 'bit))
+ (ba4 (bit-nand ba1 ba2 ba3)))
+ (and (eq ba3 ba4)
+ (equalp ba3 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*111 #*111)))
+ (not (eq ba1 ba3))
+ (not (eq ba1 ba4))
+ (not (eq ba2 ba3))
+ (not (eq ba2 ba4))))
+
+
+
+
+(equal (bit-nor #*11101010 #*01101011) #*00010100)
+(equal (bit-nor #*11101010 #*01101011 nil) #*00010100)
+(equal (bit-nor (make-array 8 :element-type 'bit :initial-contents #*11101010)
+ #*01101011 t)
+ #*00010100)
+(equal (bit-nor #*11101010
+ #*01101011
+ (make-array 8 :element-type 'bit))
+ #*00010100)
+(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*11101010))
+ (ba2 (make-array 8 :element-type 'bit :initial-contents #*01101011))
+ (ba (bit-nor ba1 ba2)))
+ (and (not (eq ba1 ba))
+ (not (eq ba2 ba))
+ (not (eq ba1 ba2))
+ (equal ba #*00010100)))
+(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01010101))
+ (ba (bit-nor ba1 #*10101010 t)))
+ (and (eq ba1 ba)
+ (equal ba1 #*00000000)))
+(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01110001))
+ (ba (bit-nor ba1 #*00111110 t)))
+ (and (eq ba1 ba)
+ (equal ba1 #*10000000)))
+(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01110001))
+ (ba2 (make-array 8 :element-type 'bit :initial-contents #*00111110))
+ (ba3 (make-array 8 :element-type 'bit))
+ (ba4 (bit-nor ba1 ba2 ba3)))
+ (and (eq ba3 ba4)
+ (equal ba3 #*10000000)
+ (not (eq ba1 ba3))
+ (not (eq ba1 ba4))
+ (not (eq ba2 ba3))
+ (not (eq ba2 ba4))))
+(equalp (bit-nor (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101))
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010)))
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*000 #*000)))
+
+(equalp (bit-nor (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101))
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010))
+ nil)
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*000 #*000)))
+
+(equalp (bit-nor (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101))
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010))
+ t)
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*000 #*000)))
+(equalp (bit-nor (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101))
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010))
+ (make-array '(2 3)
+ :element-type 'bit))
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*000 #*000)))
+(let* ((ba1 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101)))
+ (ba2 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010)))
+ (ba (bit-nor ba1 ba2)))
+ (and (not (eq ba1 ba))
+ (not (eq ba2 ba))
+ (not (eq ba1 ba2))
+ (equalp ba (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*000 #*000)))))
+
+(let* ((ba1 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101)))
+ (ba2 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010)))
+ (ba (bit-nor ba1 ba2 t)))
+ (and (eq ba1 ba)
+ (equalp ba1 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*000 #*000)))))
+(let* ((ba1 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101)))
+ (ba2 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010)))
+ (ba3 (make-array '(2 3)
+ :element-type 'bit))
+ (ba4 (bit-nor ba1 ba2 ba3)))
+ (and (eq ba3 ba4)
+ (equalp ba3 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*000 #*000)))
+ (not (eq ba1 ba3))
+ (not (eq ba1 ba4))
+ (not (eq ba2 ba3))
+ (not (eq ba2 ba4))))
+
+
+
+
+(equal (bit-orc1 #*11101010 #*01101011) #*01111111)
+(equal (bit-orc1 #*11101010 #*01101011 nil) #*01111111)
+(equal (bit-orc1 (make-array 8 :element-type 'bit :initial-contents #*11101010)
+ #*01101011 t)
+ #*01111111)
+(equal (bit-orc1 #*11101010
+ #*01101011
+ (make-array 8 :element-type 'bit))
+ #*01111111)
+(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*11101010))
+ (ba2 (make-array 8 :element-type 'bit :initial-contents #*01101011))
+ (ba (bit-orc1 ba1 ba2)))
+ (and (not (eq ba1 ba))
+ (not (eq ba2 ba))
+ (not (eq ba1 ba2))
+ (equal ba #*01111111)))
+(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01010101))
+ (ba (bit-orc1 ba1 #*10101010 t)))
+ (and (eq ba1 ba)
+ (equal ba1 #*10101010)))
+(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01110001))
+ (ba (bit-orc1 ba1 #*00111110 t)))
+ (and (eq ba1 ba)
+ (equal ba1 #*10111110)))
+(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01110001))
+ (ba2 (make-array 8 :element-type 'bit :initial-contents #*00111110))
+ (ba3 (make-array 8 :element-type 'bit))
+ (ba4 (bit-orc1 ba1 ba2 ba3)))
+ (and (eq ba3 ba4)
+ (equal ba3 #*10111110)
+ (not (eq ba1 ba3))
+ (not (eq ba1 ba4))
+ (not (eq ba2 ba3))
+ (not (eq ba2 ba4))))
+(equalp (bit-orc1 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101))
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010)))
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010)))
+
+(equalp (bit-orc1 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101))
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010))
+ nil)
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010)))
+
+(equalp (bit-orc1 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101))
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010))
+ t)
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010)))
+(equalp (bit-orc1 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101))
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010))
+ (make-array '(2 3)
+ :element-type 'bit))
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010)))
+(let* ((ba1 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101)))
+ (ba2 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010)))
+ (ba (bit-orc1 ba1 ba2)))
+ (and (not (eq ba1 ba))
+ (not (eq ba2 ba))
+ (not (eq ba1 ba2))
+ (equalp ba (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010)))))
+
+(let* ((ba1 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101)))
+ (ba2 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010)))
+ (ba (bit-orc1 ba1 ba2 t)))
+ (and (eq ba1 ba)
+ (equalp ba1 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010)))))
+(let* ((ba1 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101)))
+ (ba2 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010)))
+ (ba3 (make-array '(2 3)
+ :element-type 'bit))
+ (ba4 (bit-orc1 ba1 ba2 ba3)))
+ (and (eq ba3 ba4)
+ (equalp ba3 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010)))
+ (not (eq ba1 ba3))
+ (not (eq ba1 ba4))
+ (not (eq ba2 ba3))
+ (not (eq ba2 ba4))))
+
+
+
+(equal (bit-orc2 #*11101010 #*01101011) #*11111110)
+(equal (bit-orc2 #*11101010 #*01101011 nil) #*11111110)
+(equal (bit-orc2 (make-array 8 :element-type 'bit :initial-contents #*11101010)
+ #*01101011 t)
+ #*11111110)
+(equal (bit-orc2 #*11101010
+ #*01101011
+ (make-array 8 :element-type 'bit))
+ #*11111110)
+(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*11101010))
+ (ba2 (make-array 8 :element-type 'bit :initial-contents #*01101011))
+ (ba (bit-orc2 ba1 ba2)))
+ (and (not (eq ba1 ba))
+ (not (eq ba2 ba))
+ (not (eq ba1 ba2))
+ (equal ba #*11111110)))
+(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01010101))
+ (ba (bit-orc2 ba1 #*10101010 t)))
+ (and (eq ba1 ba)
+ (equal ba1 #*01010101)))
+(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01110001))
+ (ba (bit-orc2 ba1 #*00111110 t)))
+ (and (eq ba1 ba)
+ (equal ba1 #*11110001)))
+(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01110001))
+ (ba2 (make-array 8 :element-type 'bit :initial-contents #*00111110))
+ (ba3 (make-array 8 :element-type 'bit))
+ (ba4 (bit-orc2 ba1 ba2 ba3)))
+ (and (eq ba3 ba4)
+ (equal ba3 #*11110001)
+ (not (eq ba1 ba3))
+ (not (eq ba1 ba4))
+ (not (eq ba2 ba3))
+ (not (eq ba2 ba4))))
+(equalp (bit-orc2 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101))
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010)))
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101)))
+
+(equalp (bit-orc2 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101))
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010))
+ nil)
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101)))
+
+(equalp (bit-orc2 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101))
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010))
+ t)
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101)))
+
+(equalp (bit-orc2 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101))
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010))
+ (make-array '(2 3)
+ :element-type 'bit))
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101)))
+
+(let* ((ba1 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101)))
+ (ba2 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010)))
+ (ba (bit-orc2 ba1 ba2)))
+ (and (not (eq ba1 ba))
+ (not (eq ba2 ba))
+ (not (eq ba1 ba2))
+ (equalp ba (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101)))))
+
+(let* ((ba1 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101)))
+ (ba2 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010)))
+ (ba (bit-orc2 ba1 ba2 t)))
+ (and (eq ba1 ba)
+ (equalp ba1 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101)))))
+
+(let* ((ba1 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101)))
+ (ba2 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010)))
+ (ba3 (make-array '(2 3)
+ :element-type 'bit))
+ (ba4 (bit-orc2 ba1 ba2 ba3)))
+ (and (eq ba3 ba4)
+ (equalp ba3 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101)))
+ (not (eq ba1 ba3))
+ (not (eq ba1 ba4))
+ (not (eq ba2 ba3))
+ (not (eq ba2 ba4))))
+
+
+
+
+(equal (bit-xor #*11101010 #*01101011) #*10000001)
+(equal (bit-xor #*11101010 #*01101011 nil) #*10000001)
+(equal (bit-xor (make-array 8 :element-type 'bit :initial-contents #*11101010)
+ #*01101011 t)
+ #*10000001)
+(equal (bit-xor #*11101010
+ #*01101011
+ (make-array 8 :element-type 'bit))
+ #*10000001)
+(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*11101010))
+ (ba2 (make-array 8 :element-type 'bit :initial-contents #*01101011))
+ (ba (bit-xor ba1 ba2)))
+ (and (not (eq ba1 ba))
+ (not (eq ba2 ba))
+ (not (eq ba1 ba2))
+ (equal ba #*10000001)))
+(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01010101))
+ (ba (bit-xor ba1 #*10101010 t)))
+ (and (eq ba1 ba)
+ (equal ba1 #*11111111)))
+(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01110001))
+ (ba (bit-xor ba1 #*00111110 t)))
+ (and (eq ba1 ba)
+ (equal ba1 #*01001111)))
+(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01110001))
+ (ba2 (make-array 8 :element-type 'bit :initial-contents #*00111110))
+ (ba3 (make-array 8 :element-type 'bit))
+ (ba4 (bit-xor ba1 ba2 ba3)))
+ (and (eq ba3 ba4)
+ (equal ba3 #*01001111)
+ (not (eq ba1 ba3))
+ (not (eq ba1 ba4))
+ (not (eq ba2 ba3))
+ (not (eq ba2 ba4))))
+(equalp (bit-xor (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101))
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010)))
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*111 #*111)))
+
+(equalp (bit-xor (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101))
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010))
+ nil)
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*111 #*111)))
+
+(equalp (bit-xor (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101))
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010))
+ t)
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*111 #*111)))
+(equalp (bit-xor (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101))
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010))
+ (make-array '(2 3)
+ :element-type 'bit))
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*111 #*111)))
+(let* ((ba1 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101)))
+ (ba2 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010)))
+ (ba (bit-xor ba1 ba2)))
+ (and (not (eq ba1 ba))
+ (not (eq ba2 ba))
+ (not (eq ba1 ba2))
+ (equalp ba (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*111 #*111)))))
+
+(let* ((ba1 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101)))
+ (ba2 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010)))
+ (ba (bit-xor ba1 ba2 t)))
+ (and (eq ba1 ba)
+ (equalp ba1 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*111 #*111)))))
+(let* ((ba1 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101)))
+ (ba2 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010)))
+ (ba3 (make-array '(2 3)
+ :element-type 'bit))
+ (ba4 (bit-xor ba1 ba2 ba3)))
+ (and (eq ba3 ba4)
+ (equalp ba3 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*111 #*111)))
+ (not (eq ba1 ba3))
+ (not (eq ba1 ba4))
+ (not (eq ba2 ba3))
+ (not (eq ba2 ba4))))
+
+
+
+(equal (bit-not #*11101010) #*00010101)
+(equal (bit-not #*11101010 nil) #*00010101)
+(equal (bit-not (make-array 8 :element-type 'bit :initial-contents #*11101010)
+ t)
+ #*00010101)
+(equal (bit-not #*11101010 (make-array 8 :element-type 'bit))
+ #*00010101)
+(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*11101010))
+ (ba (bit-not ba1)))
+ (and (not (eq ba1 ba))
+ (equal ba #*00010101)))
+(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01010101))
+ (ba (bit-not ba1 t)))
+ (and (eq ba1 ba)
+ (equal ba1 #*10101010)))
+(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01110001))
+ (ba (bit-not ba1 t)))
+ (and (eq ba1 ba)
+ (equal ba1 #*10001110)))
+(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01110001))
+ (ba2 (make-array 8 :element-type 'bit))
+ (ba3 (bit-not ba1 ba2)))
+ (and (eq ba2 ba3)
+ (equal ba2 #*10001110)
+ (not (eq ba1 ba2))
+ (not (eq ba1 ba3))))
+
+(equalp (bit-not (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101)))
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010)))
+
+(equalp (bit-not (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101))
+ nil)
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010)))
+
+(equalp (bit-not (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101))
+ t)
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010)))
+(equalp (bit-not (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101))
+ (make-array '(2 3)
+ :element-type 'bit))
+ (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010)))
+(let* ((ba1 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101)))
+ (ba (bit-not ba1)))
+ (and (not (eq ba1 ba))
+ (equalp ba (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010)))))
+
+
+
+(let* ((ba1 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101)))
+ (ba (bit-not ba1 t)))
+ (and (eq ba1 ba)
+ (equalp ba1 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010)))))
+(let* ((ba1 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*010 #*101)))
+ (ba3 (make-array '(2 3)
+ :element-type 'bit))
+ (ba4 (bit-not ba1 ba3)))
+ (and (eq ba3 ba4)
+ (equalp ba3 (make-array '(2 3)
+ :element-type 'bit
+ :initial-contents '(#*101 #*010)))
+ (not (eq ba1 ba3))
+ (not (eq ba1 ba4))))
+
+
+
+(bit-vector-p (make-array 6 :element-type 'bit :fill-pointer t))
+(bit-vector-p #*)
+(not (bit-vector-p (make-array 6)))
+
+(not (simple-bit-vector-p (make-array 6)))
+(simple-bit-vector-p #*)
+(simple-bit-vector-p #*0101)
+(simple-bit-vector-p #*0)
+(simple-bit-vector-p #*1)
+(simple-bit-vector-p (make-array 6 :element-type 'bit))
+
+(equal (concatenate 'list
+ (adjust-array (make-array 5 :initial-contents '(0 1 2 3 4))
+ 10
+ :initial-element -1))
+ '(0 1 2 3 4 -1 -1 -1 -1 -1))
+
+
+(let* ((array0 (make-array '(3 2)
+ :initial-contents
+ '((e0-0 e0-1) (e1-0 e1-1) (e2-0 e2-1))))
+ (array (adjust-array array0
+ '(4 3)
+ :initial-element 0)))
+ (and (eq (aref array 0 0) 'e0-0)
+ (eq (aref array 0 1) 'e0-1)
+ (eql (aref array 0 2) '0)
+ (eq (aref array 1 0) 'e1-0)
+ (eq (aref array 1 1) 'e1-1)
+ (eql (aref array 1 2) 0)
+ (eq (aref array 2 0) 'e2-0)
+ (eq (aref array 2 1) 'e2-1)
+ (eql (aref array 2 2) 0)))
+
+
+(let* ((array0 (make-array '(3 2)
+ :initial-contents
+ '((e0-0 e0-1) (e1-0 e1-1) (e2-0 e2-1))))
+ (array (adjust-array array0
+ '(1 1)
+ :initial-element 0)))
+ (eq (aref array 0 0) 'e0-0))
+
+
+(let* ((array0 (make-array '(3 2) :initial-element 0))
+ (array1 (make-array 6 :initial-element 1))
+ (array (adjust-array array1 3 :displaced-to array0)))
+ (and (equal (array-dimensions array) '(3))
+ (every #'zerop array)))
+
+
+
+(let* ((array0 (make-array '(3 2) :initial-contents '((0 1) (2 3) (4 5))))
+ (array1 (make-array 6 :initial-element 1))
+ (array (adjust-array array1 3
+ :displaced-to array0
+ :displaced-index-offset 3)))
+ (and (equal (array-dimensions array) '(3))
+ (eql (aref array 0) 3)
+ (eql (aref array 1) 4)
+ (eql (aref array 2) 5)))
+
+
+(let* ((array0 (make-array '(3 2) :initial-contents '((0 1) (2 3) (4 5))))
+ (array1 (make-array 6 :displaced-to array0))
+ (array (adjust-array array1 9 :initial-element '-1)))
+ (and (equal (array-dimensions array) '(9))
+ (multiple-value-bind (displaced-to displaced-index-offset)
+ (array-displacement array)
+ (and (null displaced-to) (zerop displaced-index-offset)))
+ (eql (aref array 0) 0)
+ (eql (aref array 1) 1)
+ (eql (aref array 2) 2)
+ (eql (aref array 3) 3)
+ (eql (aref array 4) 4)
+ (eql (aref array 5) 5)
+ (eql (aref array 6) -1)
+ (eql (aref array 7) -1)
+ (eql (aref array 8) -1)))
+
+
+(let* ((array0 (make-array '(4 4)
+ :adjustable t
+ :initial-contents
+ '(( alpha beta gamma delta )
+ ( epsilon zeta eta theta )
+ ( iota kappa lambda mu )
+ ( nu xi omicron pi ))))
+ (array (adjust-array array0 '(3 5) :initial-element 'baz)))
+ (equalp array
+ #2A(( alpha beta gamma delta baz )
+ ( epsilon zeta eta theta baz )
+ ( iota kappa lambda mu baz ))))
+
+
+(let* ((array0 (make-array 3 :initial-element 0))
+ (array1 (make-array 3 :adjustable t :displaced-to array0))
+ (array2 (make-array 3 :displaced-to array1)))
+ (and (adjustable-array-p array1)
+ (eq array1 (adjust-array array1 6 :initial-contents '(a b c d e f)))
+ (multiple-value-bind (displaced-to displaced-index-offset)
+ (array-displacement array1)
+ (and (null displaced-to) (zerop displaced-index-offset)))
+ (eq (aref array1 0) 'a)
+ (eq (aref array1 1) 'b)
+ (eq (aref array1 2) 'c)
+ (eq (aref array1 3) 'd)
+ (eq (aref array1 4) 'e)
+ (eq (aref array1 5) 'f)
+ (eq (aref array2 0) 'a)
+ (eq (aref array2 1) 'b)
+ (eq (aref array2 2) 'c)))
+
+(let* ((str0 (make-array 10
+ :element-type 'character
+ :initial-contents "abcdefghij"))
+ (str1 (make-array 7
+ :adjustable t
+ :element-type 'character
+ :displaced-to str0
+ :displaced-index-offset 3))
+ (str2 (make-array 3
+ :element-type 'character
+ :displaced-to str1
+ :displaced-index-offset 4)))
+ (and (string= str0 "abcdefghij")
+ (string= str1 "defghij")
+ (string= str2 "hij")
+ (adjustable-array-p str1)
+ (eq str1 (adjust-array str1 10 :initial-contents "QRSTUVWXYZ"))
+ (string= str2 "UVW")))
+
+
+(let* ((bv (make-array 10
+ :element-type 'bit
+ :initial-contents #*1010101010
+ :fill-pointer t)))
+ (and (dotimes (i 10 t)
+ (unless (eql (vector-pop bv) (if (evenp i) 0 1))
+ (return nil)))
+ (zerop (length bv))))
+
+(let* ((bv (make-array 10
+ :adjustable t
+ :element-type 'bit
+ :fill-pointer 0)))
+ (dotimes (i 100)
+ (vector-push-extend (if (oddp i) 0 1) bv))
+ (dotimes (i 100 t)
+ (unless (eql (vector-pop bv) (if (oddp i) 1 0))
+ (return nil))))
+
+
+
+(let* ((str (make-array 10
+ :element-type 'character
+ :initial-contents "abcdefghjk"
+ :fill-pointer t)))
+ (and (dotimes (i 10 t)
+ (unless (char= (vector-pop str) (aref "kjhgfedcba" i))
+ (return nil)))
+ (zerop (length str))))
+
+(let* ((str (make-array 10
+ :adjustable t
+ :element-type 'character
+ :fill-pointer 0)))
+ (dotimes (i 100)
+ (vector-push-extend (if (oddp i) #\a #\z) str))
+ (dotimes (i 100 t)
+ (unless (char= (vector-pop str) (if (oddp i) #\z #\a))
+ (return nil))))
+
+
diff --git a/Sacla/tests/must-character.lisp b/Sacla/tests/must-character.lisp
new file mode 100644
index 0000000..3cd9aa6
--- /dev/null
+++ b/Sacla/tests/must-character.lisp
@@ -0,0 +1,537 @@
+;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
+;; ALL RIGHTS RESERVED.
+;;
+;; $Id: must-character.lisp,v 1.6 2004/02/20 07:23:42 yuji Exp $
+;;
+;; 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.
+;;
+;; 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.
+
+(char= #\d #\d)
+(not (char= #\A #\a))
+(not (char= #\d #\x))
+(not (char= #\d #\D))
+(not (char/= #\d #\d))
+(char/= #\d #\x)
+(char/= #\d #\D)
+(char= #\d #\d #\d #\d)
+(not (char/= #\d #\d #\d #\d))
+(not (char= #\d #\d #\x #\d))
+(not (char/= #\d #\d #\x #\d))
+(not (char= #\d #\y #\x #\c))
+(char/= #\d #\y #\x #\c)
+(not (char= #\d #\c #\d))
+(not (char/= #\d #\c #\d))
+(char< #\d #\x)
+(char<= #\d #\x)
+(not (char< #\d #\d))
+(char<= #\d #\d)
+(char< #\a #\e #\y #\z)
+(char<= #\a #\e #\y #\z)
+(not (char< #\a #\e #\e #\y))
+(char<= #\a #\e #\e #\y)
+(char> #\e #\d)
+(char>= #\e #\d)
+(char> #\d #\c #\b #\a)
+(char>= #\d #\c #\b #\a)
+(not (char> #\d #\d #\c #\a))
+(char>= #\d #\d #\c #\a)
+(not (char> #\e #\d #\b #\c #\a))
+(not (char>= #\e #\d #\b #\c #\a))
+(char-equal #\A #\a)
+(equal (stable-sort (list #\b #\A #\B #\a #\c #\C) #'char-lessp)
+ '(#\A #\a #\b #\B #\c #\C))
+
+(char= #\a)
+(char= #\a #\a)
+(char= #\a #\a #\a)
+(char= #\a #\a #\a #\a)
+(char= #\a #\a #\a #\a #\a)
+(char= #\a #\a #\a #\a #\a #\a)
+(let ((c #\z))
+ (and (eq c c)
+ (char= c c)))
+(not (char= #\Z #\z))
+(not (char= #\z #\z #\z #\a))
+(not (char= #\a #\z #\z #\z #\a))
+(not (char= #\z #\i #\z #\z))
+(not (char= #\z #\z #\Z #\z))
+
+(char/= #\a)
+(char/= #\a #\b)
+(char/= #\a #\b #\c)
+(char/= #\a #\b #\c #\d)
+(char/= #\a #\b #\c #\d #\e)
+(char/= #\a #\b #\c #\d #\e #\f)
+(let ((c #\z))
+ (and (eq c c)
+ (not (char/= c c))))
+(char/= #\Z #\z)
+(not (char/= #\z #\z #\z #\a))
+(not (char= #\a #\z #\z #\z #\a))
+(not (char= #\z #\i #\z #\z))
+(not (char= #\z #\z #\Z #\z))
+(not (char/= #\a #\a #\b #\c))
+(not (char/= #\a #\b #\a #\c))
+(not (char/= #\a #\b #\c #\a))
+
+(char< #\a)
+(char< #\a #\z)
+(char< #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m
+ #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z)
+(not (char< #\z #\y #\x #\w #\v #\u #\t #\s #\r #\q #\p #\o #\n
+ #\m #\l #\k #\j #\i #\h #\g #\f #\e #\d #\c #\b #\a))
+(char< #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M
+ #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z)
+(not (char< #\Z #\Y #\X #\W #\V #\U #\T #\S #\R #\Q #\P #\O #\N
+ #\M #\L #\K #\J #\I #\H #\G #\F #\E #\D #\C #\B #\A))
+(char< #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
+(not (char< #\9 #\8 #\7 #\6 #\5 #\4 #\3 #\2 #\1 #\0))
+(or (char< #\9 #\A)
+ (char< #\Z #\0))
+(or (char< #\9 #\a)
+ (char< #\z #\0))
+(not (char< #\a #\a #\b #\c))
+(not (char< #\a #\b #\a #\c))
+(not (char< #\a #\b #\c #\a))
+(not (char< #\9 #\0))
+
+(char> #\a)
+(not (char> #\a #\z))
+(char> #\z #\a)
+(not (char> #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m
+ #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z))
+(char> #\z #\y #\x #\w #\v #\u #\t #\s #\r #\q #\p #\o #\n
+ #\m #\l #\k #\j #\i #\h #\g #\f #\e #\d #\c #\b #\a)
+(not (char> #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M
+ #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z))
+(char> #\Z #\Y #\X #\W #\V #\U #\T #\S #\R #\Q #\P #\O #\N
+ #\M #\L #\K #\J #\I #\H #\G #\F #\E #\D #\C #\B #\A)
+(not (char> #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
+(char> #\9 #\8 #\7 #\6 #\5 #\4 #\3 #\2 #\1 #\0)
+(or (char> #\A #\9)
+ (char> #\0 #\Z))
+(or (char> #\a #\9)
+ (char> #\0 #\z))
+(not (char> #\a #\a #\b #\c))
+(not (char> #\a #\b #\a #\c))
+(not (char> #\a #\b #\c #\a))
+(char> #\9 #\0)
+
+(char<= #\a)
+(char<= #\a #\z)
+(char<= #\a #\a)
+(char<= #\Z #\Z)
+(char<= #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m
+ #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z)
+(char<= #\a #\a #\b #\b #\c #\c #\d #\d #\e #\e #\f #\f #\g #\g
+ #\h #\h #\i #\i #\j #\j #\k #\k #\l #\l #\m #\m
+ #\n #\n #\o #\o #\p #\p #\q #\q #\r #\r #\s #\s
+ #\t #\t #\u #\u #\v #\v #\w #\w #\x #\x #\y #\y #\z #\z)
+(not (char<= #\z #\y #\x #\w #\v #\u #\t #\s #\r #\q #\p #\o #\n
+ #\m #\l #\k #\j #\i #\h #\g #\f #\e #\d #\c #\b #\a))
+(char<= #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M
+ #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z)
+(char<= #\A #\B #\B #\C #\D #\E #\E #\F #\G #\H #\I #\I #\J #\K #\L #\M
+ #\N #\N #\O #\P #\Q #\R #\S #\T #\T #\U #\V #\W #\X #\Y #\Z)
+(not (char<= #\Z #\Y #\X #\W #\V #\U #\T #\S #\R #\Q #\P #\O #\N
+ #\M #\L #\K #\J #\I #\H #\G #\F #\E #\D #\C #\B #\A))
+(char<= #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
+(char<= #\0 #\1 #\2 #\2 #\3 #\3 #\3 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\9)
+(not (char<= #\9 #\8 #\7 #\6 #\5 #\4 #\3 #\2 #\1 #\0))
+(or (char<= #\9 #\A)
+ (char<= #\Z #\0))
+(or (char<= #\9 #\a)
+ (char<= #\z #\0))
+(char<= #\a #\a #\b #\c)
+(not (char<= #\a #\b #\a #\c))
+(not (char<= #\a #\b #\c #\a))
+(not (char<= #\9 #\0))
+
+(char>= #\a)
+(not (char>= #\a #\z))
+(char>= #\z #\a)
+(char>= #\a #\a)
+(char>= #\Z #\Z)
+(not (char>= #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m
+ #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z))
+(char>= #\z #\y #\x #\w #\v #\u #\t #\s #\r #\q #\p #\o #\n
+ #\m #\l #\k #\j #\i #\h #\g #\f #\e #\d #\c #\b #\a)
+(char>= #\z #\z #\y #\x #\w #\v #\u #\t #\s #\r #\q #\p #\o #\n #\n
+ #\m #\m #\l #\k #\j #\i #\h #\g #\f #\e #\d #\c #\b #\a #\a)
+(not (char>= #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M
+ #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z))
+(char>= #\Z #\Y #\X #\W #\V #\U #\T #\S #\R #\Q #\P #\O #\N
+ #\M #\L #\K #\J #\I #\H #\G #\F #\E #\D #\C #\B #\A)
+(char>= #\Z #\Y #\X #\W #\V #\U #\U #\T #\T #\S #\S #\R #\Q #\P #\O #\N
+ #\M #\L #\K #\J #\I #\H #\H #\G #\G #\F #\F #\E #\D #\C #\B #\A)
+(not (char>= #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
+(char>= #\9 #\8 #\7 #\6 #\5 #\4 #\3 #\2 #\1 #\0)
+(char>= #\9 #\8 #\8 #\8 #\7 #\6 #\5 #\4 #\3 #\3 #\3 #\2 #\1 #\0)
+(or (char>= #\A #\9)
+ (char>= #\0 #\Z))
+(or (char>= #\a #\9)
+ (char>= #\0 #\z))
+(char>= #\c #\b #\a #\a)
+(not (char>= #\c #\b #\a #\a #\b #\c))
+(not (char>= #\c #\b #\a #\c))
+(not (char>= #\c #\b #\c #\a))
+(char>= #\9 #\0)
+(not (char>= #\0 #\9))
+
+
+(char-equal #\a)
+(char-equal #\a #\a)
+(char-equal #\a #\a #\a)
+(char-equal #\a #\a #\a #\a)
+(char-equal #\a #\a #\a #\a #\a)
+(char-equal #\a #\a #\a #\a #\a #\a)
+(char-equal #\a #\A)
+(char-equal #\a #\A #\a)
+(char-equal #\a #\a #\A #\a)
+(char-equal #\a #\a #\a #\A #\a)
+(char-equal #\a #\a #\a #\a #\A #\a)
+(let ((c #\z))
+ (and (eq c c)
+ (char-equal c c)))
+(char-equal #\Z #\z)
+(not (char-equal #\z #\z #\z #\a))
+(not (char-equal #\a #\z #\z #\z #\a))
+(not (char-equal #\z #\i #\z #\z))
+(char-equal #\z #\z #\Z #\z)
+(char-equal #\a #\A #\a #\A #\a #\A #\a #\A #\a #\A)
+
+
+(char-not-equal #\a)
+(char-not-equal #\a #\b)
+(char-not-equal #\a #\b #\c)
+(char-not-equal #\a #\b #\c #\d)
+(char-not-equal #\a #\b #\c #\d #\e)
+(char-not-equal #\a #\b #\c #\d #\e #\f)
+(let ((c #\z))
+ (and (eq c c)
+ (not (char-not-equal c c))))
+(not (char-not-equal #\Z #\z))
+(not (char-not-equal #\z #\z #\z #\a))
+(not (char= #\a #\z #\z #\z #\a))
+(not (char= #\z #\i #\z #\z))
+(not (char= #\z #\z #\Z #\z))
+(not (char-not-equal #\a #\a #\b #\c))
+(not (char-not-equal #\a #\b #\a #\c))
+(not (char-not-equal #\a #\b #\c #\a))
+(not (char-not-equal #\a #\A #\a #\A))
+
+
+(char-lessp #\a)
+(char-lessp #\a #\z)
+(char-lessp #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m
+ #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z)
+(not (char-lessp #\z #\y #\x #\w #\v #\u #\t #\s #\r #\q #\p #\o #\n
+ #\m #\l #\k #\j #\i #\h #\g #\f #\e #\d #\c #\b #\a))
+(char-lessp #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M
+ #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z)
+(not (char-lessp #\Z #\Y #\X #\W #\V #\U #\T #\S #\R #\Q #\P #\O #\N
+ #\M #\L #\K #\J #\I #\H #\G #\F #\E #\D #\C #\B #\A))
+(char-lessp #\a #\B #\c #\D #\e #\F #\g #\H #\i #\J #\k #\L #\m
+ #\N #\o #\P #\q #\R #\s #\T #\u #\V #\w #\X #\y #\Z)
+(char-lessp #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
+(not (char-lessp #\9 #\8 #\7 #\6 #\5 #\4 #\3 #\2 #\1 #\0))
+(or (char-lessp #\9 #\A)
+ (char-lessp #\Z #\0))
+(or (char-lessp #\9 #\a)
+ (char-lessp #\z #\0))
+(not (char-lessp #\a #\a #\b #\c))
+(not (char-lessp #\a #\b #\a #\c))
+(not (char-lessp #\a #\b #\c #\a))
+(not (char-lessp #\9 #\0))
+(and (char-lessp #\a #\Z)
+ (char-lessp #\A #\z))
+
+
+(char-greaterp #\a)
+(not (char-greaterp #\a #\z))
+(char-greaterp #\z #\a)
+(not (char-greaterp #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m
+ #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z))
+(char-greaterp #\z #\y #\x #\w #\v #\u #\t #\s #\r #\q #\p #\o #\n
+ #\m #\l #\k #\j #\i #\h #\g #\f #\e #\d #\c #\b #\a)
+(not (char-greaterp #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M
+ #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z))
+(char-greaterp #\Z #\Y #\X #\W #\V #\U #\T #\S #\R #\Q #\P #\O #\N
+ #\M #\L #\K #\J #\I #\H #\G #\F #\E #\D #\C #\B #\A)
+(char-greaterp #\z #\Y #\x #\W #\v #\U #\t #\S #\r #\Q #\p #\O #\n
+ #\M #\l #\K #\j #\I #\h #\G #\f #\E #\d #\C #\b #\A)
+(not (char-greaterp #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
+(char-greaterp #\9 #\8 #\7 #\6 #\5 #\4 #\3 #\2 #\1 #\0)
+(or (char-greaterp #\A #\9)
+ (char-greaterp #\0 #\Z))
+(or (char-greaterp #\a #\9)
+ (char-greaterp #\0 #\z))
+(not (char-greaterp #\a #\a #\b #\c))
+(not (char-greaterp #\a #\b #\a #\c))
+(not (char-greaterp #\a #\b #\c #\a))
+(char-greaterp #\9 #\0)
+(and (char-greaterp #\z #\A)
+ (char-greaterp #\Z #\a))
+
+
+
+(char-not-greaterp #\a)
+(char-not-greaterp #\a #\z)
+(char-not-greaterp #\a #\a)
+(char-not-greaterp #\Z #\Z)
+(char-not-greaterp
+ #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m
+ #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z)
+(char-not-greaterp
+ #\a #\a #\b #\b #\c #\c #\d #\d #\e #\e #\f #\f #\g #\g
+ #\h #\h #\i #\i #\j #\j #\k #\k #\l #\l #\m #\m
+ #\n #\n #\o #\o #\p #\p #\q #\q #\r #\r #\s #\s
+ #\t #\t #\u #\u #\v #\v #\w #\w #\x #\x #\y #\y #\z #\z)
+(char-not-greaterp
+ #\a #\A #\b #\B #\c #\C #\d #\D #\e #\E #\f #\F #\g #\G
+ #\h #\H #\i #\I #\j #\J #\k #\K #\l #\L #\m #\M
+ #\n #\N #\o #\O #\p #\P #\q #\Q #\r #\R #\s #\S
+ #\t #\T #\u #\U #\v #\V #\w #\W #\x #\X #\y #\Y #\z #\z)
+(not (char-not-greaterp
+ #\z #\y #\x #\w #\v #\u #\t #\s #\r #\q #\p #\o #\n
+ #\m #\l #\k #\j #\i #\h #\g #\f #\e #\d #\c #\b #\a))
+(char-not-greaterp
+ #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M
+ #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z)
+(char-not-greaterp
+ #\A #\B #\B #\C #\D #\E #\E #\F #\G #\H #\I #\I #\J #\K #\L #\M
+ #\N #\N #\O #\P #\Q #\R #\S #\T #\T #\U #\V #\W #\X #\Y #\Z)
+(not (char-not-greaterp
+ #\Z #\Y #\X #\W #\V #\U #\T #\S #\R #\Q #\P #\O #\N
+ #\M #\L #\K #\J #\I #\H #\G #\F #\E #\D #\C #\B #\A))
+(char-not-greaterp #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
+(char-not-greaterp #\0 #\1 #\2 #\2 #\3 #\3 #\3 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\9)
+(not (char-not-greaterp #\9 #\8 #\7 #\6 #\5 #\4 #\3 #\2 #\1 #\0))
+(or (char-not-greaterp #\9 #\A)
+ (char-not-greaterp #\Z #\0))
+(or (char-not-greaterp #\9 #\a)
+ (char-not-greaterp #\z #\0))
+(char-not-greaterp #\a #\a #\b #\c)
+(not (char-not-greaterp #\a #\b #\a #\c))
+(not (char-not-greaterp #\a #\b #\c #\a))
+(not (char-not-greaterp #\9 #\0))
+(and (char-not-greaterp #\A #\z)
+ (char-not-greaterp #\a #\Z))
+
+
+(char-not-lessp #\a)
+(not (char-not-lessp #\a #\z))
+(char-not-lessp #\z #\a)
+(char-not-lessp #\a #\a)
+(char-not-lessp #\Z #\Z)
+(not (char-not-lessp #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m
+ #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z))
+(char-not-lessp #\z #\y #\x #\w #\v #\u #\t #\s #\r #\q #\p #\o #\n
+ #\m #\l #\k #\j #\i #\h #\g #\f #\e #\d #\c #\b #\a)
+(char-not-lessp #\z #\z #\y #\x #\w #\v #\u #\t #\s #\r #\q #\p #\o #\n #\n
+ #\m #\m #\l #\k #\j #\i #\h #\g #\f #\e #\d #\c #\b #\a #\a)
+(not (char-not-lessp #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M
+ #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z))
+(char-not-lessp #\Z #\Y #\X #\W #\V #\U #\T #\S #\R #\Q #\P #\O #\N
+ #\M #\L #\K #\J #\I #\H #\G #\F #\E #\D #\C #\B #\A)
+(char-not-lessp #\Z #\Y #\X #\W #\V #\U #\U #\T #\T #\S #\S #\R #\Q #\P #\O #\N
+ #\M #\L #\K #\J #\I #\H #\H #\G #\G #\F #\F #\E #\D #\C #\B #\A)
+(char-not-lessp #\z #\Z #\y #\x #\w #\V #\v #\u #\t #\s #\r #\q #\p #\o #\n #\n
+ #\m #\M #\l #\k #\K #\j #\i #\h #\g #\f #\e #\d #\c #\b #\A #\a)
+(not (char-not-lessp #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
+(char-not-lessp #\9 #\8 #\7 #\6 #\5 #\4 #\3 #\2 #\1 #\0)
+(char-not-lessp #\9 #\8 #\8 #\8 #\7 #\6 #\5 #\4 #\3 #\3 #\3 #\2 #\1 #\0)
+(or (char-not-lessp #\A #\9)
+ (char-not-lessp #\0 #\Z))
+(or (char-not-lessp #\a #\9)
+ (char-not-lessp #\0 #\z))
+(char-not-lessp #\c #\b #\a #\a)
+(not (char-not-lessp #\c #\b #\a #\a #\b #\c))
+(not (char-not-lessp #\c #\b #\a #\c))
+(not (char-not-lessp #\c #\b #\c #\a))
+(char-not-lessp #\9 #\0)
+(not (char-not-lessp #\0 #\9))
+(and (char-not-lessp #\z #\A)
+ (char-not-lessp #\Z #\a))
+
+(char= (character #\a) #\a)
+(char= (character #\b) #\b)
+(char= (character #\Space) #\Space)
+(char= (character "a") #\a)
+(char= (character "X") #\X)
+(char= (character "z") #\z)
+(char= (character 'a) #\A)
+(char= (character '\a) #\a)
+
+(alpha-char-p #\a)
+(every #'alpha-char-p '(#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m
+ #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z))
+(every #'alpha-char-p '(#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M
+ #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z))
+(notany #'alpha-char-p '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
+(not (alpha-char-p #\Newline))
+
+(alphanumericp #\Z)
+(alphanumericp #\9)
+(every #'alphanumericp '(#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m
+ #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z))
+(every #'alphanumericp '(#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M
+ #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z))
+(every #'alphanumericp '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
+(not (alphanumericp #\Newline))
+(not (alphanumericp #\#))
+
+(char= (digit-char 0) #\0)
+(char= (digit-char 10 11) #\A)
+(null (digit-char 10 10))
+(char= (digit-char 7) #\7)
+(null (digit-char 12))
+(char= (digit-char 12 16) #\C)
+(null (digit-char 6 2))
+(char= (digit-char 1 2) #\1)
+(char= (digit-char 35 36) #\Z)
+
+(do ((radix 2 (1+ radix)))
+ ((= radix 37) t)
+ (unless (dotimes (i radix t)
+ (unless (char= (digit-char i radix)
+ (svref #(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9
+ #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J
+ #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T
+ #\U #\V #\W #\X #\Y #\Z) i))
+ (return nil)))
+ (return nil)))
+
+
+(= (digit-char-p #\0) 0)
+(= (digit-char-p #\5) 5)
+(not (digit-char-p #\5 2))
+(not (digit-char-p #\A))
+(not (digit-char-p #\a))
+(= (digit-char-p #\A 11) 10)
+(= (digit-char-p #\a 11) 10)
+(equal (mapcar #'(lambda (radix)
+ (map 'list #'(lambda (x) (digit-char-p x radix))
+ "059AaFGZ"))
+ '(2 8 10 16 36))
+ '((0 NIL NIL NIL NIL NIL NIL NIL)
+ (0 5 NIL NIL NIL NIL NIL NIL)
+ (0 5 9 NIL NIL NIL NIL NIL)
+ (0 5 9 10 10 15 NIL NIL)
+ (0 5 9 10 10 15 16 35)))
+
+(do ((radix 2 (1+ radix)))
+ ((= radix 37) t)
+ (unless (dotimes (i radix t)
+ (unless (= (digit-char-p (schar
+ "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" i)
+ radix)
+ i)
+ (return nil)))
+ (return nil)))
+
+(do ((radix 2 (1+ radix)))
+ ((= radix 37) t)
+ (unless (dotimes (i radix t)
+ (unless (= (digit-char-p (schar
+ "0123456789abcdefghijklmnopqrstuvwxyz" i)
+ radix)
+ i)
+ (return nil)))
+ (return nil)))
+
+
+(graphic-char-p #\G)
+(graphic-char-p #\#)
+(graphic-char-p #\Space)
+(not (graphic-char-p #\Newline))
+
+(standard-char-p #\a)
+(standard-char-p #\z)
+(standard-char-p #\Newline)
+(every #'standard-char-p " !\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_'abcdefghijklmnopqrstuvwxyz{|}~
+")
+
+
+(char= (char-upcase #\a) #\A)
+(char= (char-upcase #\A) #\A)
+(char= (char-upcase #\-) #\-)
+(char= (char-downcase #\A) #\a)
+(char= (char-downcase #\a) #\a)
+(char= (char-downcase #\-) #\-)
+(not (upper-case-p #\a))
+(upper-case-p #\A)
+(not (upper-case-p #\-))
+(not (lower-case-p #\A))
+(lower-case-p #\a)
+(not (lower-case-p #\-))
+(both-case-p #\a)
+(both-case-p #\A)
+(not (both-case-p #\-))
+
+(let ((chars " !\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_'abcdefghijklmnopqrstuvwxyz{|}~
+")
+ c)
+ (dotimes (i (length chars) t)
+ (setq c (schar chars i))
+ (cond
+ ((upper-case-p c)
+ (unless (and (both-case-p c)
+ (not (lower-case-p c))
+ (char= (char-upcase c) c)
+ (not (char= (char-downcase c) c)))
+ (return nil)))
+ ((lower-case-p c)
+ (unless (and (both-case-p c)
+ (char= (char-downcase c) c)
+ (not (char= (char-upcase c) c)))
+ (return nil)))
+ (t
+ (unless (and (not (upper-case-p c))
+ (not (lower-case-p c))
+ (not (both-case-p c))
+ (char= (char-upcase c) c)
+ (char= (char-downcase c) c))
+ (return nil))))))
+
+(every (complement #'minusp)
+ (map 'list #'char-code " !\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_'abcdefghijklmnopqrstuvwxyz{|}~
+"))
+
+(every (complement #'minusp)
+ (map 'list #'char-int " !\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_'abcdefghijklmnopqrstuvwxyz{|}~
+"))
+
+
+(every #'characterp
+ (map 'list #'code-char
+ (map 'list #'char-code " !\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_'abcdefghijklmnopqrstuvwxyz{|}~
+")))
+
+(dotimes (i char-code-limit t)
+ (unless (or (null (code-char i)) (characterp (code-char i)))
+ (return nil)))
+
+(char= #\ (name-char (char-name #\ )))
+(char= #\Space (name-char (char-name #\Space)))
+(char= #\Newline (name-char (char-name #\Newline)))
diff --git a/Sacla/tests/must-condition.lisp b/Sacla/tests/must-condition.lisp
new file mode 100644
index 0000000..08e7080
--- /dev/null
+++ b/Sacla/tests/must-condition.lisp
@@ -0,0 +1,898 @@
+;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
+;; ALL RIGHTS RESERVED.
+;;
+;; $Id: must-condition.lisp,v 1.7 2004/02/20 07:23:42 yuji Exp $
+;;
+;; 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.
+;;
+;; 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.
+
+;; signal
+(eq (signal "test signal") nil)
+(eq (signal 'simple-error :format-control "simple-error" :format-arguments nil)
+ nil)
+(eq (signal 'simple-warning
+ :format-control "simple-warning" :format-arguments nil)
+ nil)
+(handler-case (signal "test simple-condition")
+ (simple-condition () t)
+ (condition () nil)
+ (:no-error (&rest rest) (declare (ignore rest)) nil))
+(handler-case (signal 'simple-warning :format-control "simple warning"
+ :format-arguments nil)
+ (simple-warning () t)
+ (warning () nil)
+ (condition () nil)
+ (:no-error (&rest rest) (declare (ignore rest)) nil))
+(handler-case (signal 'type-error :datum nil :expected-type 'vector)
+ (type-error () t)
+ (error () nil)
+ (:no-error (&rest rest) (declare (ignore rest)) nil))
+(let ((*break-on-signals* 'arithmetic-error))
+ (handler-case (signal 'type-error :datum nil :expected-type 'vector)
+ (type-error () t)
+ (error () nil)
+ (:no-error (&rest rest) (declare (ignore rest)) nil)))
+
+
+;; error
+(handler-case (error "simple-error test")
+ (simple-error () t)
+ (error () nil)
+ (:no-error (&rest rest) (declare (ignore rest)) nil))
+(handler-case (error 'type-error :datum nil :expected-type 'vector)
+ (type-error () t)
+ (error () nil)
+ (:no-error (&rest rest) (declare (ignore rest)) nil))
+(handler-case (error 'no-such-error!!)
+ (type-error () t)
+ (error () nil)
+ (:no-error (&rest rest) (declare (ignore rest)) nil))
+(handler-case (error 'simple-condition :format-control "simple-condition test")
+ (simple-condition () t)
+ (error () nil)
+ (:no-error (&rest rest) (declare (ignore rest)) nil))
+(handler-case (error 'simple-warning :format-control "simple-warning test")
+ (simple-warning () t)
+ (error () nil)
+ (:no-error (&rest rest) (declare (ignore rest)) nil))
+
+
+
+;; cerror
+(handler-case (cerror "Continue." "error test")
+ (simple-error () t)
+ (error () nil)
+ (:no-error (&rest rest) (declare (ignore rest)) nil))
+(handler-case (cerror "Continue." 'type-error :datum nil :expected-type 'vector)
+ (type-error () t)
+ (error () nil)
+ (:no-error (&rest rest) (declare (ignore rest)) nil))
+(handler-bind ((simple-error #'(lambda (condition)
+ (declare (ignore condition))
+ (invoke-restart 'continue))))
+ (eq (cerror "Continue." "error test") nil))
+(handler-bind ((type-error #'(lambda (condition)
+ (declare (ignore condition))
+ (invoke-restart 'continue))))
+ (eq (cerror "Continue." 'type-error :datum nil :expected-type 'vector) nil))
+
+
+
+;; warn
+(let ((*error-output* (make-string-output-stream)))
+ (and (eq (warn "I warn you!") nil)
+ (get-output-stream-string *error-output*)))
+(handler-bind ((warning #'(lambda (condition)
+ (declare (ignore condition))
+ (invoke-restart 'muffle-warning))))
+ (eq (warn "I warn you!") nil))
+(let ((*error-output* (make-string-output-stream)))
+ (handler-bind ((warning #'(lambda (condition)
+ (declare (ignore condition))
+ (invoke-restart 'muffle-warning))))
+ (and (eq (warn "I warn you!") nil)
+ (string= (get-output-stream-string *error-output*) ""))))
+(block tag
+ (handler-case (warn 'simple-error
+ :format-control "boom!" :format-arguments nil)
+ (type-error () t)
+ (simple-error () nil)
+ (error () nil)
+ (:no-error (&rest rest) (declare (ignore rest)) nil)))
+(block tag
+ (handler-case (warn 'simple-condition
+ :format-control "boom!" :format-arguments nil)
+ (type-error () t)
+ (simple-condition () nil)
+ (error () nil)
+ (:no-error (&rest rest) (declare (ignore rest)) nil)))
+(block tag
+ (let ((condition (make-condition 'simple-condition
+ :format-control "boom!"
+ :format-arguments nil)))
+ (handler-case (warn condition)
+ (type-error () t)
+ (simple-condition () nil)
+ (error () nil)
+ (:no-error (&rest rest) (declare (ignore rest)) nil))))
+(block tag
+ (let ((condition (make-condition 'simple-error
+ :format-control "boom!"
+ :format-arguments nil)))
+ (handler-case (warn condition)
+ (type-error () t)
+ (simple-error () nil)
+ (error () nil)
+ (:no-error (&rest rest) (declare (ignore rest)) nil))))
+(block tag
+ (let ((condition (make-condition 'simple-warning
+ :format-control "boom!"
+ :format-arguments nil)))
+ (handler-case (warn condition)
+ (type-error () nil)
+ (simple-warning () t)
+ (error () nil)
+ (:no-error (&rest rest) (declare (ignore rest)) nil))))
+(block tag
+ (let ((condition (make-condition 'simple-warning
+ :format-control "boom!"
+ :format-arguments nil)))
+ (handler-case (warn condition :format-control "boom!" :format-arguments nil)
+ (type-error () t)
+ (simple-warning () nil)
+ (error () nil)
+ (:no-error (&rest rest) (declare (ignore rest)) nil))))
+
+
+
+;; handler-bind
+(null (handler-bind ()))
+(handler-bind () t)
+(equal (multiple-value-list (handler-bind () 1 2 3 (values 4 5 6))) '(4 5 6))
+(eq 'handled
+ (block tag (handler-bind ((type-error #'(lambda (c)
+ (declare (ignore c))
+ (return-from tag 'handled))))
+ (error 'type-error :datum nil :expected-type 'vector))))
+(eq 'handled
+ (block tag (handler-bind ((error #'(lambda (c)
+ (declare (ignore c))
+ (return-from tag 'handled))))
+ (error 'type-error :datum nil :expected-type 'vector))))
+(eq 'handled
+ (block tag (handler-bind ((condition #'(lambda (c)
+ (declare (ignore c))
+ (return-from tag 'handled))))
+ (error 'type-error :datum nil :expected-type 'vector))))
+(eq 'outer-handler
+ (block tag
+ (handler-bind ((type-error #'(lambda (c)
+ (declare (ignore c))
+ (return-from tag 'outer-handler))))
+ (handler-bind ((type-error #'(lambda (c) (error c)))
+ (type-error #'(lambda (c)
+ (declare (ignore c))
+ (return-from tag 'inner-handler))))
+ (error 'type-error :datum nil :expected-type 'vector)))))
+(eq 'outer-handler
+ (block tag
+ (handler-bind ((error #'(lambda (c)
+ (declare (ignore c))
+ (return-from tag 'outer-handler))))
+ (handler-bind ((type-error #'(lambda (c) (error c)))
+ (type-error #'(lambda (c)
+ (declare (ignore c))
+ (return-from tag 'inner-handler))))
+ (error 'type-error :datum nil :expected-type 'vector)))))
+(eq 'left-handler
+ (block tag
+ (handler-bind ((type-error #'(lambda (c)
+ (declare (ignore c))
+ (return-from tag 'left-handler)))
+ (type-error #'(lambda (c)
+ (declare (ignore c))
+ (return-from tag 'right-handler))))
+ (error 'type-error :datum nil :expected-type 'vector))))
+(eq 'left-handler
+ (block tag
+ (handler-bind ((error #'(lambda (c)
+ (declare (ignore c))
+ (return-from tag 'left-handler)))
+ (type-error #'(lambda (c)
+ (declare (ignore c))
+ (return-from tag 'right-handler))))
+ (error 'type-error :datum nil :expected-type 'vector))))
+(eq 'left-handler
+ (block tag
+ (handler-bind ((type-error #'(lambda (c)
+ (declare (ignore c))
+ (return-from tag 'left-handler)))
+ (error #'(lambda (c)
+ (declare (ignore c))
+ (return-from tag 'right-handler))))
+ (error 'type-error :datum nil :expected-type 'vector))))
+(let ((handler-declined nil))
+ (and (eq (handler-bind ((type-error #'(lambda (c)
+ (declare (ignore c))
+ (setq handler-declined t))))
+ (signal 'type-error :datum nil :expected-type 'vector))
+ nil)
+ handler-declined))
+(let ((handler-declined nil))
+ (and (eq (handler-bind ((type-error #'(lambda (c)
+ (declare (ignore c))
+ (push 'outer handler-declined))))
+ (handler-bind ((type-error #'(lambda (c)
+ (declare (ignore c))
+ (push 'inner handler-declined))))
+ (signal 'type-error :datum nil :expected-type 'vector)))
+ nil)
+ (equal handler-declined '(outer inner))))
+(let ((handler-declined nil))
+ (and (eq (handler-bind
+ ((type-error #'(lambda (c)
+ (declare (ignore c))
+ (push 'outer-left-handler handler-declined)))
+ (type-error #'(lambda (c)
+ (declare (ignore c))
+ (push 'outer-right-handler handler-declined))))
+ (handler-bind
+ ((type-error #'(lambda (c)
+ (declare (ignore c))
+ (push 'inner-left-handler handler-declined)))
+ (type-error #'(lambda (c)
+ (declare (ignore c))
+ (push 'inner-right-handler handler-declined))))
+ (signal 'type-error :datum nil :expected-type 'vector)))
+ nil)
+ (equal handler-declined '(outer-right-handler outer-left-handler
+ inner-right-handler inner-left-handler))))
+(let ((handler-declined nil))
+ (and (eq (handler-bind
+ ((type-error #'(lambda (c)
+ (declare (ignore c))
+ (push 'outer-left-handler handler-declined)))
+ (type-error #'(lambda (c)
+ (declare (ignore c))
+ (push 'outer-right-handler handler-declined))))
+ (handler-bind
+ ((type-error #'(lambda (c)
+ (declare (ignore c))
+ (push 'inner-left-handler handler-declined)))
+ (type-error #'(lambda (c)
+ (signal c)
+ (push 'inner-right-handler handler-declined))))
+ (signal 'type-error :datum nil :expected-type 'vector)))
+ nil)
+ (equal handler-declined '(outer-right-handler
+ outer-left-handler
+ inner-right-handler
+
+ outer-right-handler
+ outer-left-handler
+
+ inner-left-handler))))
+(let ((*dynamic-var* nil))
+ (declare (special *dynamic-var*))
+ (block tag
+ (handler-bind ((type-error #'(lambda (c)
+ (declare (ignore c))
+ (return-from tag *dynamic-var*))))
+ (let ((*dynamic-var* t))
+ (declare (special *dynamic-var*))
+ (signal 'type-error :datum nil :expected-type 'vector)))))
+(let ((declined nil))
+ (and (eq nil
+ (handler-bind ((simple-condition #'(lambda (c)
+ (declare (ignore c))
+ (push 'specific declined))))
+ (handler-bind ((condition #'(lambda (c)
+ (declare (ignore c))
+ (push 'general declined))))
+ (signal "error"))))
+ (equal declined '(specific general))))
+(block tag
+ (handler-bind ((error #'(lambda (c) (return-from tag (typep c 'error)))))
+ (error "error")))
+(eq 'ok
+ (block tag
+ (handler-bind ((error #'(lambda (c)
+ (declare (ignore c))
+ (return-from tag 'ok))))
+ (handler-bind ((error #'(lambda (c)
+ (declare (ignore c))
+ (error "error3"))))
+ (handler-bind ((error #'(lambda (c)
+ (declare (ignore c))
+ (error "error2"))))
+ (error "error"))))))
+(eq 'ok
+ (block tag
+ (handler-bind
+ ((error
+ #'(lambda (c)
+ (declare (ignore c))
+ (handler-bind
+ ((error #'(lambda (c)
+ (declare (ignore c))
+ (handler-bind
+ ((error #'(lambda (c)
+ (declare (ignore c))
+ (return-from tag 'ok))))
+ (error "error2")))))
+ (error "error1")))))
+ (error "error0"))))
+
+
+;; handler-case
+(handler-case t)
+(handler-case nil
+ (:no-error (&rest rest) (declare (ignore rest)) t))
+(equal (multiple-value-list (handler-case (values 0 1 2 3 4)))
+ '(0 1 2 3 4))
+(equal (handler-case (values 0 1 2 3 4)
+ (:no-error (&rest rest) rest))
+ '(0 1 2 3 4))
+(equal (multiple-value-list (handler-case (values 0 1 2 3 4)
+ (:no-error (&rest rest) (values rest 5 6 7 8))))
+ '((0 1 2 3 4) 5 6 7 8))
+(eq t (handler-case t
+ (type-error () 'type-error)
+ (error () 'error)))
+(eq 'simple-error
+ (handler-case (error "error!")
+ (simple-error () 'simple-error)
+ (error () 'error)))
+(eq 'error
+ (handler-case (error "error!")
+ (error () 'error)
+ (simple-error () 'simple-error)))
+(eq 'error
+ (handler-case (error "error!")
+ (error () 'error)
+ (condition () 'condition)
+ (simple-error () 'simple-error)))
+(eq 'condition
+ (handler-case (error "error!")
+ (condition () 'condition)
+ (error () 'error)
+ (simple-error () 'simple-error)))
+(eq 'simple-error
+ (handler-case (signal 'simple-error
+ :format-control "error!" :format-arguments nil)
+ (simple-error () 'simple-error)
+ (error () 'error)))
+(eq 'simple-error-left
+ (handler-case (signal 'simple-error
+ :format-control "error!" :format-arguments nil)
+ (simple-error () 'simple-error-left)
+ (simple-error () 'simple-error-right)))
+(eq 'no-one-handled
+ (handler-case (progn
+ (signal 'simple-warning
+ :format-control "warning!" :format-arguments nil)
+ 'no-one-handled)
+ (simple-error () 'simple-error)
+ (error () 'error)))
+(equal (handler-case (progn
+ (signal 'simple-warning
+ :format-control "warning!" :format-arguments nil)
+ 'no-one-handled)
+ (:no-error (&rest rest) (cons 'no-error rest))
+ (simple-error () 'simple-error)
+ (error () 'error))
+ '(no-error no-one-handled))
+(let ((where 'out))
+ (eq (handler-case (let ((where 'in))
+ (declare (ignorable where))
+ (error "error!"))
+ (error () where))
+ 'out))
+(let ((where 'out))
+ (declare (special where))
+ (eq (handler-case (let ((where 'in))
+ (declare (special where))
+ (error "~S" where))
+ (error () where))
+ 'out))
+(typep (handler-case (error "error!")
+ (error (c) c))
+ 'simple-error)
+(typep (handler-case (error "error!")
+ (condition (c) c))
+ 'simple-error)
+(typep (handler-case (signal "condition")
+ (condition (c) c))
+ 'simple-condition)
+(typep (handler-case (warn "warning")
+ (condition (c) c))
+ 'simple-warning)
+
+
+
+;; restart-bind
+(null (restart-bind ()))
+(restart-bind () t)
+(= (restart-bind () 0 1 2) 2)
+(equal (multiple-value-list (restart-bind () 0 1 2 (values 3 4 5))) '(3 4 5))
+(block tag
+ (restart-bind ((continue #'(lambda (&rest rest)
+ (declare (ignore rest))
+ (return-from tag t))))
+ (handler-case (signal "testing simple-signal")
+ (simple-condition () (invoke-restart 'continue)))))
+(block tag
+ (handler-bind ((simple-condition #'(lambda (condition)
+ (declare (ignore condition))
+ (invoke-restart 'continue))))
+ (restart-bind ((continue #'(lambda (&rest rest)
+ (declare (ignore rest))
+ (return-from tag t))))
+ (signal "testing simple-condition"))))
+(block tag
+ (restart-bind ((continue #'(lambda (&rest rest)
+ (declare (ignore rest))
+ (return-from tag nil))))
+ (handler-bind ((simple-condition #'(lambda (condition)
+ (declare (ignore condition))
+ (invoke-restart 'continue))))
+ (restart-bind ((continue #'(lambda (&rest rest)
+ (declare (ignore rest))
+ (return-from tag t))))
+ (signal "testing simple-condition")))))
+(block tag
+ (restart-bind ((continue #'(lambda (&rest rest)
+ (declare (ignore rest))
+ (return-from tag t)))
+ (continue #'(lambda (&rest rest)
+ (declare (ignore rest))
+ (return-from tag nil))))
+ (handler-case (signal "testing simple-signal")
+ (simple-condition () (invoke-restart 'continue)))))
+(block tag
+ (restart-bind ((continue #'(lambda (&rest rest)
+ (declare (ignore rest))
+ (return-from tag t))
+ :report-function #'(lambda (stream)
+ (format stream "Continue"))))
+ (handler-case (signal "testing simple-signal")
+ (simple-condition () (invoke-restart 'continue)))))
+(block tag
+ (restart-bind ((continue #'(lambda (x) (return-from tag x))
+ :report-function
+ #'(lambda (stream) (format stream "Continue"))
+ :interactive-function #'(lambda () (list t))))
+ (handler-case (signal "testing simple-signal")
+ (simple-condition () (invoke-restart-interactively 'continue)))))
+(eq 'ok
+ (block tag
+ (restart-bind ((continue #'(lambda (x) (return-from tag x))))
+ (handler-case (signal "testing simple-signal")
+ (simple-condition () (invoke-restart 'continue 'ok))))))
+(block tag
+ (restart-bind ((continue #'(lambda (x) (return-from tag x))
+ :report-function
+ #'(lambda (stream) (format stream "Continue"))
+ :interactive-function #'(lambda () (list t))
+ :test-function (constantly t)))
+ (handler-case (signal "testing simple-signal")
+ (simple-condition () (invoke-restart-interactively 'continue)))))
+(block tag
+ (restart-bind ((continue #'(lambda (x) (return-from tag x))
+ :report-function
+ #'(lambda (stream) (format stream "Continue"))
+ :interactive-function #'(lambda () (list t))
+ :test-function
+ #'(lambda (c) (or (null c) (typep c 'simple-condition)))))
+ (handler-case (signal "testing simple-signal")
+ (simple-condition () (invoke-restart-interactively 'continue)))))
+(block tag
+ (restart-bind ((tb-continue #'(lambda (x) (return-from tag x))
+ :interactive-function #'(lambda () (list t))
+ :test-function (constantly nil)
+ :report-function
+ #'(lambda (stream) (format stream "Continue"))))
+ (not (find-restart 'tb-continue))))
+(block tag
+ (restart-bind ((tb-continue #'(lambda (x) (return-from tag x))
+ :interactive-function #'(lambda () (list t))
+ :test-function (constantly t)
+ :report-function #'(lambda (stream) (format stream "cont."))))
+ (handler-case (signal "testing simple-signal")
+ (simple-condition () (invoke-restart-interactively 'tb-continue)))))
+(null (let ((*dynamic-var* nil))
+ (declare (special *dynamic-var*))
+ (block tag
+ (restart-bind ((continue #'(lambda (x)
+ (declare (ignore x))
+ (return-from tag *dynamic-var*))
+ :interactive-function #'(lambda () (list t))
+ :test-function (constantly t)
+ :report-function
+ #'(lambda (stream) (format stream "cont."))))
+ (handler-case (let ((*dynamic-var* t))
+ (declare (special *dynamic-var*))
+ (signal "testing simple-signal"))
+ (simple-condition () (invoke-restart-interactively 'continue)))))))
+(let ((*dynamic-var* nil))
+ (declare (special *dynamic-var*))
+ (block tag
+ (restart-bind ((continue #'(lambda (x)
+ (declare (ignore x))
+ (return-from tag *dynamic-var*))
+ :interactive-function #'(lambda () (list t))
+ :test-function (constantly t)
+ :report-function
+ #'(lambda (stream) (format stream "cont."))))
+ (handler-bind ((simple-condition
+ #'(lambda (c)
+ (declare (ignore c))
+ (invoke-restart-interactively 'continue))))
+ (let ((*dynamic-var* t))
+ (declare (special *dynamic-var*))
+ (signal "testing simple-signal"))))))
+(block tag
+ (restart-bind ((nil #'(lambda (&rest rest)
+ (declare (ignore rest))
+ (return-from tag t))))
+ (handler-case (signal "testing simple-signal")
+ (simple-condition () (invoke-restart 'nil)))))
+
+
+
+;; restart-case
+(restart-case t)
+(restart-case t
+ (continue (&rest rest) (declare (ignore rest)) nil))
+(equal (multiple-value-list (restart-case (values 0 1 2 3 4))) '(0 1 2 3 4))
+(eq 'continued
+ (restart-case (continue)
+ (continue (&rest rest) (declare (ignore rest)) 'continued)))
+(eq nil
+ (restart-case (continue)
+ (continue (&rest rest) (declare (ignore rest)))))
+(eq 'continue-left
+ (restart-case (continue)
+ (continue (&rest rest) (declare (ignore rest)) 'continue-left)
+ (continue (&rest rest) (declare (ignore rest)) 'continue-right)))
+(null (restart-case (invoke-restart 'continue)
+ (continue (&rest rest)
+ :interactive (lambda () (list 0 1 2 3))
+ rest)))
+(equal (restart-case (invoke-restart-interactively 'continue)
+ (continue (&rest rest)
+ :interactive (lambda () (list 0 1 2 3))
+ rest))
+ '(0 1 2 3))
+(equal (restart-case (invoke-restart-interactively 'continue)
+ (continue (&rest rest)
+ :interactive (lambda () (list 0 1 2 3))
+ :report "continue"
+ rest))
+ '(0 1 2 3))
+(equal (restart-case (invoke-restart-interactively 'continue)
+ (continue (&rest rest)
+ :interactive (lambda () (list 0 1 2 3))
+ :report "continue"
+ :test (lambda (c) (declare (ignore c)) t)
+ rest))
+ '(0 1 2 3))
+(= (restart-case
+ (handler-bind ((error #'(lambda (c)
+ (declare (ignore c))
+ (invoke-restart 'my-restart 7))))
+ (error "Foo."))
+ (my-restart (&optional v) v))
+ 7)
+(eq (handler-bind ((error #'(lambda (c)
+ (declare (ignore c))
+ (invoke-restart 'my-restart 'restarted))))
+ (restart-case (error "Boo.")
+ (my-restart (&optional v) v)))
+ 'restarted)
+(eq (handler-bind ((error #'(lambda (c)
+ (invoke-restart (find-restart 'my-restart c)
+ 'restarted))))
+ (restart-case (error "Boo.")
+ (my-restart (&optional v) v)))
+ 'restarted)
+
+(> (length
+ (block tag
+ (handler-bind ((error #'(lambda (c)
+ (return-from tag (compute-restarts c)))))
+ (restart-case (error "Boo.")
+ (my-restart (&optional v) v)
+ (my-restart (&optional v) v)))))
+ 1)
+(eq 'ok
+ (restart-case (invoke-restart 'nil)
+ (nil (&rest rest) (declare (ignore rest)) 'ok)))
+
+
+
+
+
+
+;; compute-restarts
+(listp (mapcar #'restart-name (compute-restarts)))
+(listp (mapcar #'restart-name
+ (compute-restarts (make-condition 'simple-error
+ :format-control "error"
+ :format-arguments nil))))
+(restart-case (let ((list (compute-restarts)))
+ (and (member 'my-restart list
+ :test #'string= :key #'restart-name)
+ (member 'your-restart list
+ :test #'string= :key #'restart-name)))
+ (my-restart ())
+ (your-restart ()))
+(restart-case (let ((list (compute-restarts)))
+ (member 'my-restart
+ (cdr (member 'my-restart list
+ :test #'string= :key #'restart-name))
+ :test #'string= :key #'restart-name))
+ (my-restart ())
+ (my-restart ()))
+
+
+;; find-restart
+(or (find-restart 'continue) t)
+(restart-case (find-restart 'my-restart)
+ (my-restart ()))
+(restart-case (find-restart (find-restart 'my-restart))
+ (my-restart ()))
+(let ((condition (make-condition 'simple-error
+ :format-control "error" :format-arguments nil)))
+ (block tag
+ (handler-bind ((error
+ #'(lambda (c)
+ (return-from tag (and (eq c condition)
+ (find-restart 'my-restart c))))))
+ (restart-case (error condition)
+ (my-restart ())))))
+
+
+;; restart-name
+(string= "MY-RESTART"
+ (block tag
+ (handler-bind
+ ((error
+ #'(lambda (c)
+ (return-from tag (restart-name
+ (find-restart 'my-restart c))))))
+ (restart-case (error "error!")
+ (my-restart ())))))
+(null (block tag
+ (handler-bind
+ ((error
+ #'(lambda (c)
+ (return-from tag (restart-name
+ (find-restart 'nil c))))))
+ (restart-case (error "error!")
+ (nil ())))))
+
+
+;; with-condition-restarts
+(null (with-condition-restarts
+ (make-condition 'simple-error
+ :format-control "error" :format-arguments nil)
+ ()))
+(with-condition-restarts
+ (make-condition 'simple-error
+ :format-control "error" :format-arguments nil)
+ () t)
+(equal
+ (multiple-value-list
+ (with-condition-restarts
+ (make-condition 'simple-error
+ :format-control "error" :format-arguments nil)
+ () 0 1 2 (values 3 4 5)))
+ '(3 4 5))
+(let ((condition (make-condition 'simple-error
+ :format-control "error" :format-arguments nil))
+ (other (make-condition 'simple-error
+ :format-control "error" :format-arguments nil)))
+ (block tag
+ (handler-bind
+ ((error
+ #'(lambda (c)
+ (return-from tag (and (find-restart 'my-restart c)
+ (null (with-condition-restarts other
+ (compute-restarts)
+ (find-restart 'my-restart c))))))))
+ (restart-case (progn 3 2 1 'go (error condition))
+ (my-restart ())))))
+
+
+;; with-simple-restart
+(null (with-simple-restart (continue "continue")))
+(with-simple-restart (continue "continue") t)
+(equal (multiple-value-list
+ (with-simple-restart (continue "continue") 0 1 (values 2 3 4)))
+ '(2 3 4))
+(equal (multiple-value-list
+ (with-simple-restart (continue "continue")
+ (continue)))
+ '(nil t))
+(equal (multiple-value-list
+ (with-simple-restart (continue "continue")
+ (handler-case (error "boo")
+ (error (c) (declare (ignore c)) (invoke-restart 'continue)))))
+ '(nil t))
+
+
+;; abort
+(eq 'ok
+ (restart-case (abort)
+ (abort () 'ok)))
+(let ((condition (make-condition 'simple-error
+ :format-control "error" :format-arguments nil)))
+ (or (find-restart 'abort condition)
+ (eq 'handled
+ (handler-case (abort condition)
+ (control-error () 'handled)
+ (condition () nil)))))
+
+;; muffle-warning
+(eq 'ok
+ (restart-case (muffle-warning)
+ (muffle-warning () 'ok)))
+(let ((condition (make-condition 'simple-warning
+ :format-control "warning"
+ :format-arguments nil)))
+ (or (find-restart 'muffle-warning condition)
+ (eq 'handled
+ (handler-case (muffle-warning condition)
+ (control-error () 'handled)
+ (condition () nil)))))
+
+;; continue
+(eq 'ok
+ (restart-case (continue)
+ (continue () 'ok)))
+(let ((condition (make-condition 'simple-error
+ :format-control "error"
+ :format-arguments nil)))
+ (or (find-restart 'continue condition)
+ (null (continue condition))))
+
+;; store-value
+(eq 'ok
+ (restart-case (store-value 'ok)
+ (store-value (value) value)))
+(let ((condition (make-condition 'simple-error
+ :format-control "error"
+ :format-arguments nil)))
+ (or (find-restart 'store-value condition)
+ (null (store-value t condition))))
+
+;; use-value
+(eq 'ok
+ (restart-case (use-value 'ok)
+ (use-value (value) value)))
+(let ((condition (make-condition 'simple-error
+ :format-control "error"
+ :format-arguments nil)))
+ (or (find-restart 'use-value condition)
+ (null (use-value t condition))))
+
+
+
+
+
+;; assert
+(eq (assert t) nil)
+(handler-case (assert nil)
+ (error () t)
+ (:no-error (&rest rest) (declare (ignore rest)) nil))
+(let ((count 0))
+ (and (eq (assert (incf count)) nil)
+ (= count 1)))
+(handler-case (let ((var nil)) (assert var (var) "VAR should be true."))
+ (simple-error () t)
+ (error () nil)
+ (:no-error (&rest rest) (declare (ignore rest)) nil))
+(let ((str (copy-seq "ABC"))
+ (count 0))
+ (and (eq (assert (char= (aref str 0) #\A) ((aref (progn (incf count) str) 0)))
+ nil)
+ (zerop count)))
+(let ((str (copy-seq "ABC"))
+ (count 0))
+ (and (eq (assert (and (char= (aref str 0) #\A)
+ (char= (aref str 1) #\B))
+ ((aref (progn (incf count) str) 0)
+ (aref (progn (incf count) str) 1)))
+ nil)
+ (zerop count)))
+(handler-case (let ((var nil))
+ (assert var (var) 'type-error :expected-type 'array))
+ (type-error () t)
+ (error () nil)
+ (:no-error (&rest rest) (declare (ignore rest)) nil))
+
+
+;; check-type
+(null (let ((var nil)) (check-type var null)))
+(null (let ((var '(a b c))) (check-type var cons)))
+(handler-case (let ((var '(a b c))) (check-type var vector))
+ (type-error () t)
+ (error () nil)
+ (:no-error (&rest rest) (declare (ignore rest)) nil))
+(eq 'handled
+ (block tag
+ (handler-bind ((type-error
+ #'(lambda (c)
+ (declare (ignore c))
+ (return-from tag 'handled)))
+ (error #'(lambda (c)
+ (declare (ignore c))
+ (return-from tag nil))))
+ (let ((var '(a b c)))
+ (check-type var vector)
+ var))))
+(string= (block tag
+ (handler-bind ((type-error
+ #'(lambda (c)
+ (declare (ignore c))
+ (invoke-restart 'store-value "eat this")))
+ (error #'(lambda (c)
+ (declare (ignore c))
+ (return-from tag nil))))
+ (let ((var '(a b c)))
+ (check-type var vector)
+ var)))
+ "eat this")
+
+
+;; ignore-errors
+(null (ignore-errors))
+(ignore-errors t)
+(let ((result (multiple-value-list (ignore-errors (error "error")))))
+ (and (null (first result))
+ (typep (second result) 'simple-error)))
+(equal (multiple-value-list (ignore-errors 'a 'b 'c (values 'd 'e)))
+ '(d e))
+(let ((result (multiple-value-list
+ (ignore-errors (signal 'simple-error
+ :format-control "error"
+ :format-arguments nil)))))
+ (and (null (first result))
+ (typep (second result) 'simple-error)))
+(eq (ignore-errors (signal "only signal") 'ok) 'ok)
+(eq (block tag
+ (handler-bind ((condition #'(lambda (c)
+ (declare (ignore c))
+ (return-from tag 'handled))))
+ (ignore-errors (error 'simple-condition
+ :format-control "only condition"
+ :format-arguments nil))))
+ 'handled)
+(let ((result (multiple-value-list
+ (ignore-errors (warn 'simple-error
+ :format-control "an error, not a warning"
+ :format-arguments nil)))))
+ (and (null (first result))
+ (typep (second result) 'type-error)))
+
diff --git a/Sacla/tests/must-cons.lisp b/Sacla/tests/must-cons.lisp
new file mode 100644
index 0000000..a865e70
--- /dev/null
+++ b/Sacla/tests/must-cons.lisp
@@ -0,0 +1,2309 @@
+;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
+;; ALL RIGHTS RESERVED.
+;;
+;; $Id: must-cons.lisp,v 1.4 2004/02/20 07:23:42 yuji Exp $
+;;
+;; 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.
+;;
+;; 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.
+
+(consp (cons 'a 'b))
+
+(consp '(1 . 2))
+
+(consp (list nil))
+
+(not (consp 'a))
+
+(not (consp nil))
+
+(not (consp 1))
+
+(not (consp #\a))
+
+(let ((a (cons 1 2)))
+ (and (eql (car a) 1)
+ (eql (cdr a) 2)))
+
+(equal (cons 1 nil) '(1))
+
+(equal (cons nil nil) '(nil))
+
+(equal (cons 'a (cons 'b (cons 'c '()))) '(a b c))
+
+(atom 'a)
+
+(atom nil)
+
+(atom 1)
+
+(atom #\a)
+
+(not (atom (cons 1 2)))
+
+(not (atom '(a . b)))
+
+(not (atom (list nil)))
+
+
+(listp nil)
+
+(listp '(a b c))
+
+(listp '(a . b))
+
+(listp (cons 'a 'b))
+
+(listp '#1=(1 2 . #1#))
+
+(not (listp 1))
+
+(not (listp 't))
+
+(null '())
+(null 'nil)
+(null nil)
+(not (null t))
+(null (cdr '(a)))
+(not (null (cdr '(1 . 2))))
+(not (null 'a))
+
+
+(endp '())
+(not (endp '(1)))
+(not (endp '(1 2)))
+(not (endp '(1 2 3)))
+(not (endp (cons 1 2)))
+(endp (cddr '(1 2)))
+
+
+(let ((a (cons 1 2)))
+ (and (eq (rplaca a 0) a)
+ (equal a '(0 . 2))))
+
+(let ((a (list 1 2 3)))
+ (and (eq (rplaca a 0) a)
+ (equal a '(0 2 3))))
+
+(let ((a (cons 1 2)))
+ (and (eq (rplacd a 0) a)
+ (equal a '(1 . 0))))
+
+(let ((a (list 1 2 3)))
+ (and (eq (rplacd a 0) a)
+ (equal a '(1 . 0))))
+
+(eq (car '(a . b)) 'a)
+
+(null (car nil))
+
+(let ((a (cons 1 2)))
+ (eq (car (list a)) a))
+
+(eq (car '#1=(a . #1#)) 'a)
+
+(eq (cdr '(a . b)) 'b)
+(eq (rest '(a . b)) 'b)
+
+(null (cdr nil))
+(null (rest nil))
+
+(let ((a (cons 1 2)))
+ (eq (cdr (cons 1 a)) a))
+(let ((a (cons 1 2)))
+ (eq (rest (cons 1 a)) a))
+
+(let ((x '#1=(a . #1#)))
+ (eq (cdr x) x))
+(let ((x '#1=(a . #1#)))
+ (eq (rest x) x))
+
+(eq (caar '((a) b c)) 'a)
+
+(eq (cadr '(a b c)) 'b)
+
+(eq (cdar '((a . aa) b c)) 'aa)
+
+(eq (cddr '(a b . c)) 'c)
+
+(eq (caaar '(((a)) b c)) 'a)
+
+(eq (caadr '(a (b) c)) 'b)
+
+(eq (cadar '((a aa) b c)) 'aa)
+
+(eq (caddr '(a b c)) 'c)
+
+(eq (cdaar '(((a . aa)) b c)) 'aa)
+
+(eq (cdadr '(a (b . bb) c)) 'bb)
+
+(eq (cddar '((a aa . aaa) b c)) 'aaa)
+
+(eq (cdddr '(a b c . d)) 'd)
+
+(eq (caaaar '((((a))) b c)) 'a)
+
+(eq (caaadr '(a ((b)) c)) 'b)
+
+(eq (caadar '((a (aa)) b c)) 'aa)
+
+(eq (caaddr '(a b (c))) 'c)
+
+(eq (cadaar '(((a aa)) b c)) 'aa)
+
+(eq (cadadr '(a (b bb) c)) 'bb)
+
+(eq (caddar '((a aa aaa) b c)) 'aaa)
+
+(eq (cadddr '(a b c d)) 'd)
+
+(eq (cdaaar '((((a . aa))) b c)) 'aa)
+
+(eq (cdaadr '(a ((b . bb)) c)) 'bb)
+
+(eq (cdadar '((a (aa . aaa)) b c)) 'aaa)
+
+(eq (cdaddr '(a b (c . cc))) 'cc)
+
+(eq (cddaar '(((a aa . aaa)) b c)) 'aaa)
+
+(eq (cddadr '(a (b bb . bbb) c)) 'bbb)
+
+(eq (cdddar '((a aa aaa . aaaa) b c)) 'aaaa)
+
+(eq (cddddr '(a b c d . e)) 'e)
+
+(let ((x (cons 1 2)))
+ (and (eql (setf (car x) 0) 0)
+ (equal x '(0 . 2))))
+
+(let ((x (cons 1 2)))
+ (and (eql (setf (cdr x) 0) 0)
+ (equal x '(1 . 0))))
+
+(let ((x (copy-tree '((a) b c))))
+ (and (eql (setf (caar x) 0) 0)
+ (equal x '((0) b c))))
+
+(let ((x (list 'a 'b 'c)))
+ (and (eql (setf (cadr x) 0) 0)
+ (equal x '(a 0 c))))
+
+(let ((x (copy-tree '((a . aa) b c))))
+ (and (eql (setf (cdar x) 0) 0)
+ (equal x '((a . 0) b c))))
+
+(let ((x (copy-tree '(a b . c))))
+ (and (eql (setf (cddr x) 0) 0)
+ (equal x '(a b . 0))))
+
+(let ((x (copy-tree '(((a)) b c))))
+ (and (eql (setf (caaar x) 0) 0)
+ (equal x '(((0)) b c))))
+
+(let ((x (copy-tree '(a (b) c))))
+ (and (eql (setf (caadr x) 0) 0)
+ (equal x '(a (0) c))))
+
+(let ((x (copy-tree '((a aa) b c))))
+ (and (eql (setf (cadar x) 0) 0)
+ (equal x '((a 0) b c))))
+
+(let ((x (list 'a 'b 'c)))
+ (and (eql (setf (caddr x) 0) 0)
+ (equal x '(a b 0))))
+
+(let ((x (copy-tree '(((a . aa)) b c))))
+ (and (eql (setf (cdaar x) 0) 0)
+ (equal x '(((a . 0)) b c))))
+
+(let ((x (copy-tree '(a (b . bb) c))))
+ (and (eql (setf (cdadr x) 0) 0)
+ (equal x '(a (b . 0) c))))
+
+(let ((x (copy-tree '((a aa . aaa) b c))))
+ (and (eql (setf (cddar x) 0) 0)
+ (equal x '((a aa . 0) b c))))
+
+(let ((x (copy-tree '(a b c . d))))
+ (and (eql (setf (cdddr x) 0) 0)
+ (equal x '(a b c . 0))))
+
+(let ((x (copy-tree '((((a))) b c))))
+ (and (eql (setf (caaaar x) 0) 0)
+ (equal x '((((0))) b c))))
+
+(let ((x (copy-tree '(a ((b)) c))))
+ (and (eql (setf (caaadr x) 0) 0)
+ (equal x '(a ((0)) c))))
+
+(let ((x (copy-tree '((a (aa)) b c))))
+ (and (eql (setf (caadar x) 0) 0)
+ (equal x '((a (0)) b c))))
+
+(let ((x (copy-tree '(a b (c)))))
+ (and (eql (setf (caaddr x) 0) 0)
+ (equal x '(a b (0)))))
+
+(let ((x (copy-tree '(((a aa)) b c))))
+ (and (eql (setf (cadaar x) 0) 0)
+ (equal x '(((a 0)) b c))))
+
+(let ((x (copy-tree '(a (b bb) c))))
+ (and (eql (setf (cadadr x) 0) 0)
+ (equal x '(a (b 0) c))))
+
+(let ((x (copy-tree '((a aa aaa) b c))))
+ (and (eql (setf (caddar x) 0) 0)
+ (equal x '((a aa 0) b c))))
+
+(let ((x (list 'a 'b 'c 'd)))
+ (and (eql (setf (cadddr x) 0) 0)
+ (equal x '(a b c 0))))
+
+(let ((x (copy-tree '((((a . aa))) b c))))
+ (and (eql (setf (cdaaar x) 0) 0)
+ (equal x '((((a . 0))) b c))))
+
+(let ((x (copy-tree '(a ((b . bb)) c))))
+ (and (eql (setf (cdaadr x) 0) 0)
+ (equal x '(a ((b . 0)) c))))
+
+(let ((x (copy-tree '((a (aa . aaa)) b c))))
+ (and (eql (setf (cdadar x) 0) 0)
+ (equal x '((a (aa . 0)) b c))))
+
+(let ((x (copy-tree '(a b (c . cc)))))
+ (and (eql (setf (cdaddr x) 0) 0)
+ (equal x '(a b (c . 0)))))
+
+(let ((x (copy-tree '(((a aa . aaa)) b c))))
+ (and (eql (setf (cddaar x) 0) 0)
+ (equal x '(((a aa . 0)) b c))))
+
+(let ((x (copy-tree '(a (b bb . bbb) c))))
+ (and (eql (setf (cddadr x) 0) 0)
+ (equal x '(a (b bb . 0) c))))
+
+(let ((x (copy-tree '((a aa aaa . aaaa) b c))))
+ (and (eql (setf (cdddar x) 0) 0)
+ (equal x '((a aa aaa . 0) b c))))
+
+(let ((x (copy-tree '(a b c d . e))))
+ (and (eql (setf (cddddr x) 0) 0)
+ (equal x '(a b c d . 0))))
+
+(eq (copy-tree 'a) 'a)
+
+(eq (copy-tree nil) nil)
+
+(let* ((a (list 'a))
+ (b (list 'b))
+ (c (list 'c))
+ (x3 (cons c nil))
+ (x2 (cons b x3))
+ (x (cons a x2))
+ (y (copy-tree x)))
+ (and (not (eq x y))
+ (not (eq (car x) (car y)))
+ (not (eq (cdr x) (cdr y)))
+ (not (eq (cadr x) (cadr y)))
+ (not (eq (cddr x) (cddr y)))
+ (not (eq (caddr x) (caddr y)))
+ (eq (cdddr x) (cdddr y))
+ (equal x y)
+ (eq (car x) a) (eq (car a) 'a) (eq (cdr a) nil)
+ (eq (cdr x) x2)
+ (eq (car x2) b) (eq (car b) 'b) (eq (cdr b) nil)
+ (eq (cdr x2) x3)
+ (eq (car x3) c) (eq (car c) 'c) (eq (cdr c) nil)
+ (eq (cdr x3) nil)))
+
+(let* ((x (list (list 'a 1) (list 'b 2) (list 'c 3)))
+ (y (copy-tree x)))
+ (and (not (eq (car x) (car y)))
+ (not (eq (cadr x) (cadr y)))
+ (not (eq (caddr x) (caddr y)))))
+
+(let* ((x (list (list (list 1))))
+ (y (copy-tree x)))
+ (and (not (eq x y))
+ (not (eq (car x) (car y)))
+ (not (eq (caar x) (caar y)))))
+
+
+(let ((x (list 'a 'b 'c 'd)))
+ (and (equal (sublis '((a . 1) (b . 2) (c . 3)) x)
+ '(1 2 3 d))
+ (equal x '(a b c d))))
+
+(let* ((n (cons 'n nil))
+ (m (cons 'm n))
+ (l (cons 'l m))
+ (x (sublis '((a . 1) (b . 2) (c . 3)) l)))
+ (and (eq x l)
+ (eq (car l) 'l)
+ (eq (cdr l) m)
+ (eq (car m) 'm)
+ (eq (cdr m) n)
+ (eq (car n) 'n)
+ (eq (cdr n) nil)))
+
+(eq (sublis '() '()) '())
+
+(equal (sublis '() '(1 2 3)) '(1 2 3))
+
+(eq (sublis '((a . 1) (b . 2)) '()) nil)
+
+(equal (sublis '((a b c) (b c d) (c d e))
+ '(a b c))
+ '((b c) (c d) (d e)))
+
+(equal (sublis '((a . 1) (b . 2) (c . 3))
+ '(((a)) (b) c))
+ '(((1)) (2) 3))
+
+(equal (sublis '(((a) . 1) ((b) . 2) ((c) . 3))
+ '((((a))) ((b)) (c)))
+ '((((a))) ((b)) (c)))
+
+(equal (sublis '(((a) . 1) ((b) . 2) ((c) . 3))
+ '((((a))) ((b)) (c))
+ :test #'equal)
+ '(((1)) (2) 3))
+
+(equal (sublis '(((a) . 1) ((b) . 2) ((c) . 3))
+ '((((a))) ((b)) (c))
+ :test-not (complement #'equal))
+ '(((1)) (2) 3))
+
+(equal (sublis '((a . 1) (b . 2) (c . 3))
+ '((((a))) ((b)) (c))
+ :key #'car)
+ '(((1)) (2) 3))
+
+(equal (sublis '(((a) . 1) ((b) . 2) ((c) . 3))
+ '((((a))) ((b)) (c))
+ :key #'car
+ :test #'equal)
+ '((1) 2 . 3))
+
+
+
+(equal (nsublis '((a . 1) (b . 2) (c . 3))
+ (list 'a 'b 'c 'd))
+ '(1 2 3 d))
+
+(let* ((x (list 'a 'b 'c 'd))
+ (y (nsublis '((a . 1) (b . 2) (c . 3)) x)))
+ (and (eq x y)
+ (equal x '(1 2 3 d))))
+
+(let ((x (list 'l 'm 'n)))
+ (and (eq (nsublis '((a . 1) (b . 2) (c . 3)) x) x)
+ (equal x '(l m n))))
+
+(let* ((n (cons 'n nil))
+ (m (cons 'm n))
+ (l (cons 'l m))
+ (x (nsublis '((a . 1) (b . 2) (c . 3)) l)))
+ (and (eq x l)
+ (eq (car l) 'l)
+ (eq (cdr l) m)
+ (eq (car m) 'm)
+ (eq (cdr m) n)
+ (eq (car n) 'n)
+ (eq (cdr n) nil)))
+
+(eq (nsublis '() '()) '())
+
+(equal (nsublis '() '(1 2 3)) '(1 2 3))
+
+(eq (nsublis '((a . 1) (b . 2)) '()) nil)
+
+(equal (nsublis '((a b c) (b c d) (c d e))
+ (list 'a 'b 'c))
+ '((b c) (c d) (d e)))
+
+(equal (nsublis '((a . 1) (b . 2) (c . 3))
+ (copy-tree '(((a)) (b) c)))
+ '(((1)) (2) 3))
+
+(equal (nsublis '(((a) . 1) ((b) . 2) ((c) . 3))
+ (copy-tree '((((a))) ((b)) (c))))
+ '((((a))) ((b)) (c)))
+
+(equal (nsublis '(((a) . 1) ((b) . 2) ((c) . 3))
+ (copy-tree '((((a))) ((b)) (c)))
+ :test #'equal)
+ '(((1)) (2) 3))
+
+(equal (nsublis '(((a) . 1) ((b) . 2) ((c) . 3))
+ (copy-tree '((((a))) ((b)) (c)))
+ :test-not (complement #'equal))
+ '(((1)) (2) 3))
+
+
+(equal (nsublis '((a . 1) (b . 2) (c . 3))
+ (copy-tree '((((a))) ((b)) (c)))
+ :key #'car)
+ '(((1)) (2) 3))
+
+(equal (nsublis '(((a) . 1) ((b) . 2) ((c) . 3))
+ (copy-tree '((((a))) ((b)) (c)))
+ :key 'car
+ :test #'equal)
+ '((1) 2 . 3))
+
+
+(let ((tree '(old (old) ((old)))))
+ (equal (subst 'new 'old tree)
+ '(new (new) ((new)))))
+
+(eq (subst 'new 'old 'old) 'new)
+
+(eq (subst 'new 'old 'not-old) 'not-old)
+
+(equal (subst 'new '(b) '(a ((b))) :test #'equal)
+ '(a (new)))
+
+(equal (subst 'new '(b) '(a ((b))) :test-not (complement #'equal))
+ '(a (new)))
+
+(equal (subst 'x 3 '(1 (1 2) (1 2 3) (1 2 3 4))
+ :key #'(lambda (y) (and (listp y) (third y))))
+ '(1 (1 2) X X))
+
+(equal (subst 'x "D" '("a" ("a" "b") ("a" "b" "c") ("a" "b" "c" "d"))
+ :test #'equalp
+ :key #'(lambda (y) (and (listp y) (fourth y))))
+ '("a" ("a" "b") ("a" "b" "c") X))
+
+
+(equal (subst-if 'new #'(lambda (x) (eq x 'old)) '(old old))
+ '(new new))
+
+(eq (subst-if 'new #'(lambda (x) (eq x 'old)) 'old) 'new)
+
+(equal (subst-if 'x #'(lambda (x) (eql x 3)) '(1 (1 2) (1 2 3) (1 2 3 4))
+ :key #'(lambda (y) (and (listp y) (third y))))
+ '(1 (1 2) x x))
+
+
+(let ((tree '(old (old) ((old)))))
+ (equal (subst-if 'new #'(lambda (x) (eq x 'old)) tree)
+ '(new (new) ((new)))))
+
+(eq (subst-if 'new #'(lambda (x) (eq x 'old)) 'old)
+ 'new)
+
+(eq (subst-if 'new #'(lambda (x) (eq x 'old)) 'not-old)
+ 'not-old)
+
+(equal (subst-if 'new #'(lambda (x) (equal x '(b))) '(a ((b))))
+ '(a (new)))
+
+(equal (subst-if 'x
+ #'(lambda (x) (eql x 3)) '(1 (1 2) (1 2 3) (1 2 3 4))
+ :key #'(lambda (y) (and (listp y) (third y))))
+ '(1 (1 2) X X))
+
+(equal (subst-if 'x
+ #'(lambda (x) (equalp x "D"))
+ '("a" ("a" "b") ("a" "b" "c") ("a" "b" "c" "d"))
+ :key #'(lambda (y) (and (listp y) (fourth y))))
+ '("a" ("a" "b") ("a" "b" "c") X))
+
+
+(equal (subst-if-not 'new #'(lambda (x) (not (eq x 'old))) '(old old))
+ '(new new))
+
+(eq (subst-if-not 'new #'(lambda (x) (not (eq x 'old))) 'old) 'new)
+
+(equal (subst-if-not 'x #'(lambda (x) (not (eql x 3)))
+ '(1 (1 2) (1 2 3) (1 2 3 4))
+ :key #'(lambda (y) (and (listp y) (third y))))
+ '(1 (1 2) x x))
+
+
+(let ((tree '(old (old) ((old)))))
+ (equal (subst-if-not 'new #'(lambda (x) (not (eq x 'old))) tree)
+ '(new (new) ((new)))))
+
+(eq (subst-if-not 'new #'(lambda (x) (not (eq x 'old))) 'old)
+ 'new)
+
+(eq (subst-if-not 'new #'(lambda (x) (not (eq x 'old))) 'not-old)
+ 'not-old)
+
+(equal (subst-if-not 'new #'(lambda (x) (not (equal x '(b)))) '(a ((b))))
+ '(a (new)))
+
+(equal (subst-if-not 'x
+ #'(lambda (x) (not (eql x 3)))
+ '(1 (1 2) (1 2 3) (1 2 3 4))
+ :key #'(lambda (y) (and (listp y) (third y))))
+ '(1 (1 2) X X))
+
+(equal (subst-if-not 'x
+ #'(lambda (x) (not (equalp x "D")))
+ '("a" ("a" "b") ("a" "b" "c") ("a" "b" "c" "d"))
+ :key #'(lambda (y) (and (listp y) (fourth y))))
+ '("a" ("a" "b") ("a" "b" "c") X))
+
+
+
+(let ((tree '(old (old) ((old)))))
+ (equal (nsubst 'new 'old (copy-tree tree))
+ '(new (new) ((new)))))
+
+(let* ((tree (copy-tree '(old (old) ((old)))))
+ (new-tree (nsubst 'new 'old tree)))
+ (and (eq tree new-tree)
+ (equal tree '(new (new) ((new))))))
+
+(eq (nsubst 'new 'old 'old) 'new)
+
+(eq (nsubst 'new 'old 'not-old) 'not-old)
+
+(equal (nsubst 'new '(b) (copy-tree '(a ((b)))) :test #'equal)
+ '(a (new)))
+
+(equal (nsubst 'new '(b) (copy-tree '(a ((b)))) :test-not (complement #'equal))
+ '(a (new)))
+
+(equal (nsubst 'x 3 (copy-tree '(1 (1 2) (1 2 3) (1 2 3 4)))
+ :key #'(lambda (y) (and (listp y) (third y))))
+ '(1 (1 2) X X))
+
+(equal (nsubst 'x "D"
+ (copy-tree '("a" ("a" "b") ("a" "b" "c") ("a" "b" "c" "d")))
+ :test #'equalp
+ :key #'(lambda (y) (and (listp y) (fourth y))))
+ '("a" ("a" "b") ("a" "b" "c") X))
+
+
+(equal (nsubst-if 'new #'(lambda (x) (eq x 'old)) (list 'old 'old))
+ '(new new))
+
+(eq (nsubst-if 'new #'(lambda (x) (eq x 'old)) 'old) 'new)
+
+(let* ((x (copy-tree '(old (old) ((old)) (old) old)))
+ (y (nsubst-if 'new #'(lambda (x) (eq x 'old)) x)))
+ (and (eq x y)
+ (equal x '(new (new) ((new)) (new) new))))
+
+(equal (nsubst-if 'x
+ #'(lambda (x) (eql x 3))
+ (copy-tree '(1 (1 2) (1 2 3) (1 2 3 4)))
+ :key #'(lambda (y) (and (listp y) (third y))))
+ '(1 (1 2) x x))
+
+(let ((tree '(old (old) ((old)))))
+ (equal (nsubst-if 'new #'(lambda (x) (eq x 'old)) (copy-tree tree))
+ '(new (new) ((new)))))
+
+(eq (nsubst-if 'new #'(lambda (x) (eq x 'old)) 'old)
+ 'new)
+
+(eq (nsubst-if 'new #'(lambda (x) (eq x 'old)) 'not-old)
+ 'not-old)
+
+(equal (nsubst-if 'new #'(lambda (x) (equal x '(b)))
+ (copy-tree '(a ((b)))))
+ '(a (new)))
+
+(equal (nsubst-if 'x
+ #'(lambda (x) (eql x 3))
+ (copy-tree '(1 (1 2) (1 2 3) (1 2 3 4)))
+ :key #'(lambda (y) (and (listp y) (third y))))
+ '(1 (1 2) X X))
+
+(equal (nsubst-if 'x
+ #'(lambda (x) (equalp x "D"))
+ (copy-tree '("a" ("a" "b") ("a" "b" "c") ("a" "b" "c" "d")))
+ :key #'(lambda (y) (and (listp y) (fourth y))))
+ '("a" ("a" "b") ("a" "b" "c") X))
+
+
+(equal (nsubst-if-not 'new #'(lambda (x) (not (eq x 'old)))
+ (list 'old 'old))
+ '(new new))
+
+(eq (nsubst-if-not 'new #'(lambda (x) (not (eq x 'old))) 'old) 'new)
+
+(let* ((x (copy-tree '(old (old) ((old)) (old) old)))
+ (y (nsubst-if-not 'new #'(lambda (x) (not (eq x 'old))) x)))
+ (and (eq x y)
+ (equal x '(new (new) ((new)) (new) new))))
+
+(equal (nsubst-if-not 'x #'(lambda (x) (not (eql x 3)))
+ (copy-tree '(1 (1 2) (1 2 3) (1 2 3 4)))
+ :key #'(lambda (y) (and (listp y) (third y))))
+ '(1 (1 2) x x))
+
+(let ((tree '(old (old) ((old)))))
+ (equal (nsubst-if-not 'new #'(lambda (x) (not (eq x 'old))) (copy-tree tree))
+ '(new (new) ((new)))))
+
+(eq (nsubst-if-not 'new #'(lambda (x) (not (eq x 'old))) 'old)
+ 'new)
+
+(eq (nsubst-if-not 'new #'(lambda (x) (not (eq x 'old))) 'not-old)
+ 'not-old)
+
+(equal (nsubst-if-not 'new #'(lambda (x) (not (equal x '(b))))
+ (copy-tree '(a ((b)))))
+ '(a (new)))
+
+(equal (nsubst-if-not 'x
+ #'(lambda (x) (not (eql x 3)))
+ (copy-tree '(1 (1 2) (1 2 3) (1 2 3 4)))
+ :key #'(lambda (y) (and (listp y) (third y))))
+ '(1 (1 2) X X))
+
+(equal
+ (nsubst-if-not 'x
+ #'(lambda (x) (not (equalp x "D")))
+ (copy-tree '("a" ("a" "b") ("a" "b" "c") ("a" "b" "c" "d")))
+ :key #'(lambda (y) (and (listp y) (fourth y))))
+ '("a" ("a" "b") ("a" "b" "c") X))
+
+
+
+(tree-equal 'a 'a)
+
+(not (tree-equal 'a 'b))
+
+(tree-equal '(a (b (c))) '(a (b (c))))
+
+(tree-equal '(a (b (c))) '(a (b (c))) :test #'eq)
+
+(tree-equal '(a (b (c))) '(a (b (c))) :test-not (complement #'eq))
+
+(not (tree-equal '("a" ("b" ("c"))) '("a" ("b" ("c")))))
+
+(tree-equal '("a" ("b" ("c"))) '("a" ("b" ("c"))) :test #'equal)
+
+(tree-equal '("a" ("b" ("c"))) '("a" ("b" ("c")))
+ :test-not (complement #'equal))
+
+(not (tree-equal '(a b) '(a (b))))
+
+
+(eq (copy-list '()) '())
+
+(equal (copy-list '(a b c))
+ '(a b c))
+
+(equal (copy-list '(a . b)) '(a . b))
+
+(let* ((x '(a b c))
+ (y (copy-list x)))
+ (and (equal x y)
+ (not (eq x y))))
+
+(let* ((a (list 'a))
+ (b (list 'b))
+ (c (list 'c))
+ (x (list a b c))
+ (y (copy-list x)))
+ (and (equal x y)
+ (not (eq x y))
+ (eq (car x) (car y))
+ (eq (cadr x) (cadr y))
+ (eq (caddr x) (caddr y))
+ (eq (caar x) 'a)
+ (eq (caadr x) 'b)
+ (eq (caaddr x) 'c)))
+
+
+(null (list))
+
+(equal (list 1) '(1))
+
+(equal (list 1 2 3) '(1 2 3))
+
+(equal (list* 1 2 '(3)) '(1 2 3))
+
+(equal (list* 1 2 'x) '(1 2 . x))
+
+(equal (list* 1 2 '(3 4)) '(1 2 3 4))
+
+(eq (list* 'x) 'x)
+
+
+(eql (list-length '()) 0)
+
+(eql (list-length '(1)) 1)
+
+(eql (list-length '(1 2)) 2)
+
+(null (list-length '#1=(1 2 3 4 . #1#)))
+
+
+(equal (make-list 5) '(nil nil nil nil nil))
+
+(equal (make-list 3 :initial-element 'rah) '(rah rah rah))
+
+(equal (make-list 2 :initial-element '(1 2 3)) '((1 2 3) (1 2 3)))
+
+(null (make-list 0))
+
+(null (make-list 0 :initial-element 'new-element))
+
+
+(let ((place nil))
+ (and (equal (push 0 place) '(0))
+ (equal place '(0))))
+
+(let ((place (list 1 2 3)))
+ (and (equal (push 0 place) '(0 1 2 3))
+ (equal place '(0 1 2 3))))
+
+(let ((a (list (list 1 2 3) 9)))
+ (and (equal (push 0 (car a)) '(0 1 2 3))
+ (equal a '((0 1 2 3) 9))))
+
+(let ((x (copy-tree '(a (b c) d))))
+ (and (equal (push 'aa (cadr x)) '(aa b c))
+ (equal x '(a (aa b c) d))))
+
+
+(let ((place (list 1 2 3)))
+ (and (eql (pop place) 1)
+ (equal place '(2 3))))
+
+(let ((place '()))
+ (and (eql (pop place) nil)
+ (equal place '())))
+
+(let ((a (list (list 1 2 3) 9)))
+ (and (eql (pop (car a)) 1)
+ (equal a '((2 3) 9))))
+
+(let ((x (list 'a 'b 'c)))
+ (and (eq (pop (cdr x)) 'b)
+ (equal x '(a c))))
+
+
+(eq (first '(a . b)) 'a)
+
+(null (first nil))
+
+(let ((a (cons 1 2)))
+ (eq (first (list a)) a))
+
+(eq (first '#1=(a . #1#)) 'a)
+
+(eql (first '(1 2 3)) '1)
+(eql (second '(1 2 3)) '2)
+(eql (third '(1 2 3)) '3)
+(eql (fourth '(1 2 3 4)) '4)
+(eql (fifth '(1 2 3 4 5)) '5)
+(eql (sixth '(1 2 3 4 5 6)) '6)
+(eql (seventh '(1 2 3 4 5 6 7)) '7)
+(eql (eighth '(1 2 3 4 5 6 7 8)) '8)
+(eql (ninth '(1 2 3 4 5 6 7 8 9)) '9)
+(eql (tenth '(1 2 3 4 5 6 7 8 9 10)) '10)
+
+
+(let ((x (list 'a 'b 'c)))
+ (and (eql (setf (first x) 0) 0)
+ (equal x '(0 b c))))
+
+(let ((x (list 'a 'b 'c)))
+ (and (eql (setf (second x) 0) 0)
+ (equal x '(a 0 c))))
+
+(let ((x (list 'a 'b 'c)))
+ (and (eql (setf (third x) 0) 0)
+ (equal x '(a b 0))))
+
+(let ((x (list 'a 'b 'c 'd)))
+ (and (eql (setf (fourth x) 0) 0)
+ (equal x '(a b c 0))))
+
+(let ((x (list 'a 'b 'c 'd 'e)))
+ (and (eql (setf (fifth x) 0) 0)
+ (equal x '(a b c d 0))))
+
+(let ((x (list 'a 'b 'c 'd 'e 'f)))
+ (and (eql (setf (sixth x) 0) 0)
+ (equal x '(a b c d e 0))))
+
+(let ((x (list 'a 'b 'c 'd 'e 'f 'g)))
+ (and (eql (setf (seventh x) 0) 0)
+ (equal x '(a b c d e f 0))))
+
+(let ((x (list 'a 'b 'c 'd 'e 'f 'g 'h)))
+ (and (eql (setf (eighth x) 0) 0)
+ (equal x '(a b c d e f g 0))))
+
+(let ((x (list 'a 'b 'c 'd 'e 'f 'g 'h 'i)))
+ (and (eql (setf (ninth x) 0) 0)
+ (equal x '(a b c d e f g h 0))))
+
+(let ((x (list 'a 'b 'c 'd 'e 'f 'g 'h 'i 'j)))
+ (and (eql (setf (tenth x) 0) 0)
+ (equal x '(a b c d e f g h i 0))))
+
+
+(let ((x '(a b c)))
+ (eq (nthcdr 0 x) x))
+
+(let ((x '(a b c)))
+ (eq (nthcdr 1 x) (cdr x)))
+
+(let ((x '(a b c)))
+ (eq (nthcdr 2 x) (cddr x)))
+
+(let ((x '(a b c)))
+ (eq (nthcdr 2 x) (cddr x)))
+
+(let ((x '(a b c)))
+ (eq (nthcdr 3 x) (cdddr x)))
+
+(equal (nthcdr 0 '(0 1 2)) '(0 1 2))
+(equal (nthcdr 1 '(0 1 2)) '(1 2))
+(equal (nthcdr 2 '(0 1 2)) '(2))
+(equal (nthcdr 3 '(0 1 2)) '())
+
+(eql (nthcdr 1 '(0 . 1)) 1)
+
+(eql (nth 0 '(a b c)) 'a)
+(eql (nth 1 '(a b c)) 'b)
+(eql (nth 2 '(a b c)) 'c)
+(eql (nth 3 '(a b c)) '())
+(eql (nth 4 '(a b c)) '())
+(eql (nth 5 '(a b c)) '())
+(eql (nth 6 '(a b c)) '())
+
+(eq (nth 0 '(a . b)) 'a)
+
+(let ((x (list 'a 'b 'c)))
+ (and (eq (setf (nth 0 x) 'z) 'z)
+ (equal x '(z b c))))
+
+(let ((x (list 'a 'b 'c)))
+ (and (eq (setf (nth 1 x) 'z) 'z)
+ (equal x '(a z c))))
+
+(let ((x (list 'a 'b 'c)))
+ (and (eq (setf (nth 2 x) 'z) 'z)
+ (equal x '(a b z))))
+
+(let ((0-to-3 (list 0 1 2 3)))
+ (and (equal (setf (nth 2 0-to-3) "two") "two")
+ (equal 0-to-3 '(0 1 "two" 3))))
+
+
+(eq (nconc) '())
+(equal (nconc nil (list 'a 'b 'c) (list 'd 'e 'f))
+ '(a b c d e f))
+
+(equal (nconc nil nil (list 'a 'b 'c) (list 'd 'e 'f))
+ '(a b c d e f))
+
+(equal (nconc nil nil nil (list 'a 'b 'c) (list 'd 'e 'f))
+ '(a b c d e f))
+
+
+(let* ((x (list 'a 'b 'c)))
+ (eq (nconc x) x))
+
+(let* ((x (list 'a 'b 'c))
+ (y (list 'd 'e 'f))
+ (list (nconc x y)))
+ (and (eq list x)
+ (eq (nthcdr 3 list) y)
+ (equal list '(a b c d e f))))
+
+(let* ((x (list 'a))
+ (y (list 'b))
+ (z (list 'c))
+ (list (nconc x y z)))
+ (and (eq x list)
+ (eq (first list) 'a)
+ (eq y (cdr list))
+ (eq (second list) 'b)
+ (eq z (cddr list))
+ (eq (third list) 'c)))
+
+(equal (append '(a b) '() '(c d) '(e f))
+ '(a b c d e f))
+
+(null (append))
+(null (append '()))
+(null (append '() '()))
+
+(eq (append 'a) 'a)
+
+(eq (append '() 'a) 'a)
+
+(eq (append '() '() 'a) 'a)
+
+
+(equal (append '(a b) 'c) '(a b . c))
+
+(let* ((x '(a b c))
+ (y '(d e f))
+ (z (append x y)))
+ (and (equal z '(a b c d e f))
+ (eq (nthcdr 3 z) y)
+ (not (eq x z))))
+
+
+(equal (revappend '(a b c) '(d e f))
+ '(c b a d e f))
+
+(let* ((x '(a b c))
+ (y '(d e f))
+ (z (revappend x y)))
+ (and (equal z '(c b a d e f))
+ (not (eq x z))
+ (eq (nthcdr 3 z) y)))
+
+(let ((x '(a b c)))
+ (eq (revappend '() x) x))
+
+(null (revappend '() '()))
+
+(eq (revappend '() 'a) 'a)
+
+(equal (revappend '(a) 'b) '(a . b))
+
+(equal (revappend '(a) '()) '(a))
+
+(equal (revappend '(1 2 3) '()) '(3 2 1))
+
+
+(equal (nreconc (list 'a 'b 'c) '(d e f))
+ '(c b a d e f))
+
+(let* ((x (list 'a 'b 'c))
+ (y '(d e f))
+ (z (nreconc x y)))
+ (and (equal z '(c b a d e f))
+ (eq (nthcdr 3 z) y)))
+
+(let ((x (list 'a 'b 'c)))
+ (eq (nreconc '() x) x))
+
+(null (nreconc '() '()))
+
+(eq (nreconc '() 'a) 'a)
+
+(equal (nreconc (list 'a) 'b) '(a . b))
+
+(equal (nreconc (list 'a) '()) '(a))
+
+(equal (nreconc (list 1 2 3) '()) '(3 2 1))
+
+
+(null (butlast nil))
+(null (butlast nil 1))
+(null (butlast nil 2))
+(null (butlast nil 3))
+(equal (butlast '(1 2 3 4 5)) '(1 2 3 4))
+(equal (butlast '(1 2 3 4 5) 1) '(1 2 3 4))
+(equal (butlast '(1 2 3 4 5) 2) '(1 2 3))
+(equal (butlast '(1 2 3 4 5) 3) '(1 2))
+(equal (butlast '(1 2 3 4 5) 4) '(1))
+(equal (butlast '(1 2 3 4 5) 5) '())
+(equal (butlast '(1 2 3 4 5) 6) '())
+(equal (butlast '(1 2 3 4 5) 7) '())
+
+(equal (butlast '(1 2 3 4 5 . 6)) '(1 2 3 4))
+(equal (butlast '(1 2 3 4 5 . 6) 1) '(1 2 3 4))
+(equal (butlast '(1 2 3 4 5 . 6) 2) '(1 2 3))
+(equal (butlast '(1 2 3 4 5 . 6) 3) '(1 2))
+(equal (butlast '(1 2 3 4 5 . 6) 4) '(1))
+(equal (butlast '(1 2 3 4 5 . 6) 5) '())
+(equal (butlast '(1 2 3 4 5 . 6) 6) '())
+(equal (butlast '(1 2 3 4 5 . 6) 7) '())
+
+(let ((a '(1 2 3 4 5)))
+ (equal (butlast a 3) '(1 2))
+ (equal a '(1 2 3 4 5)))
+
+
+(null (nbutlast nil))
+(null (nbutlast nil 1))
+(null (nbutlast nil 2))
+(null (nbutlast nil 3))
+(equal (nbutlast (list 1 2 3 4 5)) '(1 2 3 4))
+(equal (nbutlast (list 1 2 3 4 5) 1) '(1 2 3 4))
+(equal (nbutlast (list 1 2 3 4 5) 2) '(1 2 3))
+(equal (nbutlast (list 1 2 3 4 5) 3) '(1 2))
+(equal (nbutlast (list 1 2 3 4 5) 4) '(1))
+(equal (nbutlast (list 1 2 3 4 5) 5) '())
+(equal (nbutlast (list 1 2 3 4 5) 6) '())
+(equal (nbutlast (list 1 2 3 4 5) 7) '())
+
+(equal (nbutlast (list* 1 2 3 4 5 6)) '(1 2 3 4))
+(equal (nbutlast (list* 1 2 3 4 5 6) 1) '(1 2 3 4))
+(equal (nbutlast (list* 1 2 3 4 5 6) 2) '(1 2 3))
+(equal (nbutlast (list* 1 2 3 4 5 6) 3) '(1 2))
+(equal (nbutlast (list* 1 2 3 4 5 6) 4) '(1))
+(equal (nbutlast (list* 1 2 3 4 5 6) 5) '())
+(equal (nbutlast (list* 1 2 3 4 5 6) 6) '())
+(equal (nbutlast (list* 1 2 3 4 5 6) 7) '())
+
+(let* ((a '(1 2 3 4 5))
+ (b (nbutlast a 3)))
+ (and (eq a b)
+ (equal a '(1 2))))
+
+
+(let ((x '(0 1 2 3 4 5 6 7 8 9)))
+ (eq (last x) (nthcdr 9 x)))
+
+(null (last nil))
+
+(let ((x '(0 1 . 2)))
+ (eq (last x) (cdr x)))
+
+(eql (last '(1 . 2) 0) 2)
+
+(let ((x '(0 1 2 3 4)))
+ (eq (last x 0) nil))
+
+(let ((x '(0 1 2 3 4)))
+ (eq (last x) (nthcdr 4 x)))
+
+(let ((x '(0 1 2 3 4)))
+ (eq (last x 1) (nthcdr 4 x)))
+
+(let ((x '(0 1 2 3 4)))
+ (eq (last x 2) (cdddr x)))
+
+(let ((x '(0 1 2 3 4)))
+ (eq (last x 3) (cddr x)))
+
+(let ((x '(0 1 2 3 4)))
+ (eq (last x 4) (cdr x)))
+
+(let ((x '(0 1 2 3 4)))
+ (eq (last x 5) x))
+
+(let ((x '(0 1 2 3 4)))
+ (eq (last x 6) x))
+
+(let ((x '(0 1 2 3 4)))
+ (eq (last x 7) x))
+
+(let ((x '(0 1 2 3 4)))
+ (eq (last x 8) x))
+
+
+(tailp '() '())
+
+(tailp '() '(1))
+
+(tailp '() '(1 2 3 4 5 6 7 8 9))
+
+(let ((x '(1 2 3)))
+ (and (tailp x x)
+ (tailp (cdr x) x)
+ (tailp (cddr x) x)
+ (tailp (cdddr x) x)))
+
+(let ((x '(1 . 2)))
+ (and (tailp x x)
+ (tailp (cdr x) x)))
+
+(not (tailp nil '(1 . 2)))
+
+(not (tailp 'x '(1 2 3 4 5 6)))
+
+(not (tailp (list 1 2 3) '(1 2 3)))
+
+(let ((x '(1 2 3 4 5 . 6)))
+ (tailp (last x) x))
+
+(let ((x '(1 2 3 4 5 . 6)))
+ (tailp (last x) x))
+
+
+(null (ldiff '() '()))
+
+(equal (ldiff '(1 . 2) 2) '(1))
+
+(equal (ldiff '(1 2 3 4 5 6 7 8 9) '())
+ '(1 2 3 4 5 6 7 8 9))
+
+(let ((x '(1 2 3)))
+ (and (null (ldiff x x))
+ (equal (ldiff x (cdr x)) '(1))
+ (equal (ldiff x (cddr x)) '(1 2))
+ (equal (ldiff x (cdddr x)) '(1 2 3))))
+
+(let* ((x '(1 2 3))
+ (y '(a b c))
+ (z (ldiff x y)))
+ (and (not (eq x z))
+ (equal z '(1 2 3))))
+
+(equal (member 'a '(a b c d)) '(a b c d))
+(equal (member 'b '(a b c d)) '(b c d))
+(equal (member 'c '(a b c d)) '(c d))
+(equal (member 'd '(a b c d)) '(d))
+(equal (member 'e '(a b c d)) '())
+(equal (member 'f '(a b c d)) '())
+
+(let ((x '(a b c d)))
+ (eq (member 'a x) x)
+ (eq (member 'b x) (cdr x))
+ (eq (member 'c x) (cddr x))
+ (eq (member 'd x) (cdddr x))
+ (eq (member 'e x) nil))
+
+
+(equal (member 'a '(a b c d) :test #'eq) '(a b c d))
+(equal (member 'b '(a b c d) :test #'eq) '(b c d))
+(equal (member 'c '(a b c d) :test #'eq) '(c d))
+(equal (member 'd '(a b c d) :test #'eq) '(d))
+(equal (member 'e '(a b c d) :test #'eq) '())
+(equal (member 'f '(a b c d) :test #'eq) '())
+
+(null (member 'a '()))
+
+(let* ((x '((1 . a) (2 . b) (3 . c) (4 . d) (5 . e)))
+ (y (member 'd x :key #'cdr :test #'eq)))
+ (and (equal y '((4 . d) (5 . e)))
+ (eq y (nthcdr 3 x))))
+
+(let* ((x '((1 . a) (2 . b) (3 . c) (4 . d) (5 . e)))
+ (y (member 'd x :key #'cdr)))
+ (and (equal y '((4 . d) (5 . e)))
+ (eq y (nthcdr 3 x))))
+
+(let* ((x '((1 . a) (2 . b) (3 . c) (4 . d) (5 . e)))
+ (y (member 'd x :key #'cdr :test-not (complement #'eq))))
+ (and (equal y '((4 . d) (5 . e)))
+ (eq y (nthcdr 3 x))))
+
+(let* ((x '((1 . a) (2 . b) (3 . c) (4 . d) (5 . e)))
+ (y (member 'd x :test-not (complement #'eq))))
+ (eq y nil))
+
+(equal (member 2 '((1 . 2) (3 . 4)) :test-not #'= :key #'cdr)
+ '((3 . 4)))
+
+(equal (member-if #'(lambda (x) (eql x 'a)) '(a b c d)) '(a b c d))
+(equal (member-if #'(lambda (x) (eql x 'b)) '(a b c d)) '(b c d))
+(equal (member-if #'(lambda (x) (eql x 'c)) '(a b c d)) '(c d))
+(equal (member-if #'(lambda (x) (eql x 'd)) '(a b c d)) '(d))
+(equal (member-if #'(lambda (x) (eql x 'e)) '(a b c d)) '())
+(equal (member-if #'(lambda (x) (eql x 'f)) '(a b c d)) '())
+
+(null (member-if #'(lambda (x) (eql x 'a)) '()))
+
+(let* ((x '((1 . a) (2 . b) (3 . c) (4 . d) (5 . e)))
+ (y (member-if #'(lambda (p) (eq p 'd)) x :key #'cdr)))
+ (and (equal y '((4 . d) (5 . e)))
+ (eq y (nthcdr 3 x))))
+
+(equal (member-if #'cdr '((1) (2 . 2) (3 3 . 3)))
+ '((2 . 2) (3 3 . 3)))
+
+(null (member-if #'zerop '(7 8 9)))
+
+
+(equal (member-if-not #'(lambda (x) (not (eql x 'a))) '(a b c d)) '(a b c d))
+(equal (member-if-not #'(lambda (x) (not (eql x 'b))) '(a b c d)) '(b c d))
+(equal (member-if-not #'(lambda (x) (not (eql x 'c))) '(a b c d)) '(c d))
+(equal (member-if-not #'(lambda (x) (not (eql x 'd))) '(a b c d)) '(d))
+(equal (member-if-not #'(lambda (x) (not (eql x 'e))) '(a b c d)) '())
+(equal (member-if-not #'(lambda (x) (not (eql x 'f))) '(a b c d)) '())
+
+(null (member-if-not #'(lambda (x) (not (eql x 'a))) '()))
+
+(let* ((x '((1 . a) (2 . b) (3 . c) (4 . d) (5 . e)))
+ (y (member-if-not #'(lambda (p) (not (eq p 'd))) x :key #'cdr)))
+ (and (equal y '((4 . d) (5 . e)))
+ (eq y (nthcdr 3 x))))
+
+
+(let ((x '((1 2) (2 3) (3 4) (4 5)))
+ (y nil))
+ (and (eq (mapc #'(lambda (a) (push (car a) y)) x) x)
+ (equal y '(4 3 2 1))))
+
+(let ((dummy nil)
+ (list-1 '(1 2 3 4)))
+ (and (eq (mapc #'(lambda (&rest x) (setq dummy (append dummy x)))
+ list-1
+ '(a b c d e)
+ '(x y z))
+ list-1)
+ (equal dummy '(1 a x 2 b y 3 c z))))
+
+(let* ((x '(0 1 2 3))
+ (y nil)
+ (z (mapc #'(lambda (a b c) (push (list a b c) y))
+ x '(1 2 3 4) '(2 3 4 5))))
+ (and (eq z x)
+ (equal y '((3 4 5) (2 3 4) (1 2 3) (0 1 2)))))
+
+
+(let* ((x '(0 1 2 3))
+ (y nil)
+ (z (mapc #'(lambda (a b c) (push (list a b c) y))
+ nil x '(1 2 3 4) '(2 3 4 5))))
+ (and (null z)
+ (null y)))
+
+(let ((sum 0))
+ (mapc #'(lambda (&rest rest) (setq sum (+ sum (apply #'+ rest))))
+ '(0 1 2)
+ '(1 2 0)
+ '(2 0 1))
+ (eql sum 9))
+
+(let ((result 'initial-value)
+ (list-1 nil))
+ (and (eq (mapc #'(lambda (a b) (setq result (cons (cons a b) result))) list-1) list-1)
+ (eq result 'initial-value)))
+
+(let ((result 'initial-value)
+ (list-1 nil))
+ (and (eq (mapc #'(lambda (a b) (setq result (cons (cons a b) result)))
+ list-1
+ '(1 2 3))
+ list-1)
+ (eq result 'initial-value)))
+
+(let ((result 'initial-value)
+ (list-1 '(1 2 3)))
+ (and (eq (mapc #'(lambda (a b) (setq result (cons (cons a b) result)))
+ list-1
+ '())
+ list-1)
+ (eq result 'initial-value)))
+
+
+(equal (mapcar #'car '((1 2) (2 3) (3 4) (4 5)))
+ '(1 2 3 4))
+
+(null (mapcar #'identity '()))
+
+(equal (mapcar #'list '(0 1 2 3) '(a b c d) '(w x y z))
+ '((0 a w) (1 b x) (2 c y) (3 d z)))
+
+(null (mapcar #'list '() '(0 1 2 3) '(1 2 3 4) '(2 3 4 5)))
+(null (mapcar #'list '(0 1 2 3) '() '(1 2 3 4) '(2 3 4 5)))
+(null (mapcar #'list '(0 1 2 3) '(1 2 3 4) '() '(2 3 4 5)))
+(null (mapcar #'list '(0 1 2 3) '(1 2 3 4) '(2 3 4 5) '()))
+
+(equal (mapcar #'list '(0) '(a b) '(x y z)) '((0 a x)))
+(equal (mapcar #'list '(a b) '(0) '(x y z)) '((a 0 x)))
+(equal (mapcar #'list '(a b) '(x y z) '(0)) '((a x 0)))
+
+(equal (mapcar #'cons '(a b c) '(1 2 3))
+ '((A . 1) (B . 2) (C . 3)))
+
+
+(equal (mapcan #'cdr (copy-tree '((1 2) (2 3) (3 4) (4 5))))
+ '(2 3 4 5))
+
+(equal (mapcan #'append
+ '((1 2 3) (4 5 6) (7 8 9))
+ '((a) (b c) (d e f))
+ (list (list 'x 'y 'z) (list 'y 'z) (list 'z)))
+ '(1 2 3 a x y z 4 5 6 b c y z 7 8 9 d e f z))
+
+(null (mapcan #'append '((1 2 3) (4 5 6) (7 8 9)) '((a) (b c)) '()))
+(null (mapcan #'append '((1 2 3) (4 5 6) (7 8 9)) '() '((a) (b c))))
+(null (mapcan #'append '() '((1 2 3) (4 5 6) (7 8 9)) '((a) (b c))))
+
+(equal (mapcan #'list
+ (list 1 2 3 4 5)
+ (list 2 3 4 5 6)
+ (list 3 4 5 6 7)
+ (list 4 5 6 7 8))
+ '(1 2 3 4 2 3 4 5 3 4 5 6 4 5 6 7 5 6 7 8))
+
+(equal (mapcan #'(lambda (x y) (if (null x) nil (list x y)))
+ '(nil nil nil d e)
+ '(1 2 3 4 5 6))
+ '(d 4 e 5))
+
+(equal (mapcan #'(lambda (x) (and (numberp x) (list x)))
+ '(a 1 b c 3 4 d 5))
+ '(1 3 4 5))
+
+
+(equal (maplist #'identity '(a b c d))
+ '((a b c d) (b c d) (c d) (d)))
+
+(equal (maplist #'car '((1 2) (2 3) (3 4) (4 5)))
+ '((1 2) (2 3) (3 4) (4 5)))
+
+(equal (maplist #'list '(a b c) '(b c d) '(c d e))
+ '(((a b c) (b c d) (c d e))
+ ((b c) (c d) (d e))
+ ((c) (d) (e))))
+
+(equal (maplist #'append '(a b c) '(b c d) '(c d e))
+ '((a b c b c d c d e) (b c c d d e) (c d e)))
+
+(equal (maplist #'append '(a b c) '(b c) '(c))
+ '((a b c b c c)))
+
+(null (maplist #'append '() '(a b c) '(b c) '(c)))
+(null (maplist #'append '(a b c) '() '(b c) '(c)))
+(null (maplist #'append '(a b c) '(b c) '(c) '()))
+
+(let ((x '((1 2) (2 3) (3 4) (4 5)))
+ (y nil))
+ (and (eq (mapl #'(lambda (a) (push (car a) y)) x) x)
+ (equal y '((4 5) (3 4) (2 3) (1 2)))))
+
+(let ((x nil))
+ (and (null (mapl #'(lambda (&rest rest) (push rest x)) '() '(0) '(0 1)))
+ (null x)))
+
+(let ((x nil))
+ (and (equal (mapl #'(lambda (&rest rest) (push rest x)) '(0) '() '(0 1))
+ '(0))
+ (null x)))
+
+(let ((x nil))
+ (and (equal (mapl #'(lambda (&rest rest) (push rest x)) '(0) '(0 1) '())
+ '(0))
+ (null x)))
+
+(equal (mapcon #'car (copy-tree '((1 2) (2 3) (3 4) (4 5))))
+ '(1 2 2 3 3 4 4 5))
+
+
+(equal (mapcon #'list '(0 1 2 3) '(1 2 3 4) '(2 3 4 5) '(3 4 5 6))
+ '((0 1 2 3) (1 2 3 4) (2 3 4 5) (3 4 5 6) (1 2 3) (2 3 4) (3 4 5)
+ (4 5 6) (2 3) (3 4) (4 5) (5 6) (3) (4) (5) (6)))
+
+
+(null (mapcon #'list '() '(0 1 2 3) '(1 2 3 4) '(2 3 4 5) '(3 4 5 6)))
+(null (mapcon #'list '(0 1 2 3) '() '(1 2 3 4) '(2 3 4 5) '(3 4 5 6)))
+(null (mapcon #'list '(0 1 2 3) '(1 2 3 4) '() '(2 3 4 5) '(3 4 5 6)))
+(null (mapcon #'list '(0 1 2 3) '(1 2 3 4) '(2 3 4 5) '() '(3 4 5 6)))
+(null (mapcon #'list '(0 1 2 3) '(1 2 3 4) '(2 3 4 5) '(3 4 5 6) '()))
+
+
+(let* ((x '((apple . 1) (orange . 2) (grapes . 3)))
+ (y (acons 'plum 9 x)))
+ (and (equal y '((plum . 9) (apple . 1) (orange . 2) (grapes . 3)))
+ (eq x (cdr y))))
+
+(equal (acons 'a '0 nil) '((a . 0)))
+
+(equal (acons 'apple 1 (acons 'orange 2 (acons 'grapes '3 nil)))
+ '((apple . 1) (orange . 2) (grapes . 3)))
+
+(equal (acons nil nil nil) '((nil)))
+
+
+(let ((alist '((x . 100) (y . 200) (z . 50))))
+ (eq (assoc 'y alist) (cadr alist)))
+
+(null (assoc 'no-such-key '((x . 100) (y . 200) (z . 50))))
+
+(let ((alist '((x . 100) (y . 200) (z . 50))))
+ (eq (assoc 'y alist :test #'eq) (cadr alist)))
+
+(null (assoc 'key '()))
+(null (assoc 'nil '(())))
+(null (assoc 'nil '(() ())))
+(let ((alist '(nil nil nil (x . 100) (y . 200) (z . 50))))
+ (eq (assoc 'y alist) (car (cddddr alist))))
+(let ((alist '((1 . a) nil (2 . b) (nil))))
+ (eq (assoc 'nil alist) (cadddr alist)))
+
+(let ((alist '((x . 100) (y . 200) (x . 100) (z . 50))))
+ (eq (assoc 'y alist) (cadr alist)))
+
+(let ((alist '((a . 1) (b . 2) (c . 3) (d . 4))))
+ (eq (assoc 'a alist :test-not (complement #'eq)) (car alist)))
+
+(let ((alist '((a . 1) (b . 2) (c . 3) (d . 4))))
+ (null (assoc 'z alist :test-not (complement #'eq))))
+
+(let ((alist '(((a aa aaa)) ((b bb bbb)) ((c cc ccc)) ((d dd ddd)))))
+ (eq (assoc 'aa alist :key #'cadr :test #'eq) (car alist)))
+
+(let ((alist '(((a aa aaa)) ((b bb bbb)) ((c cc ccc)) ((d dd ddd)))))
+ (eq (assoc 'bb alist :key #'cadr :test #'eq) (cadr alist)))
+
+(let ((alist '(((a aa aaa)) ((b bb bbb)) ((c cc ccc)) ((d dd ddd)))))
+ (eq (assoc 'cc alist :key #'cadr :test #'eq) (caddr alist)))
+
+(let ((alist '(((a aa aaa)) ((b bb bbb)) ((c cc ccc)) ((d dd ddd)))))
+ (eq (assoc 'dd alist :key #'cadr :test #'eq) (cadddr alist)))
+
+(let ((alist '(((a aa aaa)) ((b bb bbb)) ((c cc ccc)) ((d dd ddd)))))
+ (null (assoc 'ee alist :key #'cadr :test #'eq)))
+
+(let ((alist '(((a aa aaa)) nil ((b bb bbb)) ((c cc ccc)) ((d dd ddd)))))
+ (eq (assoc 'dd alist :key #'cadr :test #'eq) (car (cddddr alist))))
+
+(let ((alist '(((a aa aaa)) ((b bb bbb)) nil ((c cc ccc)) ((d dd ddd)))))
+ (eq (assoc 'dd alist :key #'cadr :test #'eq) (car (cddddr alist))))
+
+(let ((alist '(((a aa aaa)) nil ((b bb bbb)) ((c cc ccc)) ((d dd ddd)))))
+ (eq (assoc 'dd alist :key #'cadr :test #'eq) (car (cddddr alist))))
+
+(let ((alist '(((a aa aaa)) ((b bb bbb)) ((c cc ccc)) ((d dd ddd)) nil)))
+ (eq (assoc 'dd alist :key #'cadr :test #'eq) (cadddr alist)))
+
+
+
+(let ((alist '((x . 100) (y . 200) (z . 50))))
+ (eq (assoc-if #'(lambda (arg) (eq arg 'y)) alist) (cadr alist)))
+
+(null (assoc-if #'consp '((x . 100) (y . 200) (z . 50))))
+
+(null (assoc-if #'(lambda (x) (eq x 'key)) '()))
+(null (assoc-if #'identity '(())))
+(null (assoc-if #'identity '(() ())))
+(let ((alist '(nil nil nil (x . 100) (y . 200) (z . 50))))
+ (eq (assoc-if #'(lambda (arg) (eq arg 'y)) alist) (car (cddddr alist))))
+(let ((alist '((1 . a) nil (2 . b) (nil))))
+ (eq (assoc-if #'(lambda (arg) (null arg)) alist) (cadddr alist)))
+
+
+(let ((alist '(((a aa aaa)) ((b bb bbb)) ((c cc ccc)) ((d dd ddd)))))
+ (eq (assoc-if #'(lambda (x) (eq x 'aa)) alist :key #'cadr) (car alist)))
+
+(let ((alist '(((a aa aaa)) ((b bb bbb)) ((c cc ccc)) ((d dd ddd)))))
+ (eq (assoc-if #'(lambda (x) (eq x 'bb)) alist :key #'cadr) (cadr alist)))
+
+(let ((alist '(((a aa aaa)) ((b bb bbb)) ((c cc ccc)) ((d dd ddd)))))
+ (null (assoc-if #'(lambda (x) (eq x 'ee)) alist :key #'cadr)))
+
+
+
+(let ((alist '((x . 100) (y . 200) (z . 50))))
+ (eq (assoc-if-not #'(lambda (arg) (not (eq arg 'y))) alist) (cadr alist)))
+
+(null (assoc-if-not (complement #'consp) '((x . 100) (y . 200) (z . 50))))
+
+(null (assoc-if-not #'(lambda (x) (not (eq x 'key))) '()))
+(null (assoc-if-not #'identity '(())))
+(null (assoc-if-not #'identity '(() ())))
+(let ((alist '(nil nil nil (x . 100) (y . 200) (z . 50))))
+ (eq (assoc-if-not #'(lambda (arg) (not (eq arg 'y))) alist)
+ (car (cddddr alist))))
+(let ((alist '((1 . a) nil (2 . b) (nil))))
+ (eq (assoc-if-not #'identity alist) (cadddr alist)))
+
+(let ((alist '(((a aa aaa)) ((b bb bbb)) ((c cc ccc)) ((d dd ddd)))))
+ (eq (assoc-if-not #'(lambda (x) (not (eq x 'aa))) alist :key #'cadr)
+ (car alist)))
+
+(let ((alist '(((a aa aaa)) ((b bb bbb)) ((c cc ccc)) ((d dd ddd)))))
+ (eq (assoc-if-not #'(lambda (x) (not (eq x 'bb))) alist :key #'cadr)
+ (cadr alist)))
+
+(let ((alist '(((a aa aaa)) ((b bb bbb)) ((c cc ccc)) ((d dd ddd)))))
+ (null (assoc-if-not #'(lambda (x) (not (eq x 'ee))) alist :key #'cadr)))
+
+
+(equal (copy-alist '((a . 10) (b . 100) (c . 1000)))
+ '((a . 10) (b . 100) (c . 1000)))
+
+(let* ((alist '((a . 10) (b . 100) (c . 1000)))
+ (copy (copy-alist alist)))
+ (and (not (eq alist copy))
+ (not (eq (cdr alist) (cdr copy)))
+ (not (eq (cddr alist) (cddr copy)))
+ (not (eq (car alist) (car copy)))
+ (not (eq (cadr alist) (cadr copy)))
+ (not (eq (caddr alist) (caddr copy)))))
+
+(let* ((alist '((a 10 x) (b 100 y) (c 1000 z)))
+ (copy (copy-alist alist)))
+ (and (not (eq alist copy))
+ (not (eq (cdr alist) (cdr copy)))
+ (not (eq (cddr alist) (cddr copy)))
+ (not (eq (car alist) (car copy)))
+ (not (eq (cadr alist) (cadr copy)))
+ (not (eq (caddr alist) (caddr copy)))
+ (eq (cdar alist) (cdar copy))
+ (eq (cdadr alist) (cdadr copy))
+ (eq (cdaddr alist) (cdaddr copy))))
+
+
+(let* ((alist (pairlis '(x y z) '(xx yy zz) '((a . aa) (b . bb)))))
+ (and (equal (assoc 'x alist) '(x . xx))
+ (equal (assoc 'y alist) '(y . yy))
+ (equal (assoc 'z alist) '(z . zz))
+ (equal (assoc 'a alist) '(a . aa))
+ (equal (assoc 'b alist) '(b . bb))
+ (null (assoc 'key alist))))
+
+(let* ((alist (pairlis '(x y z) '(xx yy zz))))
+ (and (equal (assoc 'x alist) '(x . xx))
+ (equal (assoc 'y alist) '(y . yy))
+ (equal (assoc 'z alist) '(z . zz))
+ (null (assoc 'key alist))))
+
+
+(let ((alist '((x . 100) (y . 200) (z . 50))))
+ (eq (rassoc '200 alist) (cadr alist)))
+
+(null (rassoc 'no-such-datum '((x . 100) (y . 200) (z . 50))))
+
+(let ((alist '((x . 100) (y . 200) (z . 50))))
+ (eq (rassoc '200 alist :test #'=) (cadr alist)))
+
+(null (rassoc 'key '()))
+(null (rassoc 'nil '(())))
+(null (rassoc 'nil '(() ())))
+
+(let ((alist '(nil nil nil (x . 100) (y . 200) (z . 50))))
+ (eq (rassoc '200 alist) (car (cddddr alist))))
+(let ((alist '((1 . a) nil (2 . b) (nil))))
+ (eq (rassoc 'nil alist) (cadddr alist)))
+
+(let ((alist '((x . 100) (y . 200) (x . 100) (z . 50))))
+ (eq (rassoc '200 alist) (cadr alist)))
+
+(let ((alist '((a . 1) (b . 2) (c . 3) (d . 4))))
+ (eq (rassoc '1 alist :test-not (complement #'=)) (car alist)))
+
+(let ((alist '((a . 1) (b . 2) (c . 3) (d . 4))))
+ (null (rassoc '9 alist :test-not (complement #'=))))
+
+(let ((alist '((a aa aaa) (b bb bbb) (c cc ccc) (d dd ddd))))
+ (eq (rassoc 'aa alist :key #'car :test #'eq) (car alist)))
+
+(let ((alist '((a aa aaa) (b bb bbb) (c cc ccc) (d dd ddd))))
+ (eq (rassoc 'ddd alist :key #'cadr :test #'eq) (cadddr alist)))
+
+(let ((alist '((a aa aaa) (b bb bbb) (c cc ccc) (d dd ddd))))
+ (null (rassoc 'eee alist :key #'cadr :test #'eq)))
+
+(let ((alist '((a aa aaa) nil (b bb bbb) (c cc ccc) (d dd ddd))))
+ (eq (rassoc 'ddd alist :key #'cadr :test #'eq) (car (cddddr alist))))
+
+(let ((alist '((a aa aaa) (b bb bbb) nil (c cc ccc) (d dd ddd))))
+ (eq (rassoc 'ddd alist :key #'cadr :test #'eq) (car (cddddr alist))))
+
+(let ((alist '((a aa aaa) (b bb bbb) (c cc ccc) (d dd ddd) nil)))
+ (eq (rassoc 'ddd alist :key #'cadr :test #'eq) (car (cdddr alist))))
+
+(let ((alist '((x . 100) (y . 200) (z . 50))))
+ (eq (rassoc-if #'(lambda (arg) (= arg 200)) alist) (cadr alist)))
+
+(null (rassoc-if #'consp '((x . 100) (y . 200) (z . 50))))
+
+(null (rassoc-if #'(lambda (x) (eq x 'key)) '()))
+(null (rassoc-if #'identity '(())))
+(null (rassoc-if #'identity '(() ())))
+(let ((alist '(nil nil nil (x . 100) (y . 200) (z . 50))))
+ (eq (rassoc-if #'(lambda (arg) (= arg 200)) alist) (car (cddddr alist))))
+(let ((alist '((1 . a) nil (2 . b) (nil))))
+ (eq (rassoc-if #'(lambda (arg) (null arg)) alist) (cadddr alist)))
+
+(let ((alist '((a aa aaa) (b bb bbb) (c cc ccc) (d dd ddd))))
+ (eq (rassoc-if #'(lambda (x) (eq x 'aaa)) alist :key #'cadr) (car alist)))
+
+(let ((alist '((a aa aaa) (b bb bbb) (c cc ccc) (d dd ddd))))
+ (eq (rassoc-if #'(lambda (x) (eq x 'bbb)) alist :key #'cadr) (cadr alist)))
+
+(let ((alist '((a aa aaa) (b bb bbb) (c cc ccc) (d dd ddd))))
+ (null (rassoc-if #'(lambda (x) (eq x 'eee)) alist :key #'cadr)))
+
+
+(let ((alist '((x . 100) (y . 200) (z . 50))))
+ (eq (rassoc-if-not #'(lambda (arg) (not (= arg 200))) alist) (cadr alist)))
+
+(null (rassoc-if-not (complement #'consp) '((x . 100) (y . 200) (z . 50))))
+
+(null (rassoc-if-not #'(lambda (x) (not (eq x 'key))) '()))
+(null (rassoc-if-not #'identity '(())))
+(null (rassoc-if-not #'identity '(() ())))
+(let ((alist '(nil nil nil (x . 100) (y . 200) (z . 50))))
+ (eq (rassoc-if-not #'(lambda (arg) (not (= arg 200))) alist)
+ (car (cddddr alist))))
+(let ((alist '((1 . a) nil (2 . b) (nil))))
+ (eq (assoc-if-not #'identity alist) (cadddr alist)))
+
+(let ((alist '((a aa aaa) (b bb bbb) (c cc ccc) (d dd ddd))))
+ (eq (rassoc-if-not #'(lambda (x) (not (eq x 'aaa))) alist :key #'cadr)
+ (car alist)))
+
+(let ((alist '((a aa aaa) (b bb bbb) (c cc ccc) (d dd ddd))))
+ (eq (rassoc-if-not #'(lambda (x) (not (eq x 'bbb))) alist :key #'cadr)
+ (cadr alist)))
+
+(let ((alist '(((a aa aaa) . 0) ((b bb bbb) . 1) ((c cc ccc) . 2))))
+ (eq (rassoc-if-not #'(lambda (x) (not (= x '2))) alist :key #'1+)
+ (cadr alist)))
+
+
+(let ((plist '(prop1 1 prop2 2 prop3 3 prop4 4)))
+ (multiple-value-bind (indicator value tail)
+ (get-properties plist '(prop3 prop4 propX propY))
+ (and (eq indicator 'prop3)
+ (eql value 3)
+ (eq tail (nthcdr 4 plist)))))
+
+(multiple-value-bind (indicator value tail)
+ (get-properties '(prop1 1 prop2 2 prop3 3 prop4 4)
+ '(propX propY propZ))
+ (and (eq indicator nil)
+ (eq value nil)
+ (eq tail nil)))
+
+(let ((plist '(prop1 1 prop2 2 prop3 3 prop4 4)))
+ (multiple-value-bind (indicator value tail)
+ (get-properties plist '(prop1))
+ (and (eq indicator 'prop1)
+ (eql value 1)
+ (eq tail plist))))
+
+(let ((plist '(prop1 1 nil nil prop2 2 prop3 3 prop4 4)))
+ (multiple-value-bind (indicator value tail)
+ (get-properties plist '(nil))
+ (and (eq indicator nil)
+ (eql value nil)
+ (eq tail (cddr plist)))))
+
+(let ((plist '(prop1 1 prop2 2 prop3 3 prop4 4)))
+ (multiple-value-bind (indicator value tail)
+ (get-properties plist '(prop3 prop4 propX propY prop1))
+ (and (eq indicator 'prop1)
+ (eql value 1)
+ (eq tail plist))))
+
+
+(let ((plist '(prop1 1 prop2 2 prop3 3 prop4 4)))
+ (eql (getf plist 'prop1) 1))
+
+(let ((plist '(prop1 1 prop2 2 prop3 3 prop4 4)))
+ (eql (getf plist 'prop2) 2))
+
+(let ((plist '(prop1 1 prop2 2 prop3 3 prop4 4)))
+ (eql (getf plist 'prop3) 3))
+
+(let ((plist '(prop1 1 prop2 2 prop3 3 prop4 4)))
+ (eql (getf plist 'prop4) 4))
+
+(let ((plist
+ '(prop1 1 prop2 2 prop3 3 prop4 4 prop1 5 prop2 6 prop3 7 prop4 8)))
+ (eql (getf plist 'prop1) 1))
+
+(let ((plist
+ '(prop1 1 prop2 2 prop3 3 prop4 4 prop1 5 prop2 6 prop3 7 prop4 8)))
+ (eql (getf plist 'prop2) 2))
+
+(let ((plist
+ '(prop1 1 prop2 2 prop3 3 prop4 4 prop1 5 prop2 6 prop3 7 prop4 8)))
+ (eql (getf plist 'prop3) 3))
+
+(let ((plist
+ '(prop1 1 prop2 2 prop3 3 prop4 4 prop1 5 prop2 6 prop3 7 prop4 8)))
+ (eql (getf plist 'prop4) 4))
+
+(let ((plist
+ '(prop1 1 prop2 2 prop3 3 prop4 4 prop1 5 prop2 6 prop3 7 prop4 8)))
+ (null (getf plist 'propX)))
+
+(let ((plist '(prop1 1 prop2 2 prop3 3 prop4 4)))
+ (eq (getf plist 'weird-property 'not-found) 'not-found))
+
+
+(let ((plist (copy-list '(prop1 1 prop2 2 prop3 3 prop4 4))))
+ (and (eql (setf (getf plist 'prop1) 9) 9)
+ (eql (getf plist 'prop1) 9)))
+
+(let ((plist nil))
+ (and (eql (setf (getf plist 'prop1) 9) 9)
+ (eql (getf plist 'prop1) 9)))
+
+(let ((plist '()))
+ (incf (getf plist 'count 0))
+ (eql (getf plist 'count) 1))
+
+(let ((x (list nil)))
+ (and (eql (setf (getf (car x) 'prop1) 9) 9)
+ (eql (getf (car x) 'prop1) 9)))
+
+
+(let ((plist (list 'p1 1 'p2 2 'p3 3 'p4 4)))
+ (and (remf plist 'p2)
+ (eq (getf plist 'p2 'not-found) 'not-found)))
+
+(let ((plist (list 'p1 1 'p2 2 'p3 3 'p4 4)))
+ (and (remf plist 'p3)
+ (eq (getf plist 'p3 'not-found) 'not-found)))
+
+(let ((plist (list 'p1 1 'p2 2 'p3 3 'p4 4)))
+ (and (remf plist 'p4)
+ (eq (getf plist 'p4 'not-found) 'not-found)))
+
+(let ((plist (list 'p1 1 'p2 2 'p3 3 'p4 4)))
+ (and (null (remf plist 'pX))
+ (equal plist '(p1 1 p2 2 p3 3 p4 4))))
+
+(let ((plist (list 'p1 1 'p2 2 'p3 3 'p4 4)))
+ (and (remf plist 'p4)
+ (remf plist 'p2)
+ (remf plist 'p3)
+ (remf plist 'p1)
+ (null (remf plist 'pX))
+ (null (remf plist 'p1))
+ (null (remf plist 'p2))
+ (null (remf plist 'p3))
+ (null (remf plist 'p4))
+ (null plist)))
+
+
+(let ((plist (list 'p1 1 'p2 2 'p3 3 'p4 4 'p1 5 'p2 6 'p3 7 'p4 8)))
+ (and (remf plist 'p4)
+ (remf plist 'p2)
+ (remf plist 'p3)
+ (remf plist 'p1)
+ (null (remf plist 'pX))
+ (eql (getf plist 'p1) 5)
+ (eql (getf plist 'p2) 6)
+ (eql (getf plist 'p3) 7)
+ (eql (getf plist 'p4) 8)))
+
+(let ((plist (list 'p1 100 'p1 1 'p2 2 'p3 3 'p4 4)))
+ (and (eql (getf plist 'p1) 100)
+ (remf plist 'p1)
+ (eql (getf plist 'p1) 1)
+ (remf plist 'p1)
+ (null (getf plist 'p1))))
+
+(let ((plist (list 'p1 1 'p2 2 'p3 3 'p4 4)))
+ (and (remf plist 'p4)
+ (null (getf plist 'p4))))
+
+
+(let ((list1 (list 1 1 2 3 4 'a 'b 'c "A" "B" "C" "d"))
+ (list2 (list 1 4 5 'b 'c 'd "a" "B" "c" "D")))
+ (null (set-exclusive-or (intersection list1 list2) '(C B 4 1 1)))
+ (null (set-exclusive-or (intersection list1 list2 :test 'equal)
+ '("B" C B 4 1 1)
+ :test 'equal))
+ (null (set-exclusive-or (intersection list1 list2 :test #'equalp)
+ '("d" "C" "B" "A" C B 4 1 1)
+ :test #'equalp)))
+
+(null (intersection '(0 1 2) '()))
+(null (intersection '() '()))
+(null (intersection '() '(0 1 2)))
+(equal (intersection '(0) '(0)) '(0))
+(equal (intersection '(0 1 2 3) '(2)) '(2))
+(member 0 (intersection '(0 0 0 0 0) '(0 1 2 3 4 5)))
+(null (set-exclusive-or (intersection '(0 1 2 3 4) '(4 3 2 1 0))
+ '(4 3 2 1 0)))
+(null (set-exclusive-or (intersection '(0 1 2 3 4) '(0 1 2 3 4))
+ '(0 1 2 3 4)))
+(null (set-exclusive-or (intersection '(0 1 2 3 4) '(4 3 2 1 0))
+ '(0 1 2 3 4)))
+
+
+(let ((list1 (list "A" "B" "C" "d" "e" "F" "G" "h"))
+ (list2 (list "a" "B" "c" "D" "E" "F" "g" "h")))
+ (null (set-exclusive-or (intersection list1 list2
+ :test #'char=
+ :key #'(lambda (x) (char x 0)))
+ '("B" "F" "h")
+ :test #'char=
+ :key #'(lambda (x) (char x 0)))))
+
+(let ((list1 (list "A" "B" "C" "d" "e" "F" "G" "h"))
+ (list2 (list "a" "B" "c" "D" "E" "F" "g" "h")))
+ (null (set-exclusive-or (intersection list1 list2
+ :test #'char-equal
+ :key #'(lambda (x) (char x 0)))
+ '("A" "B" "C" "d" "e" "F" "G" "h")
+ :test #'char-equal
+ :key #'(lambda (x) (char x 0)))))
+
+(let ((list1 (list "A" "B" "C" "d"))
+ (list2 (list "D" "E" "F" "g" "h")))
+ (null (set-exclusive-or (intersection list1 list2
+ :test #'char-equal
+ :key #'(lambda (x) (char x 0)))
+ '("d")
+ :test #'char-equal
+ :key #'(lambda (x) (char x 0)))))
+
+
+
+
+(let ((list1 (list 1 1 2 3 4 'a 'b 'c "A" "B" "C" "d"))
+ (list2 (list 1 4 5 'b 'c 'd "a" "B" "c" "D")))
+ (null (set-exclusive-or (nintersection (copy-list list1) list2) '(C B 4 1 1)))
+ (null (set-exclusive-or (nintersection (copy-list list1) list2 :test 'equal)
+ '("B" C B 4 1 1)
+ :test 'equal))
+ (null (set-exclusive-or (nintersection (copy-list list1) list2 :test #'equalp)
+ '("d" "C" "B" "A" C B 4 1 1)
+ :test #'equalp)))
+
+(null (nintersection (list 0 1 2) '()))
+(null (nintersection '() '()))
+(null (nintersection '() '(0 1 2)))
+(equal (nintersection (list 0) '(0)) '(0))
+(equal (nintersection (list 0 1 2 3) '(2)) '(2))
+(member 0 (nintersection (list 0 0 0 0 0) '(0 1 2 3 4 5)))
+(null (set-exclusive-or (nintersection (list 0 1 2 3 4) '(4 3 2 1 0))
+ '(4 3 2 1 0)))
+(null (set-exclusive-or (nintersection (list 0 1 2 3 4) '(0 1 2 3 4))
+ '(0 1 2 3 4)))
+(null (set-exclusive-or (nintersection (list 0 1 2 3 4) '(4 3 2 1 0))
+ '(0 1 2 3 4)))
+
+
+(let ((list1 (list "A" "B" "C" "d" "e" "F" "G" "h"))
+ (list2 (list "a" "B" "c" "D" "E" "F" "g" "h")))
+ (null (set-exclusive-or (nintersection list1 list2
+ :test #'char=
+ :key #'(lambda (x) (char x 0)))
+ '("B" "F" "h")
+ :test #'char=
+ :key #'(lambda (x) (char x 0)))))
+
+(let ((list1 (list "A" "B" "C" "d" "e" "F" "G" "h"))
+ (list2 (list "a" "B" "c" "D" "E" "F" "g" "h")))
+ (null (set-exclusive-or (nintersection list1 list2
+ :test #'char-equal
+ :key #'(lambda (x) (char x 0)))
+ '("A" "B" "C" "d" "e" "F" "G" "h")
+ :test #'char-equal
+ :key #'(lambda (x) (char x 0)))))
+
+(let ((list1 (list "A" "B" "C" "d"))
+ (list2 (list "D" "E" "F" "g" "h")))
+ (null (set-exclusive-or (nintersection list1 list2
+ :test #'char-equal
+ :key #'(lambda (x) (char x 0)))
+ '("d")
+ :test #'char-equal
+ :key #'(lambda (x) (char x 0)))))
+
+
+(let ((set '(a b c)))
+ (eq (adjoin 'a set) set))
+
+(let* ((set '(a b c))
+ (new-set (adjoin 'x set)))
+ (and (equal new-set '(x a b c))
+ (eq set (cdr new-set))))
+
+(equal (adjoin 1 nil) '(1))
+(equal (adjoin nil nil) '(nil))
+(equal (adjoin nil '(nil)) '(nil))
+(let ((set '((test-item 1))))
+ (equal (adjoin '(test-item 1) set) '((test-item 1) (test-item 1))))
+
+(let ((set '((test-item 1))))
+ (equal (adjoin '(test-item 1) set)
+ '((test-item 1) (test-item 1))))
+
+(let ((set '((test-item 1))))
+ (eq (adjoin '(test-item 1) set :test #'equal) set))
+
+(let ((set '((test-item 1))))
+ (eq (adjoin '(test-item) set :key #'car) set))
+
+(let ((set '((test-item 1))))
+ (eq (adjoin '(test-item) set :key #'car :test #'eq) set))
+
+(let ((set '(("test-item" 1))))
+ (eq (adjoin '("test-item") set :key #'car :test #'equal) set))
+
+
+(let ((set '((test-item 1))))
+ (eq (adjoin '(test-item 1) set :test-not (complement #'equal)) set))
+
+(let ((set '((test-item 1))))
+ (eq (adjoin '(test-item) set :test-not (complement #'eql) :key #'car) set))
+
+(let ((set '((test-item 1))))
+ (eq (adjoin '(test-item) set :key #'car :test-not (complement #'eq)) set))
+
+(let ((set '(("test-item" 1))))
+ (eq (adjoin '("test-item") set :key #'car :test-not (complement #'equal))
+ set))
+
+
+(let ((place nil))
+ (and (equal (pushnew 'a place) '(a))
+ (equal place '(a))))
+
+(let ((place nil))
+ (and (equal (pushnew 'a place) '(a))
+ (equal place '(a))))
+
+(let ((place '((a . 1) (b . 2))))
+ (and (equal (pushnew '(b . 2) place :test #'= :key #'cdr) '((a . 1) (b . 2)))
+ (equal place '((a . 1) (b . 2)))))
+
+(let ((place '((a . 1) (b . 2))))
+ (and (equal (pushnew '(b . 2) place :test-not (complement #'=) :key #'cdr)
+ '((a . 1) (b . 2)))
+ (equal place '((a . 1) (b . 2)))))
+
+(let ((place '((a . 1) (b . 2))))
+ (and (eq (pushnew '(z . 2) place :test #'= :key #'cdr) place)
+ (equal place '((a . 1) (b . 2)))))
+
+(let ((place '((a . 1) (b . 2))))
+ (and (eq (pushnew '(z . 2) place :test-not (complement #'=) :key #'cdr) place)
+ (equal place '((a . 1) (b . 2)))))
+
+(let ((place '("love" "peace")))
+ (equal (pushnew "war" place :test #'equal) '("war" "love" "peace")))
+
+(let ((place '("love" "peace")))
+ (equal (pushnew "war" place :test-not (complement #'equal))
+ '("war" "love" "peace")))
+
+(let ((place '("love" "peace")))
+ (and (eq (pushnew "peace" place :test #'equal) place)
+ (equal place '("love" "peace"))))
+
+(let ((place '("love" "peace")))
+ (and (eq (pushnew "peace" place :test-not (complement #'equal)) place)
+ (equal place '("love" "peace"))))
+
+(let ((place '(("love" . l) ("peace" . p))))
+ (equal (pushnew '("war" . w) place :test #'equal :key #'car)
+ '(("war" . w) ("love" . l) ("peace" . p))))
+
+(let ((place '(("love" . l) ("peace" . p))))
+ (equal (pushnew '("war" . w) place :test-not (complement #'equal) :key #'car)
+ '(("war" . w) ("love" . l) ("peace" . p))))
+
+(let ((place '(("love" . l) ("peace" . p))))
+ (and (eq (pushnew '("love" . l) place :test #'equal :key #'car) place)
+ (equal place '(("love" . l) ("peace" . p)))))
+
+(let ((place '(("love" . l) ("peace" . p))))
+ (and (eq (pushnew '("love" . l) place
+ :test-not (complement #'equal) :key #'car) place)
+ (equal place '(("love" . l) ("peace" . p)))))
+
+(let ((place '(("love" . l) ("peace" . p))))
+ (and (eq (pushnew '("LOVE" . L) place :test #'equalp :key #'car) place)
+ (equal place '(("love" . l) ("peace" . p)))))
+
+(let ((place '(("love" . l) ("peace" . p))))
+ (and (eq (pushnew '("LOVE" . L) place
+ :test-not (complement #'equalp) :key #'car) place)
+ (equal place '(("love" . l) ("peace" . p)))))
+
+(let ((place '(("love" . l) ("peace" . p))))
+ (equal (pushnew '("LOVE" . L) place :test #'equal :key #'car)
+ '(("LOVE" . L) ("love" . l) ("peace" . p))))
+
+(let ((place '(("love" . l) ("peace" . p))))
+ (equal (pushnew '("LOVE" . L) place :test-not (complement #'equal) :key #'car)
+ '(("LOVE" . L) ("love" . l) ("peace" . p))))
+
+(let ((list '((1) (1 2) (1 2 3))))
+ (and (equal (pushnew '(1) list) '((1) (1) (1 2) (1 2 3)))
+ (equal list '((1) (1) (1 2) (1 2 3)))))
+
+
+(let* ((list '((1) (1 2) (1 2 3)))
+ (original list))
+ (and (equal (pushnew '(1) list :test #'equal) '((1) (1 2) (1 2 3)))
+ (eq list original)))
+
+(let* ((list '((1) (1 2) (1 2 3)))
+ (original list))
+ (and (equal (pushnew '(1) list :test #'equal :key nil) '((1) (1 2) (1 2 3)))
+ (eq list original)))
+
+(let ((list (copy-tree '(1 (2) 3 4))))
+ (and (equal (pushnew 4 (cadr list)) '(4 2))
+ (equal list '(1 (4 2) 3 4))))
+
+(let ((list (copy-tree '(1 (2) 3 4))))
+ (and (equal (pushnew 4 (cadr list) :key nil) '(4 2))
+ (equal list '(1 (4 2) 3 4))))
+
+
+(null (set-difference (set-difference '(1 2 3 4 5 6 7 8 9)
+ '(2 4 6 8))
+ '(1 3 5 7 9)))
+(null (nset-difference (set-difference (list 1 2 3 4 5 6 7 8 9)
+ '(2 4 6 8))
+ '(1 3 5 7 9)))
+
+(null (set-difference (set-difference '("1" "2" "3" "4" "5" "6" "7" "8" "9")
+ '("2" "4" "6" "8") :test #'equal)
+ '("1" "3" "5" "7" "9") :test-not (complement #'equal)))
+
+(null (set-difference (set-difference '("1" "2" "3" "4" "5" "6" "7" "8" "9")
+ '("2" "4" "6" "8") :test #'equal)
+ '("1" "3" "5" "7" "9") :test-not (complement #'equal)))
+
+(null (nset-difference (nset-difference
+ (list "1" "2" "3" "4" "5" "6" "7" "8" "9")
+ '("2" "4" "6" "8") :test #'equal)
+ '("1" "3" "5" "7" "9") :test-not (complement #'equal)))
+
+(null (set-difference (set-difference '(("love") ("hate") ("peace") ("war"))
+ '(("love") ("peace"))
+ :key #'car
+ :test #'equal)
+ '(("hate") ("war"))
+ :key #'car
+ :test-not (complement #'equal)))
+
+(null (nset-difference (nset-difference
+ (list '("love") '("hate") '("peace") '("war"))
+ '(("love") ("peace"))
+ :key #'car
+ :test #'equal)
+ '(("hate") ("war"))
+ :key #'car
+ :test-not (complement #'equal)))
+
+
+(null (set-difference '() '()))
+(null (set-difference '() '() :test #'equal :key 'identity))
+(null (nset-difference '() '()))
+(null (set-difference '() '(1 2 3)))
+(null (set-difference '() '(1 2 3) :test #'equal :key 'identity))
+(null (nset-difference '() '(1 2 3)))
+
+(null (set-difference '(1 2 3 4) '(4 3 2 1)))
+(null (nset-difference (list 1 2 3 4) '(4 3 2 1)))
+(null (set-difference '(1 2 3 4) '(2 4 3 1)))
+(null (nset-difference (list 1 2 3 4) '(2 4 3 1)))
+(null (set-difference '(1 2 3 4) '(1 3 4 2)))
+(null (nset-difference (list 1 2 3 4) '(1 3 4 2)))
+(null (set-difference '(1 2 3 4) '(1 3 2 4)))
+(null (nset-difference (list 1 2 3 4) '(1 3 2 4)))
+
+
+(eq (set-difference (set-difference '(1 2 3) '())
+ '(1 2 3))
+ '())
+(eq (nset-difference (nset-difference (list 1 2 3) '())
+ '(1 2 3))
+ '())
+
+(eq (set-difference (set-difference '(1 2 3) '(1))
+ '(2 3))
+ '())
+(eq (nset-difference (nset-difference (list 1 2 3) '(1))
+ '(2 3))
+ '())
+
+(eq (set-difference (set-difference '(1 2 3) '(1 2))
+ '(3))
+ '())
+(eq (nset-difference (nset-difference (list 1 2 3) '(1 2))
+ '(3))
+ '())
+
+
+(null (set-exclusive-or (set-exclusive-or '(1 2 3) '(2 3 4))
+ '(1 4)))
+(null (nset-exclusive-or (nset-exclusive-or (list 1 2 3) '(2 3 4))
+ '(1 4)))
+(null (set-exclusive-or (set-exclusive-or '(1 2 3) '(1 3))
+ '(2)))
+(null (nset-exclusive-or (nset-exclusive-or (list 1 2 3) '(1 3))
+ '(2)))
+(null (set-exclusive-or '() '()))
+(null (nset-exclusive-or '() '()))
+(null (set-exclusive-or '(1 2 3) '(3 2 1)))
+(null (nset-exclusive-or (list 1 2 3) '(3 2 1)))
+(null (set-exclusive-or '(1 2 3) '(2 3 1)))
+(null (nset-exclusive-or (list 1 2 3) '(2 3 1)))
+(null (set-exclusive-or '(1 2 3) '(1 3 2)))
+(null (nset-exclusive-or (list 1 2 3) '(1 3 2)))
+
+(null (set-exclusive-or (set-exclusive-or '(1 2 3) '())
+ '(3 2 1)))
+(null (nset-exclusive-or (nset-exclusive-or (list 1 2 3) '())
+ '(3 2 1)))
+(null (set-exclusive-or (set-exclusive-or '() '(1 2 3))
+ '(2 1 3)))
+(null (nset-exclusive-or (nset-exclusive-or '() '(1 2 3))
+ '(2 1 3)))
+
+(null (set-exclusive-or '("car" "ship" "airplane" "submarine")
+ '("car" "ship" "airplane" "submarine")
+ :test #'equal))
+(null (nset-exclusive-or (copy-list '("car" "ship" "airplane" "submarine"))
+ '("car" "ship" "airplane" "submarine")
+ :test #'equal))
+
+(null (set-exclusive-or '("car" "ship" "airplane" "submarine")
+ '("CAR" "SHIP" "AIRPLANE" "SUBMARINE")
+ :test #'equalp))
+(null (nset-exclusive-or (copy-list '("car" "ship" "airplane" "submarine"))
+ '("CAR" "SHIP" "AIRPLANE" "SUBMARINE")
+ :test #'equalp))
+
+(null (set-exclusive-or '("car" "ship" "airplane" "submarine")
+ '("ship" "airplane" "submarine" "car")
+ :test-not (complement #'equal)))
+(null (nset-exclusive-or (copy-list '("car" "ship" "airplane" "submarine"))
+ '("ship" "airplane" "submarine" "car")
+ :test-not (complement #'equal)))
+
+(null (set-exclusive-or '(("car") ("ship") ("airplane") ("submarine"))
+ '(("car") ("ship") ("airplane") ("submarine"))
+ :test #'string=
+ :key #'car))
+(null (nset-exclusive-or (copy-tree
+ '(("car") ("ship") ("airplane") ("submarine")))
+ '(("car") ("ship") ("airplane") ("submarine"))
+ :test #'string=
+ :key #'car))
+
+(null (set-exclusive-or '(("car") ("ship") ("airplane") ("submarine"))
+ '(("car") ("ship") ("airplane") ("submarine"))
+ :test-not (complement #'string=)
+ :key #'car))
+(null (nset-exclusive-or (copy-tree
+ '(("car") ("ship") ("airplane") ("submarine")))
+ '(("car") ("ship") ("airplane") ("submarine"))
+ :test-not (complement #'string=)
+ :key #'car))
+
+(null (set-exclusive-or
+ (set-exclusive-or '("car" "ship" "airplane" "submarine")
+ '("car" "ship" "horse" "airplane" "submarine" "camel")
+ :test #'equal)
+ '("camel" "horse")
+ :test-not (complement #'equal)))
+
+(null (nset-exclusive-or
+ (nset-exclusive-or (list "car" "ship" "airplane" "submarine")
+ '("car" "ship" "horse" "airplane" "submarine" "camel")
+ :test #'equal)
+ '("camel" "horse")
+ :test-not (complement #'equal)))
+
+
+(subsetp '(1 2 3) '(1 2 3))
+(subsetp '(1 2 3) '(3 2 1))
+(subsetp '(1 2 3) '(2 1 3))
+
+(null (subsetp '(1 2 3 4) '(2 1 3)))
+(subsetp '(1) '(2 1 3))
+(subsetp '(1 2) '(1 2 3 4 5 6 7 8))
+(subsetp '(1 2 3 4 5) '(8 7 6 5 4 3 2 1))
+(null (subsetp '("car" "ship" "airplane" "submarine")
+ '("car" "ship" "horse" "airplane" "submarine" "camel")))
+
+(subsetp '("car" "ship" "airplane" "submarine")
+ '("car" "ship" "horse" "airplane" "submarine" "camel")
+ :test #'equal)
+
+(subsetp '("CAR" "SHIP" "AIRPLANE" "SUBMARINE")
+ '("car" "ship" "horse" "airplane" "submarine" "camel")
+ :test #'equalp)
+
+(subsetp '(("car") ("ship") ("airplane") ("submarine"))
+ '(("car") ("ship") ("horse") ("airplane") ("submarine") ("camel"))
+ :test #'string=
+ :key #'car)
+
+
+(null (union '() '()))
+(null (nunion '() '()))
+(null (set-difference (union '(1 2 3) '(2 3 4))
+ '(1 2 3 4)))
+(null (set-difference (nunion (list 1 2 3) (list 2 3 4))
+ '(1 2 3 4)))
+
+(null (set-difference (union '(1 2 3) '(1 2 3))
+ '(1 2 3)))
+(null (set-difference (nunion (list 1 2 3) (list 1 2 3))
+ '(1 2 3)))
+
+(null (set-difference (union '(1) '(3 2 1))
+ '(1 2 3)))
+(null (set-difference (nunion (list 1) (list 3 2 1))
+ '(1 2 3)))
+
+(null (set-difference (union '(1 2 3) '())
+ '(1 2 3)))
+(null (set-difference (nunion (list 1 2 3) '())
+ '(1 2 3)))
+
+(null (set-difference (union '() '(1 2 3))
+ '(1 2 3)))
+(null (set-difference (nunion '() (list 1 2 3))
+ '(1 2 3)))
+
+(null (set-difference (union '(1 2 3) '(2))
+ '(1 2 3)))
+(null (set-difference (nunion (list 1 2 3) (list 2))
+ '(1 2 3)))
+
+
+(null (set-difference (union '("Alpha" "Bravo" "Charlie")
+ '("Bravo" "Charlie" "Delta" "Echo")
+ :test #'string=)
+ '("Alpha" "Bravo" "Charlie" "Delta" "Echo")
+ :test-not (complement #'string=)))
+
+(null (set-difference (nunion (list "Alpha" "Bravo" "Charlie")
+ (list "Bravo" "Charlie" "Delta" "Echo")
+ :test #'string=)
+ '("Alpha" "Bravo" "Charlie" "Delta" "Echo")
+ :test-not (complement #'string=)))
+
+(null (set-difference
+ (union (copy-tree '(("Alpha") ("Bravo") ("Charlie")))
+ (copy-tree '(("Bravo") ("Charlie") ("Delta") ("Echo")))
+ :test #'string=
+ :key #'car)
+ '(("Alpha") ("Bravo") ("Charlie") ("Delta") ("Echo"))
+ :test-not (complement #'string=)
+ :key #'car))
+
+(null (set-difference
+ (nunion (copy-tree '(("Alpha") ("Bravo") ("Charlie")))
+ (copy-tree '(("Bravo") ("Charlie") ("Delta") ("Echo")))
+ :test #'string=
+ :key #'car)
+ '(("Alpha") ("Bravo") ("Charlie") ("Delta") ("Echo"))
+ :test-not (complement #'string=)
+ :key #'car))
+
+
+(null (set-difference (union '("Alpha" "Bravo" "Charlie")
+ '("BRAVO" "CHARLIE" "DELTA" "ECHO")
+ :test #'string-equal)
+ '("ALPHA" "BRAVO" "CHARLIE" "DELTA" "ECHO")
+ :test-not (complement #'string-equal)))
+
diff --git a/Sacla/tests/must-data-and-control.lisp b/Sacla/tests/must-data-and-control.lisp
new file mode 100644
index 0000000..0b0fb96
--- /dev/null
+++ b/Sacla/tests/must-data-and-control.lisp
@@ -0,0 +1,1660 @@
+;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
+;; ALL RIGHTS RESERVED.
+;;
+;; $Id: must-data-and-control.lisp,v 1.15 2004/02/20 07:23:42 yuji Exp $
+;;
+;; 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.
+;;
+;; 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.
+
+(let (a b c)
+ (and (null (psetq a 1 b 2 c 3))
+ (eql a 1)
+ (eql b 2)
+ (eql c 3)))
+
+(let ((a 1)
+ (b 2)
+ (c 3))
+ (and (null (psetq a (1+ b) b (1+ a) c (+ a b)))
+ (eql a 3)
+ (eql b 2)
+ (eql c 3)))
+
+(let ((x (list 10 20 30)))
+ (symbol-macrolet ((y (car x)) (z (cadr x)))
+ (psetq y (1+ z) z (1+ y))
+ (equal (list x y z) '((21 11 30) 21 11))))
+
+(let ((a 1) (b 2))
+ (and (null (psetq a b b a))
+ (eql a 2)
+ (eql b 1)))
+
+
+(null (psetq))
+(let ((a nil))
+ (and (null (psetq a t))
+ (eq a t)))
+(let ((a 0)
+ (b 1))
+ (and (null (psetq a b
+ b a))
+ (eq a 1)
+ (eq b 0)))
+
+(let ((a 0)
+ (b 1)
+ (c 2))
+ (and (null (psetq a b
+ b c
+ c a))
+ (eq a 1)
+ (eq b 2)
+ (eq c 0)))
+
+(let ((a 0)
+ (b 1)
+ (c 2)
+ (d 3))
+ (and (null (psetq a b
+ b c
+ c d
+ d a))
+ (eq a 1)
+ (eq b 2)
+ (eq c 3)
+ (eq d 0)))
+
+
+
+(null (block nil (return) 1))
+(eql (block nil (return 1) 2) 1)
+(equal (multiple-value-list (block nil (return (values 1 2)) 3)) '(1 2))
+(eql (block nil (block alpha (return 1) 2)) 1)
+(eql (block alpha (block nil (return 1)) 2) 2)
+(eql (block nil (block nil (return 1) 2)) 1)
+
+(eq (dotimes (i 10 nil)
+ (return t))
+ t)
+
+(eq (dolist (elt (list 0 1 2 3) nil)
+ (when (numberp elt)
+ (return t)))
+ t)
+
+(not nil)
+(not '())
+(not (integerp 'sss))
+(null (not (integerp 1)))
+(null (not 3.7))
+(null (not 'apple))
+
+(not nil)
+(null (not t))
+(not (cdr '(a)))
+
+
+(equal 'a 'a)
+(not (equal 'a 'b))
+(equal 'abc 'abc)
+(equal 1 1)
+(equal 2 2)
+(equal 0.1 0.1)
+(equal 1/3 1/3)
+(not (equal 0 1))
+(not (equal 1 1.0))
+(not (equal 1/3 1/4))
+(equal #\a #\a)
+(equal #\b #\b)
+(not (equal #\b #\B))
+(not (equal #\C #\c))
+(equal '(0) '(0))
+(equal '(0 #\a) '(0 #\a))
+(equal '(0 #\a x) '(0 #\a x))
+(equal '(0 #\a x (0)) '(0 #\a x (0)))
+(equal '(0 #\a x (0 (#\a (x "abc" #*0101))))
+ '(0 #\a x (0 (#\a (x "abc" #*0101)))))
+(not (equal (make-array '(2 2) :initial-contents '((a b) (c d)))
+ (make-array '(2 2) :initial-contents '((a b) (c d)))))
+(let ((array (make-array '(2 2) :initial-contents '((a b) (c d)))))
+ (equal array array))
+
+
+(eql (identity 101) 101)
+(equal (mapcan #'identity (list (list 1 2 3) '(4 5 6))) '(1 2 3 4 5 6))
+(eq (identity 'x) 'x)
+
+
+
+(funcall (complement #'zerop) 1)
+(not (funcall (complement #'characterp) #\A))
+(not (funcall (complement #'member) 'a '(a b c)))
+(funcall (complement #'member) 'd '(a b c))
+
+
+
+(equal (mapcar (constantly 3) '(a b c d)) '(3 3 3 3))
+(let ((const-func (constantly 'xyz)))
+ (every #'(lambda (arg) (eq arg 'xyz))
+ (list (funcall const-func)
+ (funcall const-func 'a)
+ (funcall const-func 'a 'b)
+ (funcall const-func 'a 'b 'c)
+ (funcall const-func 'a 'b 'c 'd))))
+
+
+
+(let ((temp1 1)
+ (temp2 1)
+ (temp3 1))
+ (and (eql (and (incf temp1) (incf temp2) (incf temp3)) 2)
+ (and (eql 2 temp1) (eql 2 temp2) (eql 2 temp3))
+ (eql (decf temp3) 1)
+ (null (and (decf temp1) (decf temp2) (eq temp3 'nil) (decf temp3)))
+ (and (eql temp1 temp2) (eql temp2 temp3))
+ (and)))
+
+(eq (and) t)
+(equal (multiple-value-list (and 't 't 't (values 'a 'b 'c)))
+ '(a b c))
+(null (and 't 't (cdr '(a)) (error "error")))
+
+
+
+(let ((temp0 nil)
+ (temp1 10)
+ (temp2 20)
+ (temp3 30))
+ (and (eql (or temp0 temp1 (setq temp2 37)) 10)
+ (eql temp2 20)
+ (eql (or (incf temp1) (incf temp2) (incf temp3)) 11)
+ (eql temp1 11)
+ (eql temp2 20)
+ (eql temp3 30)
+ (equal (multiple-value-list (or (values) temp1)) '(11))
+ (equal (multiple-value-list (or (values temp1 temp2) temp3)) '(11))
+ (equal (multiple-value-list (or temp0 (values temp1 temp2))) '(11 20))
+ (equal (multiple-value-list (or (values temp0 temp1)
+ (values temp2 temp3)))
+ '(20 30))))
+
+(zerop (or '0 '1 '2))
+(let ((a 0))
+ (and (eql (or (incf a) (incf a) (incf a)) 1)
+ (eql a 1)))
+(equal (multiple-value-list (or (values) 1)) '(1))
+(equal (multiple-value-list (or (values 1 2) 3)) '(1))
+
+(null (or))
+(equal (multiple-value-list (or (values 0 1 2))) '(0 1 2))
+(equal (multiple-value-list (or nil (values 0 1 2))) '(0 1 2))
+(equal (multiple-value-list (or nil nil (values 0 1 2))) '(0 1 2))
+(equal (multiple-value-list (or nil nil nil (values 0 1 2))) '(0 1 2))
+
+
+(let ((a nil))
+ (flet ((select-options ()
+ (cond ((= a 1) (setq a 2))
+ ((= a 2) (setq a 3))
+ ((and (= a 3) (floor a 2)))
+ (t (floor a 3)))))
+ (and (eql (setq a 1) 1)
+ (eql (select-options) 2)
+ (eql a 2)
+ (eql (select-options) 3)
+ (eql a 3)
+ (eql (select-options) 1)
+ (setq a 5)
+ (equal (multiple-value-list (select-options)) '(1 2)))))
+
+(null (cond))
+(equal (multiple-value-list (cond ((values 1 2 3)))) '(1))
+(equal (multiple-value-list (cond (t (values 1 2 3)))) '(1 2 3))
+(equal (multiple-value-list (cond (t (values 1)
+ (values 1 2)
+ (values 1 2 3)))) '(1 2 3))
+(let ((a 0))
+ (and (eql (cond
+ ((incf a))
+ ((incf a))
+ ((incf a)))
+ 1)
+ (eql a 1)))
+
+(let ((a 0))
+ (and (eql (cond
+ ((incf a) (incf a) (incf a))
+ ((incf a) (incf a) (incf a))
+ ((incf a) (incf a) (incf a)))
+ 3)
+ (eql a 3)))
+
+
+
+(eq (when t 'hello) 'HELLO)
+(null (unless t 'hello))
+(null (when nil 'hello))
+(eq (unless nil 'hello) 'HELLO)
+(null (when t))
+(null (unless nil))
+(let ((x 3))
+ (equal (list (when (oddp x) (incf x) (list x))
+ (when (oddp x) (incf x) (list x))
+ (unless (oddp x) (incf x) (list x))
+ (unless (oddp x) (incf x) (list x))
+ (if (oddp x) (incf x) (list x))
+ (if (oddp x) (incf x) (list x))
+ (if (not (oddp x)) (incf x) (list x))
+ (if (not (oddp x)) (incf x) (list x)))
+ '((4) NIL (5) NIL 6 (6) 7 (7))))
+
+
+
+
+(equal (let ((list nil))
+ (dolist (k '(1 2 3 :four #\v () t 'other))
+ (push (case k
+ ((1 2) 'clause1)
+ (3 'clause2)
+ (nil 'no-keys-so-never-seen)
+ ((nil) 'nilslot)
+ ((:four #\v) 'clause4)
+ ((t) 'tslot)
+ (otherwise 'others))
+ list))
+ list)
+ '(OTHERS TSLOT NILSLOT CLAUSE4 CLAUSE4 CLAUSE2 CLAUSE1 CLAUSE1))
+
+
+(macro-function 'case)
+(macro-function 'ccase)
+(macro-function 'ecase)
+
+(eql (case 'a
+ ((a b c) 0)
+ (x 1)
+ (y 2)
+ (z 3))
+ 0)
+
+(eql (case 'j
+ ((a b c) 0)
+ (x 1)
+ (y 2)
+ (z 3)
+ (t 9))
+ 9)
+
+(eql (case 'j
+ ((a b c) 0)
+ (x 1)
+ (y 2)
+ (z 3)
+ (otherwise 9))
+ 9)
+
+(eql (case 'j
+ ((a b c) 0)
+ (x 1)
+ (y 2)
+ (z 3))
+ nil)
+
+(null (case 'x))
+
+(let ((x #\a))
+ (equal (case x
+ ((#\x #\y #\z) "xyz")
+ (#\a "a")
+ (t "-"))
+ "a"))
+
+(let ((x #\A))
+ (equal (case x
+ ((#\x #\y #\z) "xyz")
+ (#\a "a")
+ (t "-"))
+ "-"))
+
+(let ((x t))
+ (eql (case x
+ ((t) 0)
+ (t 1))
+ 0))
+
+(let ((x nil))
+ (eql (case x
+ ((t) 0)
+ (t 1))
+ 1))
+
+(let ((x 'a))
+ (eql (case x
+ ((t) 0))
+ nil))
+
+(let ((x 'otherwise))
+ (eql (case x
+ ((otherwise) 0)
+ (otherwise 1))
+ 0))
+
+(let ((x nil))
+ (eql (case x
+ ((otherwise) 0)
+ (otherwise 1))
+ 1))
+
+(let ((x 'a))
+ (eql (case x
+ ((otherwise) 0))
+ nil))
+
+
+(let ((x 'a))
+ (and (eql (case x
+ ((a b c) (setq x 0) 'a)
+ ((x y z) (setq x 1) 'x))
+ 'a)
+ (eql x 0)))
+
+(let ((x 'x))
+ (and (eql (case x
+ ((a b c) (setq x 0) 'a)
+ ((x y z) (setq x 1) 'x))
+ 'x)
+ (eql x 1)))
+
+
+(equal (mapcar #'(lambda (x) (case x (a 0) (b 1) (c 2) (d 3) (e 4)))
+ '(a b c d e f))
+ '(0 1 2 3 4 nil))
+
+(case 'a (otherwise t))
+
+(eql (case 'a (otherwise 10)) 10)
+
+(let ((a 0)
+ (b 1))
+ (and (eq (case (progn (incf a) (incf b))
+ (0 'a)
+ (1 'b)
+ (2 'c))
+ 'c)
+ (eql a 1)
+ (eql b 2)))
+
+(let ((a 0)
+ (b 1))
+ (and (eq (case (progn (incf a) (incf b))
+ (0 'a)
+ (1 'b)
+ (2 (incf a) (incf b) 'c))
+ 'c)
+ (eql a 2)
+ (eql b 3)))
+
+(let ((a (list 0 1 2 3)))
+ (eq (case (caddr a)
+ (0 'x)
+ (1 'y)
+ (2 'z)
+ (3 t))
+ 'z))
+
+
+(equal (multiple-value-list (case 2
+ (0 (values 0 'x))
+ (1 (values 1 'y))
+ (2 (values 2 'z))
+ (3 (values 3 't))))
+ '(2 z))
+
+
+
+(let ((a 'c))
+ (eql (ccase a
+ ((a b c) 0)
+ (x 1)
+ (y 2)
+ (z 3))
+ 0))
+
+(HANDLER-CASE
+ (PROGN
+ (LET ((A 'J))
+ (CCASE A ((A B C) 0) (X 1) (Y 2) (Z 3))))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE
+ (PROGN
+ (LET ((A NIL))
+ (CCASE A)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE
+ (PROGN
+ (LET ((A #\a))
+ (CCASE A ((#\A #\B #\C) 0) ((#\X #\Y #\Z) 1))))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(let ((a (list 0 1 2 3)))
+ (eq (ccase (caddr a)
+ (0 'x)
+ (1 'y)
+ (2 'z)
+ (3 t))
+ 'z))
+
+(let ((x #\a))
+ (equal (ccase x
+ ((#\x #\y #\z) "xyz")
+ (#\a "a"))
+ "a"))
+
+(let ((x 'a))
+ (and (eql (ccase x
+ ((a b c) (setq x 0) 'a)
+ ((x y z) (setq x 1) 'x))
+ 'a)
+ (eql x 0)))
+
+(let ((x 'x))
+ (and (eql (ccase x
+ ((a b c) (setq x 0) 'a)
+ ((x y z) (setq x 1) 'x))
+ 'x)
+ (eql x 1)))
+
+(equal (mapcar #'(lambda (x) (ccase x (a 0) (b 1) (c 2) (d 3) (e 4)))
+ '(a b c d e))
+ '(0 1 2 3 4))
+
+
+(equal (multiple-value-list (let ((a 2))
+ (ccase a
+ (0 (values 0 'x))
+ (1 (values 1 'y))
+ (2 (values 2 'z))
+ (3 (values 3 't)))))
+ '(2 z))
+
+(let ((a 'c))
+ (eql (ecase a
+ ((a b c) 0)
+ (x 1)
+ (y 2)
+ (z 3))
+ 0))
+
+(HANDLER-CASE
+ (PROGN
+ (LET ((A 'J))
+ (ECASE A ((A B C) 0) (X 1) (Y 2) (Z 3))))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE
+ (PROGN
+ (LET ((A NIL))
+ (ECASE A)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE
+ (PROGN
+ (LET ((A #\a))
+ (ECASE A ((#\A #\B #\C) 0) ((#\X #\Y #\Z) 1))))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(let ((a (list 0 1 2 3)))
+ (eq (ecase (caddr a)
+ (0 'x)
+ (1 'y)
+ (2 'z)
+ (3 t))
+ 'z))
+
+(let ((x #\a))
+ (equal (ecase x
+ ((#\x #\y #\z) "xyz")
+ (#\a "a"))
+ "a"))
+
+(let ((x 'a))
+ (and (eql (ecase x
+ ((a b c) (setq x 0) 'a)
+ ((x y z) (setq x 1) 'x))
+ 'a)
+ (eql x 0)))
+
+(let ((x 'x))
+ (and (eql (ecase x
+ ((a b c) (setq x 0) 'a)
+ ((x y z) (setq x 1) 'x))
+ 'x)
+ (eql x 1)))
+
+(equal (mapcar #'(lambda (x) (ecase x (a 0) (b 1) (c 2) (d 3) (e 4)))
+ '(a b c d e))
+ '(0 1 2 3 4))
+
+(equal (multiple-value-list (let ((a 2))
+ (ecase a
+ (0 (values 0 'x))
+ (1 (values 1 'y))
+ (2 (values 2 'z))
+ (3 (values 3 't)))))
+ '(2 z))
+
+
+(let ((x 'a))
+ (equal (typecase x
+ (cons "cons")
+ (symbol "symbol")
+ (number "number")
+ (otherwise "unknown"))
+ "symbol"))
+
+(let ((x (list 'a)))
+ (equal (typecase x
+ (cons "cons")
+ (symbol "symbol")
+ (number "number")
+ (otherwise "unknown"))
+ "cons"))
+
+(let ((x 0))
+ (equal (typecase x
+ (cons "cons")
+ (symbol "symbol")
+ (number "number")
+ (otherwise "unknown"))
+ "number"))
+
+(let ((x (make-array '(3 3))))
+ (equal (typecase x
+ (cons "cons")
+ (symbol "symbol")
+ (number "number")
+ (otherwise "unknown"))
+ "unknown"))
+
+
+(null (typecase 'a))
+(typecase 'a (otherwise t))
+(typecase 'a (t t))
+
+(let ((x (make-array '(3 3))))
+ (equal (typecase x
+ (cons "cons")
+ (symbol "symbol")
+ (number "number"))
+ nil))
+
+(let ((x ""))
+ (equal (typecase x
+ (t "anything")
+ (otherwise nil))
+ "anything"))
+
+(let ((x ""))
+ (and (eql (typecase x
+ (string (setq x 'string) 0)
+ (cons (setq x 'cons) 1)
+ (array (setq x 'array) 2)
+ (t (setq x 't) 9))
+ 0)
+ (eq x 'string)))
+
+(let ((x (list nil)))
+ (and (eql (typecase x
+ (string (setq x 'string) 0)
+ (cons (setq x 'cons) 1)
+ (array (setq x 'array) 2)
+ (t (setq x 't) 9))
+ 1)
+ (eq x 'cons)))
+
+
+(let ((x #*01))
+ (and (eql (typecase x
+ (string (setq x 'string) 0)
+ (cons (setq x 'cons) 1)
+ (array (setq x 'array) 2)
+ (t (setq x 't) 9))
+ 2)
+ (eq x 'array)))
+
+(let ((x #\a))
+ (and (eql (typecase x
+ (string (setq x 'string) 0)
+ (cons (setq x 'cons) 1)
+ (array (setq x 'array) 2)
+ (t (setq x 't) 9))
+ 9)
+ (eq x 't)))
+
+(let ((x #*01))
+ (and (equal (multiple-value-list (typecase x
+ (string (setq x 'string) (values 'string 0))
+ (cons (setq x 'cons) (values 'cons 1))
+ (array (setq x 'array) (values 'array 2))
+ (t (setq x 't) (values 't 9))))
+ '(array 2))
+ (eq x 'array)))
+
+
+(let ((x 'a))
+ (equal (ctypecase x
+ (cons "cons")
+ (symbol "symbol")
+ (number "number"))
+ "symbol"))
+
+(let ((x (list 'a)))
+ (equal (ctypecase x
+ (cons "cons")
+ (symbol "symbol")
+ (number "number"))
+ "cons"))
+
+(let ((x 0))
+ (equal (ctypecase x
+ (cons "cons")
+ (symbol "symbol")
+ (number "number"))
+ "number"))
+
+(HANDLER-CASE
+ (LET ((X (MAKE-ARRAY '(3 3))))
+ (CTYPECASE X
+ (CONS "cons")
+ (SYMBOL "symbol")
+ (NUMBER "number")))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+
+(HANDLER-CASE
+ (LET ((A NIL)) (CTYPECASE A))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+;; (let ((x ""))
+;; (equal (ctypecase x (t "anything"))
+;; "anything"))
+
+(let ((x ""))
+ (and (eql (ctypecase x
+ (string (setq x 'string) 0)
+ (cons (setq x 'cons) 1)
+ (array (setq x 'array) 2))
+ 0)
+ (eq x 'string)))
+
+(let ((x (list nil)))
+ (and (eql (ctypecase x
+ (string (setq x 'string) 0)
+ (cons (setq x 'cons) 1)
+ (array (setq x 'array) 2))
+ 1)
+ (eq x 'cons)))
+
+
+(let ((x #*01))
+ (and (eql (ctypecase x
+ (string (setq x 'string) 0)
+ (cons (setq x 'cons) 1)
+ (array (setq x 'array) 2))
+ 2)
+ (eq x 'array)))
+
+;; (let ((x #\a))
+;; (and (eql (ctypecase x
+;; (string (setq x 'string) 0)
+;; (cons (setq x 'cons) 1)
+;; (array (setq x 'array) 2)
+;; (t (setq x 't) 9))
+;; 9)
+;; (eq x 't)))
+
+(HANDLER-CASE
+ (LET ((X #\a))
+ (CTYPECASE X
+ (STRING (SETQ X 'STRING) 0)
+ (CONS (SETQ X 'CONS) 1)
+ (ARRAY (SETQ X 'ARRAY) 2)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(let ((x #*01))
+ (and (equal (multiple-value-list (ctypecase x
+ (string (setq x 'string) (values 'string 0))
+ (cons (setq x 'cons) (values 'cons 1))
+ (array (setq x 'array) (values 'array 2))))
+ '(array 2))
+ (eq x 'array)))
+
+
+(let ((x 'a))
+ (equal (etypecase x
+ (cons "cons")
+ (symbol "symbol")
+ (number "number"))
+ "symbol"))
+
+(let ((x (list 'a)))
+ (equal (etypecase x
+ (cons "cons")
+ (symbol "symbol")
+ (number "number"))
+ "cons"))
+
+(let ((x 0))
+ (equal (etypecase x
+ (cons "cons")
+ (symbol "symbol")
+ (number "number"))
+ "number"))
+
+(HANDLER-CASE
+ (PROGN
+ (LET ((X (MAKE-ARRAY '(3 3))))
+ (ETYPECASE X (CONS "cons") (SYMBOL "symbol") (NUMBER "number"))))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+
+(HANDLER-CASE
+ (PROGN
+ (LET ((A NIL))
+ (ETYPECASE A)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+;; (let ((x ""))
+;; (equal (etypecase x
+;; (t "anything"))
+;; "anything"))
+
+(let ((x ""))
+ (and (eql (etypecase x
+ (string (setq x 'string) 0)
+ (cons (setq x 'cons) 1)
+ (array (setq x 'array) 2))
+ 0)
+ (eq x 'string)))
+
+(let ((x (list nil)))
+ (and (eql (etypecase x
+ (string (setq x 'string) 0)
+ (cons (setq x 'cons) 1)
+ (array (setq x 'array) 2))
+ 1)
+ (eq x 'cons)))
+
+
+(let ((x #*01))
+ (and (eql (etypecase x
+ (string (setq x 'string) 0)
+ (cons (setq x 'cons) 1)
+ (array (setq x 'array) 2))
+ 2)
+ (eq x 'array)))
+
+;; (let ((x #\a))
+;; (and (eql (etypecase x
+;; (string (setq x 'string) 0)
+;; (cons (setq x 'cons) 1)
+;; (array (setq x 'array) 2)
+;; (t (setq x 't) 9))
+;; 9)
+;; (eq x 't)))
+
+(HANDLER-CASE
+ (PROGN
+ (LET ((X #\a))
+ (ETYPECASE X
+ (STRING (SETQ X 'STRING) 0)
+ (CONS (SETQ X 'CONS) 1)
+ (ARRAY (SETQ X 'ARRAY) 2))))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(let ((x #*01))
+ (and (equal (multiple-value-list (etypecase x
+ (string (setq x 'string) (values 'string 0))
+ (cons (setq x 'cons) (values 'cons 1))
+ (array (setq x 'array) (values 'array 2))))
+ '(array 2))
+ (eq x 'array)))
+
+
+(macro-function 'multiple-value-bind)
+(equal (multiple-value-bind (f r)
+ (floor 130 11)
+ (list f r))
+ '(11 9))
+
+(multiple-value-bind (a b c d)
+ (values 0 1 2 3 4 5)
+ (and (eql a 0)
+ (eql b 1)
+ (eql c 2)
+ (eql d 3)))
+
+(multiple-value-bind (a b c d)
+ (values 0 1)
+ (and (eql a 0)
+ (eql b 1)
+ (eql c nil)
+ (eql d nil)))
+
+(equal (multiple-value-list (multiple-value-bind (a b)
+ (values 0 1)
+ (values a b 2 3)))
+ '(0 1 2 3))
+
+(multiple-value-bind ()
+ (values 0 1 2)
+ t)
+
+(null (multiple-value-bind () nil))
+
+(eql (multiple-value-bind (a)
+ (floor 130 11)
+ (+ a 10))
+ 21)
+
+(eql (multiple-value-bind (a)
+ (floor 130 11)
+ (+ a 10)
+ (incf a 100)
+ (+ a 10))
+ 121)
+
+
+
+(equal (multiple-value-call #'list 1 '/ (values 2 3) '/ (values) '/ (floor 2.5))
+ '(1 / 2 3 / / 2 0.5))
+(eql (+ (floor 5 3) (floor 19 4)) (+ 1 4))
+(eql (multiple-value-call #'+ (floor 5 3) (floor 19 4)) (+ 1 2 4 3))
+
+(let ((list nil))
+ (and (eql (multiple-value-call (progn (push 'function list) #'+)
+ (progn (push 0 list) 0)
+ (progn (push 1 list) (values 1 2))
+ (progn (push 2 list) (values 3 4 5))
+ (progn (push 3 list) (values 6 7 8 9)))
+ 45)
+ (equal (reverse list) '(function 0 1 2 3))))
+
+(eql (multiple-value-call #'+ 0 1 2 3 4) 10)
+(eql (multiple-value-call #'+) 0)
+(equal (multiple-value-list
+ (multiple-value-call #'values
+ 0 1 (values 2) (values 3 4) (values 5 6 7)))
+ '(0 1 2 3 4 5 6 7))
+(special-operator-p 'multiple-value-call)
+
+
+
+(macro-function 'multiple-value-list)
+(equal (multiple-value-list (floor -3 4)) '(-1 1))
+(equal (multiple-value-list
+ (progn
+ (values 'a 'b)
+ 0))
+ '(0))
+(equal (multiple-value-list
+ (prog1
+ (values 'a 'b)
+ 0))
+ '(a))
+
+(equal (multiple-value-list
+ (multiple-value-prog1
+ (values 'a 'b)
+ 0))
+ '(a b))
+
+(special-operator-p 'multiple-value-prog1)
+(eql (multiple-value-prog1 1 2 3) 1)
+(eql (multiple-value-prog1 1 2 3) 1)
+
+
+(let ((temp '(1 2 3)))
+ (multiple-value-bind (a b c)
+ (multiple-value-prog1
+ (values-list temp)
+ (setq temp nil)
+ (values-list temp))
+ (and (eql a 1)
+ (eql b 2)
+ (eql c 3))))
+
+
+(zerop (multiple-value-prog1 0
+ (values 0 1)
+ (values 0 1 2)))
+
+(equal (multiple-value-list (multiple-value-prog1 (progn 0
+ (values 0 1)
+ (values 0 1 2))))
+ '(0 1 2))
+
+
+(let (quotient remainder)
+ (and (eql (multiple-value-setq (quotient remainder) (truncate 3.2 2)) 1)
+ (eql quotient 1)
+ (eql remainder 1.2)))
+(let ((a 7)
+ (b 8)
+ (c 9))
+ (and (eql (multiple-value-setq (a b c) (values 1 2)) 1)
+ (eql a 1)
+ (eql b 2)
+ (eql c NIL)))
+
+(let ((a 0)
+ (b 1))
+ (and (eql (multiple-value-setq (a b) (values 4 5 6)) 4)
+ (eql a 4)
+ (eql b 5)))
+
+
+(null (multiple-value-list (values-list nil)))
+(equal (multiple-value-list (values-list '(1))) '(1))
+(equal (multiple-value-list (values-list '(1 2))) '(1 2))
+(equal (multiple-value-list (values-list '(1 2 3))) '(1 2 3))
+
+(every #'(lambda (list) (equal (multiple-value-list (values-list list)) list))
+ '()
+ '(a)
+ '(a b)
+ '(a b c)
+ '(a b c d)
+ '(a b c d e)
+ '(a b c d e f)
+ '(a b c d e f g)
+ '(a b c d e f g h))
+
+
+(macro-function 'nth-value)
+(eql (nth-value 0 (values 'a 'b)) 'A)
+(eql (nth-value 1 (values 'a 'b)) 'B)
+(null (nth-value 2 (values 'a 'b)))
+(multiple-value-bind (a b eq?)
+ (let* ((x 83927472397238947423879243432432432)
+ (y 32423489732)
+ (a (nth-value 1 (floor x y)))
+ (b (mod x y)))
+ (values a b (= a b)))
+ (and (eql a 3332987528)
+ (eql b 3332987528)
+ eq?))
+
+(null (nth-value 0 (values)))
+(eql (nth-value 0 1) 1)
+(null (nth-value 1 1))
+(eql (nth-value 0 (values 0 1 2)) 0)
+(eql (nth-value 1 (values 0 1 2)) 1)
+(eql (nth-value 2 (values 0 1 2)) 2)
+(eql (nth-value 3 (values 0 1 2)) nil)
+(eql (nth-value 4 (values 0 1 2)) nil)
+(eql (nth-value 5 (values 0 1 2)) nil)
+
+
+(let ((z (list 0 1 2 3)))
+ (eql (prog* ((y z)
+ (x (car y)))
+ (return x))
+ (car z)))
+
+
+(macro-function 'prog)
+(macro-function 'prog*)
+(let ((a 1))
+ (eq (prog ((a 2) (b a)) (return (if (= a b) '= '/=))) '/=))
+
+(eq (prog* ((a 2) (b a)) (return (if (= a b) '= '/=))) '=)
+(null (prog () 'no-return-value))
+
+(flet ((king-of-confusion (w)
+ "Take a cons of two lists and make a list of conses.
+Think of this function as being like a zipper."
+ (prog (x y z) ;Initialize x, y, z to NIL
+ (setq y (car w) z (cdr w))
+ loop
+ (cond ((null y) (return x))
+ ((null z) (go err)))
+ rejoin
+ (setq x (cons (cons (car y) (car z)) x))
+ (setq y (cdr y) z (cdr z))
+ (go loop)
+ err
+ (cerror "Will self-pair extraneous items"
+ "Mismatch - gleep! ~S" y)
+ (setq z y)
+ (go rejoin))))
+ (and (equal (king-of-confusion '((0 1 2) . (a b c)))
+ '((2 . C) (1 . B) (0 . A)))
+ (equal (king-of-confusion '((0 1 2 3 4 5) . (a b c d e f)))
+ '((5 . F) (4 . E) (3 . D) (2 . C) (1 . B) (0 . A)))))
+
+
+(null (prog () t))
+(null (prog ()))
+(eql (let ((a 0)
+ (b 0))
+ (prog ((a 10)
+ (b 100))
+ (return (+ a b))))
+ 110)
+
+(prog (a
+ (b 1)
+ (c 2))
+ (return (and (null a) (eql b 1) (eql c 2))))
+
+(prog ((a 0)
+ b
+ (c 2))
+ (return (and (eql a 0) (null b) (eql c 2))))
+
+(prog ((a 0)
+ (b 1)
+ c)
+ (return (and (eql a 0) (eql b 1) (null c))))
+
+(prog (a b c)
+ (return (every #'null (list a b c))))
+
+(eql (let ((a 0))
+ (declare (special a))
+ (flet ((ref-a () a))
+ (prog ((a 10))
+ (declare (special a))
+ (return (ref-a)))))
+ 10)
+
+(let ((a 0))
+ (declare (special a))
+ (and (eql (flet ((ref-a () a))
+ (prog ((a 10)
+ b
+ (c 100))
+ (declare (special a))
+ (setq b 1)
+ (return (+ (ref-a) b c))))
+ 111)
+ (eql a 0)))
+
+(let ((a 0))
+ (declare (special a))
+ (and (equal (multiple-value-list (flet ((ref-a () a))
+ (prog ((a 10)
+ b
+ (c 100))
+ (declare (special a))
+ (setq b 1)
+ (return (values (ref-a) b c)))))
+ '(10 1 100))
+ (eql a 0)))
+
+(let ((a 0))
+ (and (eql (prog () (return a)) 0)
+ (eql a 0)))
+
+
+(flet ((rev (list)
+ (prog ((x list)
+ (result nil))
+ top
+ (when (null x)
+ (return result))
+ (psetq x (cdr x)
+ result (cons (car x) result))
+ (go top))))
+ (and (equal (rev '(0 1 2 3))
+ '(3 2 1 0))
+ (equal (rev nil)
+ nil)
+ (equal (rev '(0))
+ '(0))))
+
+(eql (prog (val)
+ (setq val 1)
+ (go point-a)
+ (incf val 16)
+ point-c
+ (incf val 04)
+ (go point-b)
+ (incf val 32)
+ point-a
+ (incf val 02)
+ (go point-c)
+ (incf val 64)
+ point-b
+ (incf val 08)
+ (return val))
+ 15)
+
+(let ((a 0))
+ (and (equal (multiple-value-list (prog ((a 100)
+ (b a)
+ (c 1))
+ (return (values a b c))))
+ '(100 0 1))
+ (eql a 0)))
+
+
+(null (prog* () 'no-return-value))
+(flet ((king-of-confusion (w)
+ "Take a cons of two lists and make a list of conses.
+Think of this function as being like a zipper."
+ (prog* (x y z) ;Initialize x, y, z to NIL
+ (setq y (car w) z (cdr w))
+ loop
+ (cond ((null y) (return x))
+ ((null z) (go err)))
+ rejoin
+ (setq x (cons (cons (car y) (car z)) x))
+ (setq y (cdr y) z (cdr z))
+ (go loop)
+ err
+ (cerror "Will self-pair extraneous items"
+ "Mismatch - gleep! ~S" y)
+ (setq z y)
+ (go rejoin))))
+ (and (equal (king-of-confusion '((0 1 2) . (a b c)))
+ '((2 . C) (1 . B) (0 . A)))
+ (equal (king-of-confusion '((0 1 2 3 4 5) . (a b c d e f)))
+ '((5 . F) (4 . E) (3 . D) (2 . C) (1 . B) (0 . A)))))
+
+(null (prog* () t))
+(null (prog* ()))
+(eql (let ((a 0)
+ (b 0))
+ (prog* ((a 10)
+ (b 100))
+ (return (+ a b))))
+ 110)
+
+(prog* (a
+ (b 1)
+ (c 2))
+ (return (and (null a) (eql b 1) (eql c 2))))
+
+(prog* ((a 0)
+ b
+ (c 2))
+ (return (and (eql a 0) (null b) (eql c 2))))
+
+(prog* ((a 0)
+ (b 1)
+ c)
+ (return (and (eql a 0) (eql b 1) (null c))))
+
+(prog* (a b c)
+ (return (every #'null (list a b c))))
+
+(eql (let ((a 0))
+ (declare (special a))
+ (flet ((ref-a () a))
+ (prog* ((a 10))
+ (declare (special a))
+ (return (ref-a)))))
+ 10)
+
+(let ((a 0))
+ (declare (special a))
+ (and (eql (flet ((ref-a () a))
+ (prog* ((a 10)
+ b
+ (c 100))
+ (declare (special a))
+ (setq b 1)
+ (return (+ (ref-a) b c))))
+ 111)
+ (eql a 0)))
+
+(let ((a 0))
+ (declare (special a))
+ (and (equal (multiple-value-list (flet ((ref-a () a))
+ (prog* ((a 10)
+ b
+ (c 100))
+ (declare (special a))
+ (setq b 1)
+ (return (values (ref-a) b c)))))
+ '(10 1 100))
+ (eql a 0)))
+
+(let ((a 0))
+ (and (eql (prog* () (return a)) 0)
+ (eql a 0)))
+
+
+(flet ((rev (list)
+ (prog* ((x list)
+ (result nil))
+ top
+ (when (null x)
+ (return result))
+ (psetq x (cdr x)
+ result (cons (car x) result))
+ (go top))))
+ (and (equal (rev '(0 1 2 3))
+ '(3 2 1 0))
+ (equal (rev nil)
+ nil)
+ (equal (rev '(0))
+ '(0))))
+
+(eql (prog* (val)
+ (setq val 1)
+ (go point-a)
+ (incf val 16)
+ point-c
+ (incf val 04)
+ (go point-b)
+ (incf val 32)
+ point-a
+ (incf val 02)
+ (go point-c)
+ (incf val 64)
+ point-b
+ (incf val 08)
+ (return val))
+ 15)
+
+(let ((a 0))
+ (and (equal (multiple-value-list (prog* ((a 100)
+ (b a)
+ (c 1))
+ (return (values a b c))))
+ '(100 100 1))
+ (eql a 0)))
+
+
+
+(macro-function 'prog1)
+(macro-function 'prog2)
+
+(eql (let ((temp 1))
+ (prog1 temp (incf temp) temp))
+ 1)
+(let ((temp t))
+ (and (eq (prog1 temp (setq temp nil)) 't)
+ (null temp)))
+
+(equal (multiple-value-list (prog1 (values 1 2 3) 4)) '(1))
+
+(let ((temp (list 'a 'b 'c)))
+ (and (eq (prog1 (car temp) (setf (car temp) 'alpha)) 'a)
+ (equal temp '(ALPHA B C))))
+
+(equal (flet ((swap-symbol-values (x y)
+ (setf (symbol-value x)
+ (prog1 (symbol-value y)
+ (setf (symbol-value y) (symbol-value x))))))
+ (let ((*foo* 1) (*bar* 2))
+ (declare (special *foo* *bar*))
+ (swap-symbol-values '*foo* '*bar*)
+ (list *foo* *bar*)))
+ '(2 1))
+
+(let ((temp 1))
+ (and (eql (prog2 (incf temp) (incf temp) (incf temp)) 3)
+ (eql temp 4)))
+
+(equal (multiple-value-list (prog2 1 (values 2 3 4) 5)) '(2))
+(equal (multiple-value-list (prog2 1 (values 2 3 4) 5 (values 6 7))) '(2))
+
+(eql (prog1 1) 1)
+(eql (prog1 1 2) 1)
+(eql (prog1 1 2 3) 1)
+
+(equal (multiple-value-list (prog1 (values 1 2 3))) '(1))
+
+(equal (multiple-value-list (prog1
+ (values 1 2 3)
+ (values 4 5 6)
+ (values 7 8 9)))
+ '(1))
+
+(eql (prog2 1 2) 2)
+(eql (prog2 1 2 3) 2)
+(eql (prog2 1 2 3 4) 2)
+
+(let ((x 0))
+ (and (eql (prog2 (incf x)
+ (incf x)
+ (incf x)
+ (incf x))
+ 2)
+ (eql x 4)))
+
+
+
+(let ((x (cons 'a 'b))
+ (y (list 1 2 3)))
+ (and (equal (setf (car x) 'x (cadr y) (car x) (cdr x) y) '(1 X 3))
+ (equal x '(X 1 X 3))
+ (equal y '(1 X 3))))
+
+(let ((x (cons 'a 'b))
+ (y (list 1 2 3)))
+ (and (null (psetf (car x) 'x (cadr y) (car x) (cdr x) y))
+ (equal x '(X 1 A 3))
+ (equal y '(1 A 3))))
+
+(null (setf))
+(null (psetf))
+
+(let ((a 0))
+ (and (eql (setf a 10) 10)
+ (eql a 10)))
+
+(let ((a 0)
+ (b 1))
+ (and (eql (setf a 10 b 20) 20)
+ (eql a 10)
+ (eql b 20)))
+
+(let ((a 0)
+ (b 1)
+ (c 2))
+ (and (eql (setf a 10 b (+ a 10) c (+ b 10)) 30)
+ (eql a 10)
+ (eql b 20)
+ (eql c 30)))
+
+(let ((x (list 0 1 2)))
+ (and (eq (setf (car x) 'a) 'a)
+ (eq (setf (cadr x) 'b) 'b)
+ (eq (setf (caddr x) 'c) 'c)
+ (equal x '(a b c))))
+
+
+(let ((a 0))
+ (and (null (psetf a 10))
+ (eql a 10)))
+
+(let ((a 0)
+ (b 1))
+ (and (null (psetf a 10 b 20))
+ (eql a 10)
+ (eql b 20)))
+
+(let ((a 0)
+ (b 1)
+ (c 2))
+ (and (null (psetf a 10 b (+ a 10) c (+ b 10)))
+ (eql a 10)
+ (eql b 10)
+ (eql c 11)))
+
+(let ((x (list 0 1 2)))
+ (and (null (psetf (car x) 'a))
+ (null (psetf (cadr x) 'b))
+ (null (psetf (caddr x) 'c))
+ (equal x '(a b c))))
+
+
+(let ((x (make-array '(2 3) :initial-contents '((a b c) (x y z)))))
+ (and (eql (setf (aref x 0 0) 0.0) 0.0)
+ (eql (setf (aref x 0 1) 0.1) 0.1)
+ (eql (setf (aref x 0 2) 0.2) 0.2)
+ (eql (setf (aref x 1 0) 1.0) 1.0)
+ (eql (setf (aref x 1 1) 1.1) 1.1)
+ (eql (setf (aref x 1 2) 1.2) 1.2)
+ (equalp x #2A((0.0 0.1 0.2) (1.0 1.1 1.2)))))
+
+(let ((x (make-array 4 :element-type 'bit :initial-element 0)))
+ (and (equalp x #*0000)
+ (eql (setf (bit x 0) 1) 1)
+ (eql (setf (bit x 2) 1) 1)
+ (equal x #*1010)))
+
+(let ((x (copy-seq "dog")))
+ (and (eql (setf (char x 0) #\c) #\c)
+ (eql (setf (char x 1) #\a) #\a)
+ (eql (setf (char x 2) #\t) #\t)
+ (equal x "cat")))
+
+(let ((x (copy-seq "dog")))
+ (and (eql (setf (schar x 0) #\c) #\c)
+ (eql (setf (schar x 1) #\a) #\a)
+ (eql (setf (schar x 2) #\t) #\t)
+ (equal x "cat")))
+
+(let ((x (copy-seq "dog")))
+ (and (eql (setf (elt x 0) #\c) #\c)
+ (eql (setf (elt x 1) #\a) #\a)
+ (eql (setf (elt x 2) #\t) #\t)
+ (equal x "cat")))
+
+(let ((x (list 0 1 2)))
+ (and (eql (setf (elt x 0) #\c) #\c)
+ (eql (setf (elt x 1) #\a) #\a)
+ (eql (setf (elt x 2) #\t) #\t)
+ (equal x '(#\c #\a #\t))))
+
+(let ((x #'(lambda (a) (+ a 10)))
+ (saved (when (fboundp 'test-fn) (fdefinition 'test-fn))))
+ (unwind-protect (and (eq (setf (fdefinition 'test-fn) x) x)
+ (eql (test-fn 10) 20))
+ (when saved
+ (setf (fdefinition 'test-fn) saved))))
+
+(let ((table (make-hash-table)))
+ (and (equal (multiple-value-list (gethash 1 table)) '(NIL NIL))
+ (equal (multiple-value-list (gethash 1 table 2)) '(2 NIL))
+ (equal (setf (gethash 1 table) "one") "one")
+ (equal (setf (gethash 2 table "two") "two") "two")
+ (multiple-value-bind (value present-p) (gethash 1 table)
+ (and (equal value "one")
+ present-p))
+ (multiple-value-bind (value present-p) (gethash 2 table)
+ (and (equal value "two")
+ present-p))))
+
+(let ((table (make-hash-table)))
+ (and (equal (multiple-value-list (gethash nil table)) '(NIL NIL))
+ (null (setf (gethash nil table) nil))
+ (multiple-value-bind (value present-p) (gethash nil table)
+ (and (equal value NIL)
+ present-p))))
+
+(let ((x (copy-seq #*0101)))
+ (and (eql (setf (sbit x 0) 1) 1)
+ (eql (setf (sbit x 2) 1) 1)
+ (equal x #*1111)))
+
+
+(let ((a 0)
+ (b 1))
+ (and (equal (multiple-value-list (setf (values a b) (values 'x 'y 'z)))
+ '(x y))
+ (eq a 'x)
+ (eq b 'y)))
+
+(let ((x (list 0 1 2))
+ (order nil))
+ (and
+ (equal (multiple-value-list (setf (values (car (prog1 x (push 0 order)))
+ (cadr (prog1 x (push 1 order)))
+ (caddr (prog1 x (push 2 order))))
+ (values 'a 'b)))
+ '(a b nil))
+ (equal x '(a b nil))
+ (equal order '(2 1 0))))
+
+
+(let ((a 'a)
+ (b 'b)
+ (c 'c))
+ (and (equal (multiple-value-list (setf (values (values a) (values b c))
+ (values 0 1 2 3 4)))
+ '(0 1))
+ (eql a 0)
+ (eql b 1)
+ (null c)))
+
+(let ((a 'a)
+ (b 'b)
+ (c 'c)
+ (d 'd))
+ (and (equal (multiple-value-list (setf (values (values a b) (values c d))
+ (values 0 1 2 3 4)))
+ '(0 1))
+ (eql a 0)
+ (null b)
+ (eql c 1)
+ (null d)))
+
+(let ((a 'a)
+ (b 'b)
+ (c 'c)
+ (d 'd))
+ (and (equal (multiple-value-list (setf (values (values a b) (values c d))
+ (values 0)))
+ '(0 nil))
+ (eql a 0)
+ (null b)
+ (null c)
+ (null d)))
+
+(let ((a 'a)
+ (b 'b)
+ (c 'c))
+ (and (equal (multiple-value-list (setf (values a) (values 0 1 2)))
+ '(0))
+ (eql a 0)
+ (eq b 'b)
+ (eq c 'c)))
+
+
+(let ((x (list 1 2 3))
+ (y 'trash))
+ (and (eq (shiftf y x (cdr x) '(hi there)) 'TRASH)
+ (equal x '(2 3))
+ (equal y '(1 HI THERE))))
+
+(let ((x (list 'a 'b 'c)))
+ (and (eq (shiftf (cadr x) 'z) 'B)
+ (equal x '(A Z C))
+ (eq (shiftf (cadr x) (cddr x) 'q) 'Z)
+ (equal x '(A (C) . Q))))
+
+(let ((n 0)
+ (x (list 'a 'b 'c 'd)))
+ (and (eq (shiftf (nth (setq n (+ n 1)) x) 'z) 'B)
+ (equal x '(A Z C D))))
+
+
+(let ((a 0)
+ (b 1)
+ (c 2)
+ (d 3))
+ (and (equal (multiple-value-list (shiftf (values a b) (values c d)
+ (values 4 5)))
+ '(0 1))
+ (eql a 2)
+ (eql b 3)
+ (eql c 4)
+ (eql d 5)))
+
+
+
+(let ((n 0)
+ (x (list 'a 'b 'c 'd 'e 'f 'g)))
+ (and (null (rotatef (nth (incf n) x)
+ (nth (incf n) x)
+ (nth (incf n) x)))
+ (equal x '(A C D B E F G))))
+
+(let ((x (list 'a 'b 'c)))
+ (and (null (rotatef (first x) (second x) (third x)))
+ (equal x '(b c a))))
+
+(let ((x (list 'a 'b 'c 'd 'e 'f)))
+ (and (null (rotatef (second x) (third x) (fourth x) (fifth x)))
+ (equal x '(a c d e b f))))
+
+(null (rotatef))
+(let ((a 0))
+ (and (null (rotatef a))
+ (zerop a)))
+
+(let ((x (list 'a 'b 'c))
+ (order nil))
+ (and (null (rotatef (first (progn (push 1 order) x))
+ (second (progn (push 2 order) x))
+ (third (progn (push 3 order) x))))
+ (equal x '(b c a))
+ (equal order '(3 2 1))))
+
+(let ((x (list 'a 'b 'c))
+ (order nil))
+ (and (null (psetf (first (progn (push 1 order) x))
+ (second (progn (push 2 order) x))
+
+ (second (progn (push 2 order) x))
+ (third (progn (push 3 order) x))
+
+ (third (progn (push 3 order) x))
+ (first (progn (push 1 order) x))))
+ (equal x '(b c a))
+ (equal order '(1 3 3 2 2 1))))
+
+(let ((a 0)
+ (b 1)
+ (c 2)
+ (d 3))
+ (and (null (rotatef (values a b) (values c d)))
+ (eql a 2)
+ (eql b 3)
+ (eql c 0)
+ (eql d 1)))
+
diff --git a/Sacla/tests/must-do.lisp b/Sacla/tests/must-do.lisp
new file mode 100644
index 0000000..7cbd326
--- /dev/null
+++ b/Sacla/tests/must-do.lisp
@@ -0,0 +1,451 @@
+;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
+;; ALL RIGHTS RESERVED.
+;;
+;; $Id: must-do.lisp,v 1.8 2004/02/20 07:23:42 yuji Exp $
+;;
+;; 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.
+;;
+;; 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.
+
+;; dotimes
+(null (dotimes (i 10)))
+(= (dotimes (temp-one 10 temp-one)) 10)
+(let ((temp-two 0))
+ (and (eq t (dotimes (temp-one 10 t) (incf temp-two)))
+ (eql temp-two 10)))
+
+(progn
+ (defun palindromep (string &optional (start 0) (end (length string)))
+ (dotimes (k (floor (- end start) 2) t)
+ (unless (char-equal (char string (+ start k))
+ (char string (- end k 1)))
+ (return nil))))
+ (and (palindromep "Able was I ere I saw Elba")
+ (not (palindromep "A man, a plan, a canal--Panama!"))
+ (equal (remove-if-not #'alpha-char-p ;Remove punctuation.
+ "A man, a plan, a canal--Panama!")
+ "AmanaplanacanalPanama")
+ (palindromep (remove-if-not #'alpha-char-p
+ "A man, a plan, a canal--Panama!"))
+ (palindromep
+ (remove-if-not #'alpha-char-p
+ "Unremarkable was I ere I saw Elba Kramer, nu?"))))
+
+
+(let ((count 0))
+ (eql (dotimes (i 5 count) (incf count)) 5))
+
+(let ((count 0))
+ (eql (dotimes (i 1 count) (incf count)) 1))
+
+(let ((count 0))
+ (zerop (dotimes (i 0 count) (incf count))))
+
+(let ((count 0))
+ (zerop (dotimes (i -1 count) (incf count))))
+
+(let ((count 0))
+ (zerop (dotimes (i -100 count) (incf count))))
+
+(eql (dotimes (i 3 i)) 3)
+(eql (dotimes (i 2 i)) 2)
+(eql (dotimes (i 1 i)) 1)
+(eql (dotimes (i 0 i)) 0)
+(eql (dotimes (i -1 i)) 0)
+(eql (dotimes (i -2 i)) 0)
+(eql (dotimes (i -10 i)) 0)
+
+(let ((list nil))
+ (and (eq (dotimes (i 10 t) (push i list)) t)
+ (equal list '(9 8 7 6 5 4 3 2 1 0))))
+
+(let ((list nil))
+ (equal (dotimes (i 10 (push i list)) (push i list))
+ '(10 9 8 7 6 5 4 3 2 1 0)))
+
+(let ((list nil))
+ (equal (dotimes (i '10 (push i list)) (push i list))
+ '(10 9 8 7 6 5 4 3 2 1 0)))
+
+(let ((list nil))
+ (equal (dotimes (i (/ 100 10) (push i list)) (push i list))
+ '(10 9 8 7 6 5 4 3 2 1 0)))
+
+(null (dotimes (i 10 t) (return nil)))
+
+(equal (multiple-value-list (dotimes (i 10 t) (return (values 'a 'b 'c))))
+ '(a b c))
+
+(let ((val 0))
+ (= (dotimes (i 10 val)
+ (incf val 1)
+ (when (< i 9)
+ (go lp))
+ (incf val 2)
+ lp
+ (incf val 3))
+ 42))
+
+(= (let ((val 0))
+ (dotimes (i 10 val)
+ (when (< i 9)
+ (go loop))
+ 9
+ (incf val 100)
+ (go last)
+ loop
+ (when (= i 0)
+ (go 9))
+ (incf val)
+ last))
+ 208)
+
+(= 3 (let ((i 3)) (dotimes (i i i) (declare (fixnum i)))))
+(= 3 (let ((x 0)) (dotimes (i 3 x) (declare (fixnum i)) (incf x))))
+(= 3 (dotimes (i 3 i) (declare (fixnum i))))
+(= 3 (let ((x 0)) (dotimes (i 3 x) (declare (fixnum i)) (incf x))))
+(equal '((8 6 4 2 0) (9 7 5 3 1))
+ (let (even odd)
+ (dotimes (i 10 (list even odd))
+ (cond
+ ((evenp i) (go even))
+ ((oddp i) (go odd))
+ (t (error "logic error")))
+ even (push i even) (go end)
+ odd (push i odd) (go end)
+ end)))
+
+
+;; dolist
+(let ((list (copy-tree '((0) (1) (2) (3)))))
+ (and (null (dolist (item list) (incf (car item))))
+ (equal list '((1) (2) (3) (4)))))
+
+(eq 'ok (dolist (x '(0 1 2) t) (return 'ok)))
+(eq 'ok (dolist (x '(0 1 2) t) (return-from nil 'ok)))
+(equal '(ok fine)
+ (multiple-value-list (dolist (x '(0 1 2) t) (return (values 'ok 'fine)))))
+(equal '(ok fine)
+ (multiple-value-list (dolist (x '(0 1 2) t)
+ (return-from nil (values 'ok 'fine)))))
+
+(null (let ((x '(0 1 2))) (dolist (x x x))))
+(= 3 (let ((x '(0 1 2)) (i 0)) (dolist (x x i) (incf i))))
+
+(null (dolist (x '())))
+(null (dolist (x '(a))))
+(eq t (dolist (x nil t)))
+(= 6 (let ((sum 0))
+ (dolist (x '(0 1 2 3) sum)
+ (declare (fixnum x))
+ (incf sum x))))
+
+(equal '(5 4 3 2 1)
+ (let (stack)
+ (flet ((f () (declare (special x)) (1+ x)))
+ (dolist (x '(0 1 2 3 4) stack)
+ (declare (special x))
+ (declare (type fixnum x))
+ (push (f) stack)))))
+
+(equal '((3 1) (4 2 0))
+ (let (odd even)
+ (dolist (x '(0 1 2 3 4) (list odd even))
+ (cond
+ ((oddp x) (go odd))
+ ((evenp x) (go even))
+ (t (error "This code mustn't have got executed.")))
+ odd (push x odd) (go loop-end)
+ even (push x even) (go loop-end)
+ loop-end)))
+
+
+(let ((temp-two '()))
+ (equal (dolist (temp-one '(1 2 3 4) temp-two) (push temp-one temp-two))
+ '(4 3 2 1)))
+
+(let ((temp-two 0))
+ (and (null (dolist (temp-one '(1 2 3 4)) (incf temp-two)))
+ (eql temp-two 4)))
+
+
+(null (dolist (var nil var)))
+(let ((list nil))
+ (equal (dolist (var '(0 1 2 3) list)
+ (push var list))
+ '(3 2 1 0)))
+
+(let ((list nil))
+ (equal (dolist (var '(0 1 2 3) (push var list))
+ (push var list))
+ '(nil 3 2 1 0)))
+
+
+(null (dolist (var '(0 1 2 3))))
+
+(let ((list nil))
+ (and (null (dolist (var '(0 1 2 3))
+ (push var list)))
+ (equal list '(3 2 1 0))))
+
+(let ((list nil))
+ (and (eq (dolist (var '() t) (push var list)) t)
+ (null list)))
+
+(let ((list '((a) (b) (c)))
+ (count 0))
+ (dolist (var list t)
+ (unless (eq (nth count list) var)
+ (return nil))
+ (incf count)))
+
+(let ((list nil))
+ (and (null (dolist (var '(0 1 2 3) t)
+ (if (= var 2)
+ (return)
+ (push var list))))
+ (equal list '(1 0))))
+
+(let ((val 0))
+ (= (dolist (var '(a b c) val)
+ (incf val 1)
+ (unless (eq var 'c)
+ (go lp))
+ (incf val 2)
+ lp
+ (incf val 3))
+ 14))
+
+(= (let ((val 0))
+ (dolist (i '(0 1 2 3 4 5 6 7 8 9) val)
+ (when (< i 9)
+ (go loop))
+ 9
+ (incf val 100)
+ (go last)
+ loop
+ (when (= i 0)
+ (go 9))
+ (incf val)
+ last))
+ 208)
+
+(let ((val 0))
+ (= (dolist (i '(0 1 2 3 4 5 6 7 8 9) val)
+ (incf val 1)
+ (when (< i 9)
+ (go lp))
+ (incf val 2)
+ lp
+ (incf val 3))
+ 42))
+
+(eq 'ok (block nil
+ (tagbody
+ (dolist (x '(0 1 2 3) t) (when (oddp x) (go there)))
+ there (return 'ok))))
+
+
+
+;; do
+(flet ((rev (list)
+ (do ((x list (cdr x))
+ (reverse nil (cons (car x) reverse)))
+ ((null x) reverse))))
+ (and (null (rev nil))
+ (equal (rev '(0 1 2 3 4)) '(4 3 2 1 0))))
+
+(flet ((nrev (list)
+ (do ((1st (cdr list) (cdr 1st))
+ (2nd list 1st)
+ (3rd '() 2nd))
+ ((null 2nd) 3rd)
+ (rplacd 2nd 3rd))))
+ (and (null (nrev nil))
+ (equal (nrev (list 0 1 2 3 4)) '(4 3 2 1 0))))
+
+(flet ((sub (list start end)
+ (do* ((x (nthcdr start list) (cdr x))
+ (i start (1+ i))
+ (result (list nil))
+ (splice result))
+ ((>= i end) (cdr result))
+ (setq splice (cdr (rplacd splice (list (car x))))))))
+ (and (eq (sub '() 0 0) '())
+ (equal (sub '(0 1 2 3) 1 4) '(1 2 3))
+ (equal (sub '(0 1 2 3) 1 1) '())
+ (equal (sub '(0 1 2 3) 1 2) '(1))
+ (equal (sub '(0 1 2 3) 1 3) '(1 2))))
+
+
+(eql (do ((temp-one 1 (1+ temp-one))
+ (temp-two 0 (1- temp-two)))
+ ((> (- temp-one temp-two) 5) temp-one))
+ 4)
+
+(eql (do ((temp-one 1 (1+ temp-one))
+ (temp-two 0 (1+ temp-one)))
+ ((= 3 temp-two) temp-one))
+ 3)
+
+(eql (do* ((temp-one 1 (1+ temp-one))
+ (temp-two 0 (1+ temp-one)))
+ ((= 3 temp-two) temp-one))
+ 2)
+
+(let ((a-vector (vector 1 nil 3 nil)))
+ (and (null (do ((i 0 (+ i 1))
+ (n (array-dimension a-vector 0)))
+ ((= i n))
+ (when (null (aref a-vector i))
+ (setf (aref a-vector i) 0))))
+ (equalp a-vector #(1 0 3 0))))
+
+(let ((vec (vector 0 1 2 3 4 5 6 7 8 9)))
+ (equalp (do ((i 0 (1+ i))
+ n
+ (j 9 (1- j)))
+ ((>= i j) vec)
+ (setq n (aref vec i))
+ (setf (aref vec i) (aref vec j))
+ (setf (aref vec j) n))
+ #(9 8 7 6 5 4 3 2 1 0)))
+
+(let ((vec (vector 0 1 2 3 4 5 6 7 8 9)))
+ (and (null (do ((i 0 (1+ i))
+ n
+ (j 9 (1- j)))
+ ((>= i j))
+ (setq n (aref vec i))
+ (setf (aref vec i) (aref vec j))
+ (setf (aref vec j) n)))
+ (equalp vec #(9 8 7 6 5 4 3 2 1 0))))
+
+(let ((vec (vector 0 1 2 3 4 5 6 7 8 9)))
+ (and (null (do ((i 0 (1+ i))
+ n
+ (j 9 (1- j)))
+ ((>= i j))
+ (declare (fixnum i j n))
+ (setq n (aref vec i))
+ (setf (aref vec i) (aref vec j))
+ (setf (aref vec j) n)))
+ (equalp vec #(9 8 7 6 5 4 3 2 1 0))))
+
+(let ((vec (vector 0 1 2 3 4 5 6 7 8 9)))
+ (and (null (do ((i 0 (1+ i))
+ n
+ (j 9 (1- j)))
+ ((>= i j))
+ (declare (fixnum i))
+ (declare (fixnum j))
+ (declare (fixnum n))
+ (setq n (aref vec i))
+ (setf (aref vec i) (aref vec j))
+ (setf (aref vec j) n)))
+ (equalp vec #(9 8 7 6 5 4 3 2 1 0))))
+
+(let ((vec (vector 0 1 2 3 4 5 6 7 8 9)))
+ (and (null (do (n
+ (i 0 (1+ i))
+ (j 9 (1- j)))
+ ((>= i j))
+ (declare (fixnum i))
+ (declare (fixnum j))
+ (declare (fixnum n))
+ (setq n (aref vec i))
+ (setf (aref vec i) (aref vec j))
+ (setf (aref vec j) n)))
+ (equalp vec #(9 8 7 6 5 4 3 2 1 0))))
+
+(let ((vec (vector 0 1 2 3 4 5 6 7 8 9)))
+ (and (null (do ((i 0 (1+ i))
+ (j 9 (1- j))
+ n)
+ ((>= i j))
+ (declare (fixnum i))
+ (declare (fixnum j))
+ (declare (fixnum n))
+ (setq n (aref vec i))
+ (setf (aref vec i) (aref vec j))
+ (setf (aref vec j) n)))
+ (equalp vec #(9 8 7 6 5 4 3 2 1 0))))
+
+(= (do* ((list (list 0 1 2 3 4 5 6 7 8 9) (cdr list))
+ (elm (car list) (car list))
+ (n 0 (+ n (or elm 0))))
+ ((endp list) n))
+ 45)
+
+(= (do* ((list (list 0 1 2 3 4 5 6 7 8 9) (cdr list))
+ (elm (car list) (car list))
+ (n 0))
+ ((endp list) n)
+ (incf n elm))
+ 45)
+
+
+(let ((vec (vector 0 1 2 3 4 5 6 7 8 9)))
+ (and (null (do* (n
+ (i 0 (1+ i))
+ (j (- 9 i) (- 9 i)))
+ ((>= i j))
+ (declare (fixnum i))
+ (declare (fixnum j))
+ (declare (fixnum n))
+ (setq n (aref vec i))
+ (setf (aref vec i) (aref vec j))
+ (setf (aref vec j) n)))
+ (equalp vec #(9 8 7 6 5 4 3 2 1 0))))
+
+(let ((vec (vector 0 1 2 3 4 5 6 7 8 9)))
+ (and (null (do* ((i 0 (1+ i))
+ n
+ (j (- 9 i) (- 9 i)))
+ ((>= i j))
+ (declare (fixnum i j n))
+ (setq n (aref vec i))
+ (setf (aref vec i) (aref vec j))
+ (setf (aref vec j) n)))
+ (equalp vec #(9 8 7 6 5 4 3 2 1 0))))
+
+(let ((vec (vector 0 1 2 3 4 5 6 7 8 9)))
+ (and (null (do* ((i 0 (1+ i))
+ (j (- 9 i) (- 9 i))
+ n)
+ ((>= i j))
+ (declare (fixnum i j n))
+ (setq n (aref vec i))
+ (setf (aref vec i) (aref vec j))
+ (setf (aref vec j) n)))
+ (equalp vec #(9 8 7 6 5 4 3 2 1 0))))
+
+(let ((vec (vector 0 1 2 3 4 5 6 7 8 9)))
+ (and (null (do* ((i 0 (1+ i))
+ (j (- 9 i) (- 9 i))
+ n)
+ ((>= i j))
+ (setf n (aref vec i)
+ (aref vec i) (aref vec j)
+ (aref vec j) n)))
+ (equalp vec #(9 8 7 6 5 4 3 2 1 0))))
+
diff --git a/Sacla/tests/must-eval.lisp b/Sacla/tests/must-eval.lisp
new file mode 100644
index 0000000..5b4a8b7
--- /dev/null
+++ b/Sacla/tests/must-eval.lisp
@@ -0,0 +1,44 @@
+;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
+;; ALL RIGHTS RESERVED.
+;;
+;; $Id: must-eval.lisp,v 1.8 2004/08/09 02:49:54 yuji Exp $
+;;
+;; 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.
+;;
+;; 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.
+
+(= (funcall (lambda (x) (+ x 3)) 4) 7)
+(= (funcall (lambda (&rest args) (apply #'+ args)) 1 2 3 4) 10)
+(functionp (lambda (&rest args) (apply #'+ args)))
+(functionp (macro-function 'lambda))
+
+
+
+(every #'special-operator-p '(block catch eval-when flet function go if labels let let* load-time-value locally macrolet multiple-value-call multiple-value-prog1 progn progv quote return-from setq symbol-macrolet tagbody the throw unwind-protect))
+(not (special-operator-p 'car))
+(not (special-operator-p 'cdr))
+;; Bruno: The spec of MACRO-FUNCTION says that an implementation can have
+;; additional special operators provided the macro expander is available through
+;; MACRO-FUNCTION.
+#-CLISP
+(not (special-operator-p 'cond))
+(not (special-operator-p 'values))
diff --git a/Sacla/tests/must-eval.patch b/Sacla/tests/must-eval.patch
new file mode 100644
index 0000000..8c1211b
--- /dev/null
+++ b/Sacla/tests/must-eval.patch
@@ -0,0 +1,15 @@
+*** sacla/lisp/test/must-eval.lisp 2004-08-03 08:34:54.000000000 +0200
+--- CLISP/clisp-20040712/sacla-tests/must-eval.lisp 2004-08-06 02:38:25.000000000 +0200
+***************
+*** 36,40 ****
+ (every #'special-operator-p '(block catch eval-when flet function go if labels let let* load-time-value locally macrolet multiple-value-call multiple-value-prog1 progn progv quote return-from setq symbol-macrolet tagbody the throw unwind-protect))
+ (not (special-operator-p 'car))
+ (not (special-operator-p 'cdr))
+! (not (special-operator-p 'cond))
+ (not (special-operator-p 'values))
+--- 36,40 ----
+ (every #'special-operator-p '(block catch eval-when flet function go if labels let let* load-time-value locally macrolet multiple-value-call multiple-value-prog1 progn progv quote return-from setq symbol-macrolet tagbody the throw unwind-protect))
+ (not (special-operator-p 'car))
+ (not (special-operator-p 'cdr))
+! #-CLISP (not (special-operator-p 'cond))
+ (not (special-operator-p 'values))
diff --git a/Sacla/tests/must-hash-table.lisp b/Sacla/tests/must-hash-table.lisp
new file mode 100644
index 0000000..d3c1e0c
--- /dev/null
+++ b/Sacla/tests/must-hash-table.lisp
@@ -0,0 +1,696 @@
+;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
+;; ALL RIGHTS RESERVED.
+;;
+;; $Id: must-hash-table.lisp,v 1.8 2004/08/09 02:49:54 yuji Exp $
+;;
+;; 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.
+;;
+;; 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.
+
+(let ((table (make-hash-table)))
+ (and (hash-table-p table)
+ (eql (setf (gethash "one" table) 1) 1)
+ (equal (multiple-value-list (gethash (copy-seq "one") table))
+ '(NIL NIL))))
+
+(let ((table (make-hash-table :test 'equal)))
+ (and (hash-table-p table)
+ (eql (setf (gethash "one" table) 1) 1)
+ (equal (multiple-value-list (gethash (copy-seq "one") table))
+ '(1 T))))
+
+(make-hash-table :rehash-size 1.5 :rehash-threshold 0.7)
+
+(make-hash-table)
+(hash-table-p (make-hash-table))
+#-CLISP ; Bruno: unfounded expectations about hash-table-test
+(dolist (test '(eq eql equal equalp) t)
+ (let ((hash-table (make-hash-table :test test)))
+ (unless (and (hash-table-p hash-table)
+ (eq (hash-table-test hash-table) test))
+ (return nil))))
+#-CLISP ; Bruno: unfounded expectations about hash-table-test
+(dolist (test '(eq eql equal equalp) t)
+ (let* ((test-function (symbol-function test))
+ (hash-table (make-hash-table :test test-function)))
+ (unless (and (hash-table-p hash-table)
+ (eq (hash-table-test hash-table) test))
+ (return nil))))
+
+(hash-table-p (make-hash-table :size 0))
+(hash-table-p (make-hash-table :size 1))
+(hash-table-p (make-hash-table :size 2))
+(hash-table-p (make-hash-table :size 3))
+(hash-table-p (make-hash-table :size 1000))
+(hash-table-p (make-hash-table :rehash-size 1))
+(hash-table-p (make-hash-table :rehash-size 100))
+(hash-table-p (make-hash-table :rehash-size 1.5))
+#-clisp (hash-table-p (make-hash-table :rehash-size 1.0))
+(hash-table-p (make-hash-table :rehash-threshold 0))
+(hash-table-p (make-hash-table :rehash-threshold 0.0))
+(hash-table-p (make-hash-table :rehash-threshold 0.1))
+(hash-table-p (make-hash-table :rehash-threshold 0.12))
+(hash-table-p (make-hash-table :rehash-threshold 0.5))
+(hash-table-p (make-hash-table :rehash-threshold 2/3))
+(hash-table-p (make-hash-table :rehash-threshold 0.888))
+(hash-table-p (make-hash-table :rehash-threshold 0.99))
+(hash-table-p (make-hash-table :rehash-threshold 1))
+(hash-table-p (make-hash-table :rehash-threshold 1.0))
+
+(let ((table (make-hash-table :size 0 :rehash-size 1.1 :rehash-threshold 0)))
+ (and (dotimes (i 10 t)
+ (setf (gethash i table) i))
+ (dotimes (i 10 t)
+ (unless (eql (gethash i table) i)
+ (return nil)))
+ (hash-table-p table)))
+
+(let ((table (make-hash-table :size 1 :rehash-size 1 :rehash-threshold 1)))
+ (and (dotimes (i 100 t)
+ (setf (gethash i table) i))
+ (dotimes (i 100 t)
+ (unless (eql (gethash i table) i)
+ (return nil)))
+ (hash-table-p table)))
+
+
+
+(not (hash-table-p 'hash-table))
+
+(let ((table (make-hash-table)))
+ (hash-table-p table))
+(not (hash-table-p 37))
+(not (hash-table-p '((a . 1) (b . 2))))
+(not (hash-table-p (type-of (make-hash-table))))
+
+
+(let ((table (make-hash-table)))
+ (and (zerop (hash-table-count table))
+ (equal (setf (gethash 57 table) "fifty-seven") "fifty-seven")
+ (eql (hash-table-count table) 1)
+ (dotimes (i 100 t) (setf (gethash i table) i))
+ (eql (hash-table-count table) 100)))
+
+(zerop (hash-table-count (make-hash-table)))
+(let ((table (make-hash-table)))
+ (and (eql (setf (gethash 'key table) 9) 9)
+ (= (hash-table-count table) 1)))
+
+
+#-CLISP ;Bruno: unfounded expectations about hash-table-rehash-size
+(let ((table (make-hash-table :size 100 :rehash-size 1.4)))
+ (= (hash-table-rehash-size table) 1.4))
+
+#-CLISP ;Bruno: unfounded expectations about hash-table-rehash-threshold
+(let ((table (make-hash-table :size 100 :rehash-threshold 0.5)))
+ (= (hash-table-rehash-threshold table) 0.5))
+
+(<= 0 (hash-table-size (make-hash-table)))
+
+#-CLISP ;Bruno: unfounded expectations about hash-table-test
+(eq 'eq (hash-table-test (make-hash-table :test 'eq)))
+#-CLISP ;Bruno: unfounded expectations about hash-table-test
+(eq 'eq (hash-table-test (make-hash-table :test #'eq)))
+#-CLISP ;Bruno: unfounded expectations about hash-table-test
+(eq 'eql (hash-table-test (make-hash-table)))
+#-CLISP ;Bruno: unfounded expectations about hash-table-test
+(eq 'eql (hash-table-test (make-hash-table :test 'eql)))
+#-CLISP ;Bruno: unfounded expectations about hash-table-test
+(eq 'eql (hash-table-test (make-hash-table :test #'eql)))
+#-CLISP ;Bruno: unfounded expectations about hash-table-test
+(eq 'equal (hash-table-test (make-hash-table :test 'equal)))
+#-CLISP ;Bruno: unfounded expectations about hash-table-test
+(eq 'equal (hash-table-test (make-hash-table :test #'equal)))
+#-CLISP ;Bruno: unfounded expectations about hash-table-test
+(eq 'equalp (hash-table-test (make-hash-table :test 'equalp)))
+#-CLISP ;Bruno: unfounded expectations about hash-table-test
+(eq 'equalp (hash-table-test (make-hash-table :test #'equalp)))
+
+(let* ((table0 (make-hash-table))
+ (table (make-hash-table
+ :size (hash-table-size table0)
+ :test (hash-table-test table0)
+ :rehash-threshold (hash-table-rehash-threshold table0)
+ :rehash-size (hash-table-rehash-size table0))))
+ (and (hash-table-p table)
+ (zerop (hash-table-count table))
+ (eq (type-of table) 'hash-table)))
+
+
+(let ((table (make-hash-table)))
+ (and (equal (multiple-value-list (gethash 1 table)) '(NIL NIL))
+ (equal (multiple-value-list (gethash 1 table 2)) '(2 nil))
+ (equal (setf (gethash 1 table) "one") "one")
+ (equal (setf (gethash 2 table "two") "two") "two")
+ (multiple-value-bind (value present-p) (gethash 1 table)
+ (and (equal value "one") present-p))
+ (multiple-value-bind (value present-p) (gethash 2 table)
+ (and (equal value "two") present-p))
+ (equal (multiple-value-list (gethash nil table)) '(nil nil))
+ (null (setf (gethash nil table) nil))
+ (multiple-value-bind (value present-p) (gethash nil table)
+ (and (not value) present-p))))
+
+(multiple-value-bind (value present-p)
+ (gethash 'key (make-hash-table) 'default)
+ (and (eq value 'default) (not present-p)))
+
+(multiple-value-bind (value present-p)
+ (gethash 'key (make-hash-table))
+ (and (null value) (not present-p)))
+
+
+(let ((table (make-hash-table)))
+ (and (multiple-value-bind (value present-p) (gethash 'key table)
+ (and (null value) (not present-p)))
+ (eql (setf (gethash 'key table) 100) 100)
+ (multiple-value-bind (value present-p) (gethash 'key table)
+ (and (eql value 100) present-p))))
+
+(let ((table (make-hash-table))
+ (list nil))
+ (and (eql (setf (gethash (progn (push 0 list) 0)
+ (progn (push 1 list) table)
+ (progn (push 2 list) 'default))
+ (progn (push 3 list) 9))
+ 9)
+ (equal list '(3 2 1 0))))
+
+(let ((table (make-hash-table)))
+ (and (dotimes (i 100 t)
+ (unless (eql (setf (gethash i table) (* i 10)) (* i 10))
+ (return nil)))
+ (= (hash-table-count table) 100)
+ (dotimes (i 100 t)
+ (unless (multiple-value-bind (value present-p) (gethash i table)
+ (and (eql value (* i 10)) present-p))
+ (return nil)))))
+
+
+(let ((table (make-hash-table)))
+ (and (equal (setf (gethash 100 table) "C") "C")
+ (multiple-value-bind (value present-p) (gethash 100 table)
+ (and (equal value "C") present-p))
+ (remhash 100 table)
+ (multiple-value-bind (value present-p) (gethash 100 table)
+ (and (not value) (not present-p)))
+ (not (remhash 100 table))))
+
+(let ((table (make-hash-table)))
+ (and (zerop (hash-table-count table))
+ (eql (setf (gethash 'a table) 'abc) 'abc)
+ (multiple-value-bind (value present-p) (gethash 'a table)
+ (and (eq value 'abc) present-p))
+ (eql (hash-table-count table) 1)
+ (remhash 'a table)
+ (multiple-value-bind (value present-p) (gethash 'a table)
+ (and (not value) (not present-p)))
+ (zerop (hash-table-count table))))
+
+(not (remhash 'key (make-hash-table)))
+
+
+(with-hash-table-iterator (iterator (make-hash-table))
+ (macrolet ((test (&environment env)
+ (if (macro-function 'iterator env) t nil)))
+ (test)))
+
+
+(let ((table (make-hash-table))
+ (alist nil))
+ (dotimes (i 10) (setf (gethash i table) i))
+ (with-hash-table-iterator (iterator table)
+ (loop
+ (multiple-value-bind (more key value) (iterator)
+ (unless more
+ (return))
+ (push (list key value) alist))))
+ (setq alist (sort alist #'< :key #'car))
+ (equal alist '((0 0) (1 1) (2 2) (3 3) (4 4) (5 5) (6 6) (7 7) (8 8) (9 9))))
+
+
+(let ((table (make-hash-table))
+ (eval 0))
+ (dotimes (i 10) (setf (gethash i table) i))
+ (with-hash-table-iterator (iterator (progn (incf eval) table))
+ (loop
+ (multiple-value-bind (more key value) (iterator)
+ (declare (ignore key value))
+ (unless more
+ (return)))))
+ (eql eval 1))
+
+
+(with-hash-table-iterator (iterator (make-hash-table))
+ (null (iterator)))
+
+
+(let ((table (make-hash-table))
+ alist0 alist1 alist2)
+ (dotimes (i 100) (setf (gethash i table) i))
+ (and (with-hash-table-iterator (iterator0 table)
+ (with-hash-table-iterator (iterator1 table)
+ (with-hash-table-iterator (iterator2 table)
+ (loop
+ (multiple-value-bind (more0 key0 value0) (iterator0)
+ (multiple-value-bind (more1 key1 value1) (iterator1)
+ (multiple-value-bind (more2 key2 value2) (iterator2)
+ (unless (or (every #'null (list more0 more1 more2))
+ (every #'identity (list more0 more1 more2)))
+ (return nil))
+ (when (every #'null (list more0 more1 more2))
+ (return t))
+ (push (cons key0 value0) alist0)
+ (push (cons key1 value1) alist1)
+ (push (cons key2 value2) alist2))))))))
+ (equal (sort alist0 #'< :key #'car)
+ (setq alist1 (sort alist1 #'< :key #'car)))
+ (equal alist1 (sort alist2 #'< :key #'car))))
+
+
+
+(let ((table (make-hash-table :rehash-size 100))
+ (n 0)
+ (alist nil))
+ (and (dolist (key '(a b c d e f g h i j k) t)
+ (unless (eql (setf (gethash key table) n) n)
+ (return nil))
+ (incf n))
+ (remhash 'b table)
+ (remhash 'd table)
+ (remhash 'f table)
+ (remhash 'h table)
+ (remhash 'j table)
+ (not (remhash 'b table))
+ (not (remhash 'd table))
+ (not (remhash 'f table))
+ (not (remhash 'h table))
+ (not (remhash 'j table))
+ (with-hash-table-iterator (iterator table)
+ (loop
+ (multiple-value-bind (more key value) (iterator)
+ (unless more
+ (return t))
+ (push (cons key value) alist))))
+ (equal (sort alist #'< :key #'cdr)
+ '((a . 0) (c . 2) (e . 4) (g . 6) (i . 8) (k . 10)))))
+
+
+(let ((table (make-hash-table)))
+ (and (null (dotimes (i 10) (setf (gethash i table) i)))
+ (eql (let ((sum-of-squares 0))
+ (maphash #'(lambda (key val)
+ (let ((square (* val val)))
+ (incf sum-of-squares square)
+ (setf (gethash key table) square)))
+ table)
+ sum-of-squares)
+ 285)
+ (eql (hash-table-count table) 10)
+ (null (maphash #'(lambda (key val)
+ (when (oddp val) (remhash key table)))
+ table))
+ (eql (hash-table-count table) 5)
+ (let ((alist nil))
+ (and (null (maphash #'(lambda (key val)
+ (push (list key val) alist))
+ table))
+ (equalp (sort alist #'< :key #'car)
+ '((0 0) (2 4) (4 16) (6 36) (8 64)))))))
+
+
+(let ((table (make-hash-table))
+ (alist nil))
+ (and (null (dotimes (i 10) (setf (gethash i table) i)))
+ (null (maphash #'(lambda (key val)
+ (if (evenp key)
+ (setf (gethash key table) (* val val))
+ (remhash key table)))
+ table))
+ (null (maphash #'(lambda (key val) (push (cons key val) alist)) table))
+ (equal (sort alist #'< :key #'car)
+ '((0 . 0) (2 . 4) (4 . 16) (6 . 36) (8 . 64)))))
+
+
+
+(flet ((test-hash-table-iterator (hash-table)
+ (let ((all-entries '())
+ (generated-entries '())
+ (unique (list nil)))
+ (maphash #'(lambda (key value) (push (list key value) all-entries))
+ hash-table)
+ (with-hash-table-iterator (generator-fn hash-table)
+ (loop
+ (multiple-value-bind (more? key value) (generator-fn)
+ (unless more? (return))
+ (unless (eql value (gethash key hash-table unique))
+ (error "Key ~S not found for value ~S" key value))
+ (push (list key value) generated-entries))))
+ (unless (= (length all-entries)
+ (length generated-entries)
+ (length (union all-entries generated-entries
+ :key #'car
+ :test (hash-table-test hash-table))))
+ (error "Generated entries and Maphash entries don't correspond"))
+ t)))
+ (let ((table (make-hash-table :rehash-size 100))
+ (n 0))
+ (and (dolist (key '(a b c d e f g h i j k) t)
+ (unless (eql (setf (gethash key table) n) n)
+ (return nil))
+ (incf n))
+ (remhash 'b table)
+ (remhash 'd table)
+ (remhash 'f table)
+ (remhash 'h table)
+ (remhash 'j table)
+ (not (remhash 'b table))
+ (not (remhash 'd table))
+ (not (remhash 'f table))
+ (not (remhash 'h table))
+ (not (remhash 'j table))
+ (test-hash-table-iterator table)
+ (test-hash-table-iterator (make-hash-table)))))
+
+
+
+
+(let ((table (make-hash-table)))
+ (and (null (dotimes (i 100) (setf (gethash i table) (format nil "~R" i))))
+ (eql (hash-table-count table) 100)
+ (multiple-value-bind (value present-p) (gethash 57 table)
+ (and (equal value "fifty-seven") present-p))
+ (hash-table-p (clrhash table))
+ (zerop (hash-table-count table))
+ (multiple-value-bind (value present-p) (gethash 57 table)
+ (and (null value) (not present-p)))))
+
+
+(let ((code (sxhash 'a)))
+ (and (typep code 'fixnum)
+ (<= 0 code)))
+
+(dolist (item '(a "" #\a (make-hash-table) (make-array '(2 3 4)) #*0101 "xx") t)
+ (let ((code (sxhash item)))
+ (unless (and (typep code 'fixnum) (<= 0 code))
+ (return nil))))
+
+
+
+(let ((table (make-hash-table :rehash-threshold 0.8)))
+ (and (eql (setf (gethash 'key table) 'value0) 'value0)
+ (eql (hash-table-count table) 1)
+ (eql (setf (gethash 'key table) 'value1) 'value1)
+ (eql (hash-table-count table) 1)
+ (eq (gethash 'key table) 'value1)))
+
+(let ((table (make-hash-table :rehash-threshold 0.8)))
+ (and (eql (setf (gethash 'key0 table) 'value0) 'value0)
+ (eql (hash-table-count table) 1)
+ (eql (setf (gethash 'key1 table) 'value1) 'value1)
+ (eql (hash-table-count table) 2)
+ (eql (setf (gethash 'key2 table) 'value2) 'value2)
+ (eql (hash-table-count table) 3)
+ (eql (setf (gethash 'key0 table) 'value00) 'value00)
+ (eql (hash-table-count table) 3)
+ (eql (setf (gethash 'key2 table) 'value22) 'value22)
+ (eql (hash-table-count table) 3)
+ (eq (gethash 'key0 table) 'value00)
+ (eq (gethash 'key1 table) 'value1)
+ (eq (gethash 'key2 table) 'value22)))
+
+
+(let ((table (make-hash-table :size 0 :test 'eq))
+ (key0 (copy-seq "key"))
+ (key1 (copy-seq "key")))
+ (and (not (eq key0 key1))
+ (eq (setf (gethash key0 table) 'value) 'value)
+ (multiple-value-bind (value present-p) (gethash key1 table)
+ (and (null value) (not present-p)))
+ (multiple-value-bind (value present-p) (gethash key0 table)
+ (and (eq value 'value) present-p))))
+
+(let ((table (make-hash-table :size 0 :test 'eql))
+ (key0 (copy-seq "key"))
+ (key1 (copy-seq "key")))
+ (and (not (eql key0 key1))
+ (eq (setf (gethash key0 table) 'value) 'value)
+ (multiple-value-bind (value present-p) (gethash key1 table)
+ (and (null value) (not present-p)))
+ (multiple-value-bind (value present-p) (gethash key0 table)
+ (and (eq value 'value) present-p))))
+
+(let ((table (make-hash-table :size 0 :test 'eql))
+ (key0 1.0)
+ (key1 1.0))
+ (and (eql key0 key1)
+ (eq (setf (gethash key0 table) 'value) 'value)
+ (multiple-value-bind (value present-p) (gethash key1 table)
+ (and (eq value 'value) present-p))
+ (multiple-value-bind (value present-p) (gethash key0 table)
+ (and (eq value 'value) present-p))))
+
+(let ((table (make-hash-table :size 0 :test 'eql))
+ (key0 #\a)
+ (key1 #\a))
+ (and (eql key0 key1)
+ (eq (setf (gethash key0 table) 'value) 'value)
+ (multiple-value-bind (value present-p) (gethash key1 table)
+ (and (eq value 'value) present-p))
+ (multiple-value-bind (value present-p) (gethash key0 table)
+ (and (eq value 'value) present-p))))
+
+(let ((table (make-hash-table :size 0 :test 'eql))
+ (key0 #\a)
+ (key1 #\A))
+ (and (not (eql key0 key1))
+ (eq (setf (gethash key0 table) 'value) 'value)
+ (multiple-value-bind (value present-p) (gethash key1 table)
+ (and (null value) (not present-p)))
+ (multiple-value-bind (value present-p) (gethash key0 table)
+ (and (eq value 'value) present-p))))
+
+(let ((table (make-hash-table :size 16 :test 'equal))
+ (key0 'key)
+ (key1 'key))
+ (and (eq key0 key1)
+ (equal key0 key1)
+ (eq (setf (gethash key0 table) 'value) 'value)
+ (multiple-value-bind (value present-p) (gethash key1 table)
+ (and (eq value 'value) present-p))
+ (multiple-value-bind (value present-p) (gethash key0 table)
+ (and (eq value 'value) present-p))))
+
+(let ((table (make-hash-table :size 0 :test 'equal))
+ (key0 1.0)
+ (key1 1.0))
+ (and (equal key0 key1)
+ (eq (setf (gethash key0 table) 'value) 'value)
+ (multiple-value-bind (value present-p) (gethash key1 table)
+ (and (eq value 'value) present-p))
+ (multiple-value-bind (value present-p) (gethash key0 table)
+ (and (eq value 'value) present-p))))
+
+(let ((table (make-hash-table :size 0 :test 'equal))
+ (key0 #\a)
+ (key1 #\a))
+ (and (equal key0 key1)
+ (eq (setf (gethash key0 table) 'value) 'value)
+ (multiple-value-bind (value present-p) (gethash key1 table)
+ (and (eq value 'value) present-p))
+ (multiple-value-bind (value present-p) (gethash key0 table)
+ (and (eq value 'value) present-p))))
+
+(let ((table (make-hash-table :size 0 :test 'equal))
+ (key0 #\a)
+ (key1 #\A))
+ (and (not (equal key0 key1))
+ (eq (setf (gethash key0 table) 'value) 'value)
+ (multiple-value-bind (value present-p) (gethash key1 table)
+ (and (null value) (not present-p)))
+ (multiple-value-bind (value present-p) (gethash key0 table)
+ (and (eq value 'value) present-p))))
+
+(let ((table (make-hash-table :size 16 :test 'equal))
+ (key0 (copy-seq "key"))
+ (key1 (copy-seq "key")))
+ (and (not (eq key0 key1))
+ (equal key0 key1)
+ (eq (setf (gethash key0 table) 'value) 'value)
+ (multiple-value-bind (value present-p) (gethash key1 table)
+ (and (eq value 'value) present-p))
+ (multiple-value-bind (value present-p) (gethash key0 table)
+ (and (eq value 'value) present-p))))
+
+(let ((table (make-hash-table :size 16 :test 'equal))
+ (key0 (copy-seq "key"))
+ (key1 (copy-seq "KEY")))
+ (and (not (eq key0 key1))
+ (not (equal key0 key1))
+ (eq (setf (gethash key0 table) 'value) 'value)
+ (multiple-value-bind (value present-p) (gethash key1 table)
+ (and (null value) (not present-p)))
+ (multiple-value-bind (value present-p) (gethash key0 table)
+ (and (eq value 'value) present-p))))
+
+(let ((table (make-hash-table :size 10 :test 'equal))
+ (key0 (copy-seq '(key)))
+ (key1 (copy-seq '(key))))
+ (and (not (eq key0 key1))
+ (equal key0 key1)
+ (eq (setf (gethash key0 table) 'value) 'value)
+ (multiple-value-bind (value present-p) (gethash key1 table)
+ (and (eq value 'value) present-p))
+ (multiple-value-bind (value present-p) (gethash key0 table)
+ (and (eq value 'value) present-p))))
+
+(let ((table (make-hash-table :size 16 :test 'equal))
+ (key0 (copy-seq #*1010))
+ (key1 (copy-seq #*1010)))
+ (and (not (eq key0 key1))
+ (equal key0 key1)
+ (eq (setf (gethash key0 table) 'value) 'value)
+ (multiple-value-bind (value present-p) (gethash key1 table)
+ (and (eq value 'value) present-p))
+ (multiple-value-bind (value present-p) (gethash key0 table)
+ (and (eq value 'value) present-p))))
+
+(let ((table (make-hash-table :size 16 :test 'equal))
+ (key0 (copy-seq #(a b c)))
+ (key1 (copy-seq #(a b c))))
+ (and (not (eq key0 key1))
+ (not (equal key0 key1))
+ (eq (setf (gethash key0 table) 'value) 'value)
+ (multiple-value-bind (value present-p) (gethash key1 table)
+ (and (null value) (not present-p)))
+ (multiple-value-bind (value present-p) (gethash key0 table)
+ (and (eq value 'value) present-p))))
+
+(let ((table (make-hash-table :size 10 :test 'equal))
+ (key0 (make-pathname))
+ (key1 (make-pathname)))
+ (and (not (eq key0 key1))
+ (equal key0 key1)
+ (eq (setf (gethash key0 table) 'value) 'value)
+ (multiple-value-bind (value present-p) (gethash key1 table)
+ (and (eq value 'value) present-p))
+ (multiple-value-bind (value present-p) (gethash key0 table)
+ (and (eq value 'value) present-p))))
+
+
+(let ((table (make-hash-table :size 0 :test 'equalp))
+ (key0 (copy-seq "key"))
+ (key1 (copy-seq "key")))
+ (and (equalp key0 key1)
+ (eq (setf (gethash key0 table) 'value) 'value)
+ (multiple-value-bind (value present-p) (gethash key1 table)
+ (and (eq value 'value) present-p))
+ (multiple-value-bind (value present-p) (gethash key0 table)
+ (and (eq value 'value) present-p))))
+
+(let ((table (make-hash-table :size 0 :test 'equalp))
+ (key0 1.0)
+ (key1 1.0))
+ (and (equalp key0 key1)
+ (eq (setf (gethash key0 table) 'value) 'value)
+ (multiple-value-bind (value present-p) (gethash key1 table)
+ (and (eq value 'value) present-p))
+ (multiple-value-bind (value present-p) (gethash key0 table)
+ (and (eq value 'value) present-p))))
+
+(let ((table (make-hash-table :size 100 :test 'equalp))
+ (key0 1)
+ (key1 1.0))
+ (and (not (eq key0 key1))
+ (equalp key0 key1)
+ (eq (setf (gethash key0 table) 'value) 'value)
+ (multiple-value-bind (value present-p) (gethash key1 table)
+ (and (eq value 'value) present-p))
+ (multiple-value-bind (value present-p) (gethash key0 table)
+ (and (eq value 'value) present-p))))
+
+(let ((table (make-hash-table :size 0 :test 'equalp))
+ (key0 #\a)
+ (key1 #\a))
+ (and (equalp key0 key1)
+ (eq (setf (gethash key0 table) 'value) 'value)
+ (multiple-value-bind (value present-p) (gethash key1 table)
+ (and (eq value 'value) present-p))
+ (multiple-value-bind (value present-p) (gethash key0 table)
+ (and (eq value 'value) present-p))))
+
+(let ((table (make-hash-table :size 10 :test 'equalp))
+ (key0 #\a)
+ (key1 #\A))
+ (and (not (eq key0 key1))
+ (equalp key0 key1)
+ (eq (setf (gethash key0 table) 'value) 'value)
+ (multiple-value-bind (value present-p) (gethash key1 table)
+ (and (eq value 'value) present-p))
+ (multiple-value-bind (value present-p) (gethash key0 table)
+ (and (eq value 'value) present-p))))
+
+(let ((table (make-hash-table :size 3 :test 'equalp))
+ (key0 (copy-seq '(#\a)))
+ (key1 (copy-seq '(#\A))))
+ (and (not (eq key0 key1))
+ (equalp key0 key1)
+ (eq (setf (gethash key0 table) 'value) 'value)
+ (multiple-value-bind (value present-p) (gethash key1 table)
+ (and (eq value 'value) present-p))
+ (multiple-value-bind (value present-p) (gethash key0 table)
+ (and (eq value 'value) present-p))))
+
+(let ((table (make-hash-table :size 3 :test 'equalp))
+ (key0 (copy-seq '(#\a (1))))
+ (key1 (copy-seq '(#\A (1.0)))))
+ (and (not (eq key0 key1))
+ (equalp key0 key1)
+ (eq (setf (gethash key0 table) 'value) 'value)
+ (multiple-value-bind (value present-p) (gethash key1 table)
+ (and (eq value 'value) present-p))
+ (multiple-value-bind (value present-p) (gethash key0 table)
+ (and (eq value 'value) present-p))))
+
+(let ((table (make-hash-table :test 'equalp))
+ (key0 (make-hash-table))
+ (key1 (make-hash-table)))
+ (and (not (eq key0 key1))
+ (equalp key0 key1)
+ (eq (setf (gethash key0 table) 'value) 'value)
+ (multiple-value-bind (value present-p) (gethash key1 table)
+ (and (eq value 'value) present-p))
+ (multiple-value-bind (value present-p) (gethash key0 table)
+ (and (eq value 'value) present-p))))
+
+(let ((table (make-hash-table)))
+ (and (zerop (hash-table-count table))
+ (dolist (pair '((a abc) (a bc) (1 "one") (1.0 "ONE") (#\a a) (#\A b)) t)
+ (unless (eq (setf (gethash (car pair) table) (cadr pair)) (cadr pair))
+ (return nil)))
+ (eql (hash-table-count table) 5)
+ (eq (gethash 'a table) 'bc)
+ (equal (gethash 1 table) "one")
+ (equal (gethash 1.0 table) "ONE")
+ (eql (gethash #\A table) 'b)
+ (eql (gethash #\a table) 'a)))
+
diff --git a/Sacla/tests/must-hash-table.patch b/Sacla/tests/must-hash-table.patch
new file mode 100644
index 0000000..c9ea48c
--- /dev/null
+++ b/Sacla/tests/must-hash-table.patch
@@ -0,0 +1,55 @@
+*** sacla/lisp/test/must-hash-table.lisp 2004-08-03 08:34:54.000000000 +0200
+--- CLISP/clisp-20040712/sacla-tests/must-hash-table.lisp 2004-08-06 02:45:56.000000000 +0200
+***************
+*** 42,52 ****
+--- 42,54 ----
+
+ (make-hash-table)
+ (hash-table-p (make-hash-table))
++ #-CLISP ; unfounded expectations about hash-table-test
+ (dolist (test '(eq eql equal equalp) t)
+ (let ((hash-table (make-hash-table :test test)))
+ (unless (and (hash-table-p hash-table)
+ (eq (hash-table-test hash-table) test))
+ (return nil))))
++ #-CLISP ; unfounded expectations about hash-table-test
+ (dolist (test '(eq eql equal equalp) t)
+ (let* ((test-function (symbol-function test))
+ (hash-table (make-hash-table :test test-function)))
+***************
+*** 114,135 ****
+--- 116,148 ----
+ (= (hash-table-count table) 1)))
+
+
++ #-CLISP ; unfounded expectations about hash-table-rehash-size
+ (let ((table (make-hash-table :size 100 :rehash-size 1.4)))
+ (= (hash-table-rehash-size table) 1.4))
+
++ #-CLISP ; unfounded expectations about hash-table-rehash-threshold
+ (let ((table (make-hash-table :size 100 :rehash-threshold 0.5)))
+ (= (hash-table-rehash-threshold table) 0.5))
+
+ (<= 0 (hash-table-size (make-hash-table)))
+
++ #-CLISP ; unfounded expectations about hash-table-test
+ (eq 'eq (hash-table-test (make-hash-table :test 'eq)))
++ #-CLISP ; unfounded expectations about hash-table-test
+ (eq 'eq (hash-table-test (make-hash-table :test #'eq)))
++ #-CLISP ; unfounded expectations about hash-table-test
+ (eq 'eql (hash-table-test (make-hash-table)))
++ #-CLISP ; unfounded expectations about hash-table-test
+ (eq 'eql (hash-table-test (make-hash-table :test 'eql)))
++ #-CLISP ; unfounded expectations about hash-table-test
+ (eq 'eql (hash-table-test (make-hash-table :test #'eql)))
++ #-CLISP ; unfounded expectations about hash-table-test
+ (eq 'equal (hash-table-test (make-hash-table :test 'equal)))
++ #-CLISP ; unfounded expectations about hash-table-test
+ (eq 'equal (hash-table-test (make-hash-table :test #'equal)))
++ #-CLISP ; unfounded expectations about hash-table-test
+ (eq 'equalp (hash-table-test (make-hash-table :test 'equalp)))
++ #-CLISP ; unfounded expectations about hash-table-test
+ (eq 'equalp (hash-table-test (make-hash-table :test #'equalp)))
+
+ (let* ((table0 (make-hash-table))
+
diff --git a/Sacla/tests/must-loop.lisp b/Sacla/tests/must-loop.lisp
new file mode 100644
index 0000000..bb28d00
--- /dev/null
+++ b/Sacla/tests/must-loop.lisp
@@ -0,0 +1,3605 @@
+;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
+;; ALL RIGHTS RESERVED.
+;;
+;; $Id: must-loop.lisp,v 1.16 2004/09/28 01:52:16 yuji Exp $
+;;
+;; 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.
+;;
+;; 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.
+
+
+;; simple loop
+(null (loop (return)))
+(loop (return-from nil t))
+(null (let ((stack '(0 1 2))) (loop (unless (pop stack) (return))) stack))
+(equal (multiple-value-list (loop (return (values 0 1 2)))) '(0 1 2))
+(= 100 (let ((i 0)) (loop (incf i) (when (>= i 100) (return i)))))
+(eq (let (x) (tagbody (loop (go end)) end (setq x t)) x) t)
+(eq t (catch 'end (loop (throw 'end t))))
+(eq t (block here (loop (return-from here t))))
+(= 3 (let ((i 0)) (loop (incf i) (if (= i 3) (return i)))))
+(= 9 (let ((i 0)(j 0))
+ (tagbody
+ (loop (incf j 3) (incf i) (if (= i 3) (go exit)))
+ exit)
+ j))
+
+
+;; loop keyword identity
+(equal (let (stack) (loop :for a :from 1 :to 3 :by 1 :do (push a stack)) stack)
+ '(3 2 1))
+(let ((for (make-symbol "FOR"))
+ (from (make-symbol "FROM"))
+ (to (make-symbol "TO"))
+ (by (make-symbol "BY"))
+ (do (make-symbol "DO")))
+ (equal (eval `(let (stack)
+ (loop ,for a ,from 1 ,to 3 ,by 1 ,do (push a stack))
+ stack))
+ '(3 2 1)))
+(let ((for (make-symbol "FOR")))
+ (equal (eval `(let (stack) (loop ,for a :from 1 :to 3 :by 1 :do (push a stack))
+ stack))
+ '(3 2 1)))
+
+(progn
+ (when (find-package "LOOP-KEY-TEST")
+ (delete-package "LOOP-KEY-TEST"))
+ (let* ((pkg (defpackage "LOOP-KEY-TEST"))
+ (for (intern "FOR" pkg))
+ (in (intern "IN" pkg))
+ (by (progn (import 'by pkg) (intern "BY" pkg)))
+ (collect (progn (import 'collect pkg) (intern "COLLECT" pkg))))
+ (export collect pkg)
+ (and (equal (eval `(loop ,for elt ,in '(1 2 3 4 5) ,by #'cddr
+ ,collect elt))
+ '(1 3 5))
+ (delete-package pkg))))
+
+
+;; for-as-arithmetic-up with 3 forms
+(equal (let (stack) (loop for a from 1 to 3 by 1 do (push a stack)) stack)
+ '(3 2 1))
+(equal (let (stack) (loop for a from 1 by 1 to 3 do (push a stack)) stack)
+ '(3 2 1))
+(equal (let (stack) (loop for a to 3 by 1 from 1 do (push a stack)) stack)
+ '(3 2 1))
+(equal (let (stack) (loop for a to 3 from 1 by 1 do (push a stack)) stack)
+ '(3 2 1))
+(equal (let (stack) (loop for a by 1 to 3 from 1 do (push a stack)) stack)
+ '(3 2 1))
+(equal (let (stack) (loop for a by 1 from 1 to 3 do (push a stack)) stack)
+ '(3 2 1))
+
+(equal (let (stack) (loop for a upfrom 1 to 3 by 1 do (push a stack)) stack)
+ '(3 2 1))
+(equal (let (stack) (loop for a upfrom 1 by 1 to 3 do (push a stack)) stack)
+ '(3 2 1))
+(equal (let (stack) (loop for a to 3 by 1 upfrom 1 do (push a stack)) stack)
+ '(3 2 1))
+(equal (let (stack) (loop for a to 3 upfrom 1 by 1 do (push a stack)) stack)
+ '(3 2 1))
+(equal (let (stack) (loop for a by 1 to 3 upfrom 1 do (push a stack)) stack)
+ '(3 2 1))
+(equal (let (stack) (loop for a by 1 upfrom 1 to 3 do (push a stack)) stack)
+ '(3 2 1))
+
+
+(equal (let (stack) (loop for a from 1 upto 3 by 1 do (push a stack)) stack)
+ '(3 2 1))
+(equal (let (stack) (loop for a from 1 by 1 upto 3 do (push a stack)) stack)
+ '(3 2 1))
+(equal (let (stack) (loop for a upto 3 by 1 from 1 do (push a stack)) stack)
+ '(3 2 1))
+(equal (let (stack) (loop for a upto 3 from 1 by 1 do (push a stack)) stack)
+ '(3 2 1))
+(equal (let (stack) (loop for a by 1 upto 3 from 1 do (push a stack)) stack)
+ '(3 2 1))
+(equal (let (stack) (loop for a by 1 from 1 upto 3 do (push a stack)) stack)
+ '(3 2 1))
+
+(equal (let (stack) (loop for a upfrom 1 upto 3 by 1 do (push a stack)) stack)
+ '(3 2 1))
+(equal (let (stack) (loop for a upfrom 1 by 1 upto 3 do (push a stack)) stack)
+ '(3 2 1))
+(equal (let (stack) (loop for a upto 3 by 1 upfrom 1 do (push a stack)) stack)
+ '(3 2 1))
+(equal (let (stack) (loop for a upto 3 upfrom 1 by 1 do (push a stack)) stack)
+ '(3 2 1))
+(equal (let (stack) (loop for a by 1 upto 3 upfrom 1 do (push a stack)) stack)
+ '(3 2 1))
+(equal (let (stack) (loop for a by 1 upfrom 1 upto 3 do (push a stack)) stack)
+ '(3 2 1))
+
+
+(equal (let (stack) (loop for a from 1 below 4 by 1 do (push a stack)) stack)
+ '(3 2 1))
+(equal (let (stack) (loop for a from 1 by 1 below 4 do (push a stack)) stack)
+ '(3 2 1))
+(equal (let (stack) (loop for a below 4 by 1 from 1 do (push a stack)) stack)
+ '(3 2 1))
+(equal (let (stack) (loop for a below 4 from 1 by 1 do (push a stack)) stack)
+ '(3 2 1))
+(equal (let (stack) (loop for a by 1 below 4 from 1 do (push a stack)) stack)
+ '(3 2 1))
+(equal (let (stack) (loop for a by 1 from 1 below 4 do (push a stack)) stack)
+ '(3 2 1))
+
+(equal (let (stack) (loop for a upfrom 1 below 4 by 1 do (push a stack)) stack)
+ '(3 2 1))
+(equal (let (stack) (loop for a upfrom 1 by 1 below 4 do (push a stack)) stack)
+ '(3 2 1))
+(equal (let (stack) (loop for a below 4 by 1 upfrom 1 do (push a stack)) stack)
+ '(3 2 1))
+(equal (let (stack) (loop for a below 4 upfrom 1 by 1 do (push a stack)) stack)
+ '(3 2 1))
+(equal (let (stack) (loop for a by 1 below 4 upfrom 1 do (push a stack)) stack)
+ '(3 2 1))
+(equal (let (stack) (loop for a by 1 upfrom 1 below 4 do (push a stack)) stack)
+ '(3 2 1))
+
+
+;; for-as-arithmetic-up with 2 forms
+(equal (let (stack) (loop for a from 1 to 3 do (push a stack)) stack) '(3 2 1))
+(equal (let (stack) (loop for a to 3 from 1 do (push a stack)) stack) '(3 2 1))
+
+(equal (let (stack) (loop for a upfrom 1 to 3 do (push a stack)) stack) '(3 2 1))
+(equal (let (stack) (loop for a to 3 upfrom 1 do (push a stack)) stack) '(3 2 1))
+
+
+(equal (let (stack) (loop for a from 1 upto 3 do (push a stack)) stack) '(3 2 1))
+(equal (let (stack) (loop for a upto 3 from 1 do (push a stack)) stack) '(3 2 1))
+
+(equal (let (stack) (loop for a upfrom 1 upto 3 do (push a stack)) stack)
+ '(3 2 1))
+(equal (let (stack) (loop for a upto 3 upfrom 1 do (push a stack)) stack)
+ '(3 2 1))
+
+
+(equal (let (stack) (loop for a from 1 below 4 do (push a stack)) stack) '(3 2 1))
+(equal (let (stack) (loop for a below 4 from 1 do (push a stack)) stack) '(3 2 1))
+
+(equal (let (stack) (loop for a upfrom 1 below 4 do (push a stack)) stack)
+ '(3 2 1))
+(equal (let (stack) (loop for a below 4 upfrom 1 do (push a stack)) stack)
+ '(3 2 1))
+
+
+(equal (let (stack) (loop for a to 3 by 1 do (push a stack)) stack) '(3 2 1 0))
+(equal (let (stack) (loop for a by 1 to 3 do (push a stack)) stack) '(3 2 1 0))
+
+(equal (let (stack) (loop for a upto 3 by 1 do (push a stack)) stack) '(3 2 1 0))
+(equal (let (stack) (loop for a by 1 upto 3 do (push a stack)) stack) '(3 2 1 0))
+
+(equal (let (stack) (loop for a below 4 by 1 do (push a stack)) stack)
+ '(3 2 1 0))
+(equal (let (stack) (loop for a by 1 below 4 do (push a stack)) stack)
+ '(3 2 1 0))
+
+
+(= 4 (let ((stack '(1 2 3)))
+ (loop for a from 1 by 1 do (unless (pop stack) (return a)))))
+(= 4 (let ((stack '(1 2 3)))
+ (loop for a by 1 from 1 do (unless (pop stack) (return a)))))
+
+(= 4 (let ((stack '(1 2 3)))
+ (loop for a upfrom 1 by 1 do (unless (pop stack) (return a)))))
+(= 4 (let ((stack '(1 2 3)))
+ (loop for a by 1 upfrom 1 do (unless (pop stack) (return a)))))
+
+
+;; for-as-arithmetic-up with 1 form
+(= 4 (let ((stack '(1 2 3)))
+ (loop for a from 1 do (unless (pop stack) (return a)))))
+(= 4 (let ((stack '(1 2 3)))
+ (loop for a upfrom 1 do (unless (pop stack) (return a)))))
+
+(equal (let (stack) (loop for a to 3 do (push a stack)) stack)
+ '(3 2 1 0))
+(equal (let (stack) (loop for a upto 3 do (push a stack)) stack)
+ '(3 2 1 0))
+(equal (let (stack) (loop for a below 4 do (push a stack)) stack)
+ '(3 2 1 0))
+
+(= 3 (let ((stack '(1 2 3)))
+ (loop for a by 1 do (unless (pop stack) (return a)))))
+
+
+;; for-as-arithmetic-downto with 3 forms
+(equal (let (stack) (loop for a from 3 downto 1 by 1 do (push a stack)) stack)
+ '(1 2 3))
+(equal (let (stack) (loop for a from 3 by 1 downto 1 do (push a stack)) stack)
+ '(1 2 3))
+(equal (let (stack) (loop for a downto 1 by 1 from 3 do (push a stack)) stack)
+ '(1 2 3))
+(equal (let (stack) (loop for a downto 1 from 3 by 1 do (push a stack)) stack)
+ '(1 2 3))
+(equal (let (stack) (loop for a by 1 from 3 downto 1 do (push a stack)) stack)
+ '(1 2 3))
+(equal (let (stack) (loop for a by 1 downto 1 from 3 do (push a stack)) stack)
+ '(1 2 3))
+
+(equal (let (stack) (loop for a from 3 above 0 by 1 do (push a stack)) stack)
+ '(1 2 3))
+(equal (let (stack) (loop for a from 3 by 1 above 0 do (push a stack)) stack)
+ '(1 2 3))
+(equal (let (stack) (loop for a above 0 by 1 from 3 do (push a stack)) stack)
+ '(1 2 3))
+(equal (let (stack) (loop for a above 0 from 3 by 1 do (push a stack)) stack)
+ '(1 2 3))
+(equal (let (stack) (loop for a by 1 from 3 above 0 do (push a stack)) stack)
+ '(1 2 3))
+(equal (let (stack) (loop for a by 1 above 0 from 3 do (push a stack)) stack)
+ '(1 2 3))
+
+
+;; for-as-arithmetic-downto with 2 forms
+(equal (let (stack) (loop for a from 3 downto 1 do (push a stack)) stack)
+ '(1 2 3))
+(equal (let (stack) (loop for a downto 1 from 3 do (push a stack)) stack)
+ '(1 2 3))
+
+(equal (let (stack) (loop for a from 3 above 0 do (push a stack)) stack)
+ '(1 2 3))
+(equal (let (stack) (loop for a above 0 from 3 do (push a stack)) stack)
+ '(1 2 3))
+
+
+;; for-as-arithmetic-downfrom with 3 forms
+(equal (let (stack) (loop for a downfrom 3 to 1 by 1 do (push a stack)) stack)
+ '(1 2 3))
+(equal (let (stack) (loop for a downfrom 3 by 1 to 1 do (push a stack)) stack)
+ '(1 2 3))
+
+(equal (let (stack) (loop for a to 1 by 1 downfrom 3 do (push a stack)) stack)
+ '(1 2 3))
+(equal (let (stack) (loop for a to 1 downfrom 3 by 1 do (push a stack)) stack)
+ '(1 2 3))
+
+(equal (let (stack) (loop for a by 1 to 1 downfrom 3 do (push a stack)) stack)
+ '(1 2 3))
+(equal (let (stack) (loop for a by 1 downfrom 3 to 1 do (push a stack)) stack)
+ '(1 2 3))
+
+
+(equal (let (stack) (loop for a downfrom 3 downto 1 by 1 do (push a stack))
+ stack)
+ '(1 2 3))
+(equal (let (stack) (loop for a downfrom 3 by 1 downto 1 do (push a stack))
+ stack)
+ '(1 2 3))
+
+(equal (let (stack) (loop for a downto 1 by 1 downfrom 3 do (push a stack))
+ stack)
+ '(1 2 3))
+(equal (let (stack) (loop for a downto 1 downfrom 3 by 1 do (push a stack))
+ stack)
+ '(1 2 3))
+
+(equal (let (stack) (loop for a by 1 downto 1 downfrom 3 do (push a stack))
+ stack)
+ '(1 2 3))
+(equal (let (stack) (loop for a by 1 downfrom 3 downto 1 do (push a stack))
+ stack)
+ '(1 2 3))
+
+
+(equal (let (stack) (loop for a downfrom 3 above 0 by 1 do (push a stack))
+ stack)
+ '(1 2 3))
+(equal (let (stack) (loop for a downfrom 3 by 1 above 0 do (push a stack))
+ stack)
+ '(1 2 3))
+
+(equal (let (stack) (loop for a above 0 by 1 downfrom 3 do (push a stack))
+ stack)
+ '(1 2 3))
+(equal (let (stack) (loop for a above 0 downfrom 3 by 1 do (push a stack))
+ stack)
+ '(1 2 3))
+
+(equal (let (stack) (loop for a by 1 above 0 downfrom 3 do (push a stack))
+ stack)
+ '(1 2 3))
+(equal (let (stack) (loop for a by 1 downfrom 3 above 0 do (push a stack))
+ stack)
+ '(1 2 3))
+
+
+;; for-as-arithmetic-downfrom with 2 forms
+(equal (let (stack) (loop for a downfrom 3 to 1 do (push a stack)) stack)
+ '(1 2 3))
+(equal (let (stack) (loop for a to 1 downfrom 3 do (push a stack)) stack)
+ '(1 2 3))
+
+(equal (let (stack) (loop for a downfrom 3 downto 1 do (push a stack)) stack)
+ '(1 2 3))
+(equal (let (stack) (loop for a downto 1 downfrom 3 do (push a stack)) stack)
+ '(1 2 3))
+
+(equal (let (stack) (loop for a downfrom 3 above 0 do (push a stack)) stack)
+ '(1 2 3))
+(equal (let (stack) (loop for a above 0 downfrom 3 do (push a stack)) stack)
+ '(1 2 3))
+
+
+(zerop (let ((stack '(0 1 2)))
+ (loop for a downfrom 3 by 1 do (unless (pop stack) (return a)))))
+(zerop (let ((stack '(0 1 2)))
+ (loop for a by 1 downfrom 3 do (unless (pop stack) (return a)))))
+
+;; for-as-arithmetic-downfrom with 1 form
+(zerop (let ((stack '(0 1 2)))
+ (loop for a downfrom 3 do (unless (pop stack) (return a)))))
+
+;; for-as-arithmetic form evaluation
+(equal (let (stack)
+ (loop for a from (+ 1 1) upto (+ 4 6) by (1+ 1) do (push a stack))
+ stack)
+ '(10 8 6 4 2))
+
+;; for-as-arithmetic form evaluation order
+(equal (let ((x 0)
+ stack)
+ (loop for a from (incf x) upto (+ (incf x) 10) by x do (push a stack))
+ stack)
+ '(11 9 7 5 3 1))
+
+(equal (let ((x 0)
+ stack)
+ (loop for a from (incf x) by (incf x) upto (+ x 10) do (push a stack))
+ stack)
+ '(11 9 7 5 3 1))
+
+(equal (let ((x 0)
+ stack)
+ (loop for a by (incf x) from (incf x) upto (+ x 10) do (push a stack))
+ stack)
+ '(12 11 10 9 8 7 6 5 4 3 2))
+
+(equal (let ((x 0)
+ stack)
+ (loop for a by (incf x) upto (+ (incf x) 10) from (incf x)
+ do (push a stack))
+ stack)
+ '(12 11 10 9 8 7 6 5 4 3))
+
+;; for-as-arithmetic type
+(equal (let (stack) (loop for a t from 1 to 3 by 1 do (push a stack)) stack)
+ '(3 2 1))
+
+(equal (let (stack) (loop for a fixnum from 1 to 3 by 1 do (push a stack)) stack)
+ '(3 2 1))
+
+(equal (let (stack) (loop for a float from 1.0 to 3.0 by 1.0 do (push a stack))
+ stack)
+ '(3.0 2.0 1.0))
+
+
+(equal (let (stack) (loop for a of-type t from 1 to 3 by 1 do (push a stack))
+ stack)
+ '(3 2 1))
+
+(equal (let (stack)
+ (loop for a of-type fixnum from 1 to 3 by 1 do (push a stack)) stack)
+ '(3 2 1))
+
+(equal (let (stack)
+ (loop for a of-type float from 1.0 to 3.0 by 1.0 do (push a stack))
+ stack)
+ '(3.0 2.0 1.0))
+
+(equal (let (stack)
+ (loop for a of-type number from 1 to 3 by 1 do (push a stack)) stack)
+ '(3 2 1))
+
+(equal (let (stack)
+ (loop for a of-type integer from 1 to 3 by 1 do (push a stack)) stack)
+ '(3 2 1))
+
+
+
+
+;; for-as-arithmetic misc
+(equal (let ((stack)) (loop for a from 0 upto 10 by 5 do (push a stack)) stack)
+ '(10 5 0))
+
+(equal (let ((stack)) (loop for a from 0 upto 10 by 3 do (push a stack)) stack)
+ '(9 6 3 0))
+
+(equal (let ((stack)) (loop for a from -3 upto 0 do (push a stack)) stack)
+ '(0 -1 -2 -3))
+
+(equal (let ((stack)) (loop for a downfrom 0 to -3 do (push a stack)) stack)
+ '(-3 -2 -1 0))
+(equal (let (stack) (loop as a from 1 to 3 by 1 do (push a stack)) stack)
+ '(3 2 1))
+(equal (let (stack) (loop as a upfrom 1 to 3 by 1 do (push a stack)) stack)
+ '(3 2 1))
+(equal (let (stack) (loop as a from 1 upto 3 by 1 do (push a stack)) stack)
+ '(3 2 1))
+(equal (let (stack) (loop as a upfrom 1 upto 3 by 1 do (push a stack)) stack)
+ '(3 2 1))
+(equal (let (stack) (loop as a from 1 below 4 by 1 do (push a stack)) stack)
+ '(3 2 1))
+(equal (let (stack) (loop as a upfrom 1 below 4 by 1 do (push a stack)) stack)
+ '(3 2 1))
+(equal (let (stack) (loop as a from 1 to 3 do (push a stack)) stack) '(3 2 1))
+(equal (let (stack) (loop as a upfrom 1 to 3 do (push a stack)) stack) '(3 2 1))
+(equal (let (stack) (loop as a from 1 upto 3 do (push a stack)) stack) '(3 2 1))
+(equal (let (stack) (loop as a upfrom 1 upto 3 do (push a stack)) stack)
+ '(3 2 1))
+(equal (let (stack) (loop as a from 1 below 4 do (push a stack)) stack) '(3 2 1))
+(equal (let (stack) (loop as a upfrom 1 below 4 do (push a stack)) stack)
+ '(3 2 1))
+(equal (let (stack) (loop as a to 3 by 1 do (push a stack)) stack) '(3 2 1 0))
+(equal (let (stack) (loop as a upto 3 by 1 do (push a stack)) stack) '(3 2 1 0))
+(equal (let (stack) (loop as a below 4 by 1 do (push a stack)) stack)
+ '(3 2 1 0))
+(= 4 (let ((stack '(1 2 3)))
+ (loop as a from 1 by 1 do (unless (pop stack) (return a)))))
+(= 4 (let ((stack '(1 2 3)))
+ (loop as a upfrom 1 by 1 do (unless (pop stack) (return a)))))
+(= 4 (let ((stack '(1 2 3)))
+ (loop as a from 1 do (unless (pop stack) (return a)))))
+(equal (let (stack) (loop as a to 3 do (push a stack)) stack) '(3 2 1 0))
+(= 3 (let ((stack '(1 2 3)))
+ (loop as a by 1 do (unless (pop stack) (return a)))))
+(equal (let (stack) (loop as a from 3 downto 1 by 1 do (push a stack)) stack)
+ '(1 2 3))
+(equal (let (stack) (loop as a from 3 above 0 by 1 do (push a stack)) stack)
+ '(1 2 3))
+(equal (let (stack) (loop as a from 3 downto 1 do (push a stack)) stack)
+ '(1 2 3))
+(equal (let (stack) (loop as a from 3 above 0 do (push a stack)) stack)
+ '(1 2 3))
+(equal (let (stack) (loop as a downfrom 3 to 1 by 1 do (push a stack)) stack)
+ '(1 2 3))
+(equal (let (stack) (loop as a to 1 by 1 downfrom 3 do (push a stack)) stack)
+ '(1 2 3))
+(equal (let (stack) (loop as a by 1 to 1 downfrom 3 do (push a stack)) stack)
+ '(1 2 3))
+(equal (let (stack) (loop as a downfrom 3 downto 1 by 1 do (push a stack))
+ stack)
+ '(1 2 3))
+(equal (let (stack) (loop as a downto 1 by 1 downfrom 3 do (push a stack))
+ stack)
+ '(1 2 3))
+(equal (let (stack) (loop as a by 1 downto 1 downfrom 3 do (push a stack))
+ stack)
+ '(1 2 3))
+(equal (let (stack) (loop as a downfrom 3 above 0 by 1 do (push a stack))
+ stack)
+ '(1 2 3))
+(equal (let (stack) (loop as a above 0 by 1 downfrom 3 do (push a stack))
+ stack)
+ '(1 2 3))
+(equal (let (stack) (loop as a by 1 above 0 downfrom 3 do (push a stack))
+ stack)
+ '(1 2 3))
+(equal (let (stack) (loop as a downfrom 3 to 1 do (push a stack)) stack)
+ '(1 2 3))
+(equal (let (stack) (loop as a downfrom 3 downto 1 do (push a stack)) stack)
+ '(1 2 3))
+(equal (let (stack) (loop as a downfrom 3 above 0 do (push a stack)) stack)
+ '(1 2 3))
+(zerop (let ((stack '(0 1 2)))
+ (loop as a downfrom 3 by 1 do (unless (pop stack) (return a)))))
+(zerop (let ((stack '(0 1 2)))
+ (loop as a downfrom 3 do (unless (pop stack) (return a)))))
+(equal (let (stack) (loop for a from 0 upto 0 do (push a stack)) stack) '(0))
+(null (loop for a upfrom 0 below 0))
+(null (loop for a upfrom 10 to -10 collect a))
+(equal (let (stack)
+ (loop for a from 1/3 upto 1 by 1/3 do (push a stack))
+ stack)
+ '(1 2/3 1/3))
+(equal (let (stack)
+ (loop for a of-type rational from 1/3 upto 5/3 by 1/3 do (push a stack))
+ stack)
+ '(5/3 4/3 1 2/3 1/3))
+(equal (let(stack) (loop for a fixnum below 3 do (push a stack)) stack)
+ '(2 1 0))
+(equal (let(stack) (loop for a of-type fixnum below 3 do (push a stack)) stack)
+ '(2 1 0))
+(equal (let(stack) (loop for a of-type (integer 0 2)
+ below 3 do (push a stack)) stack)
+ '(2 1 0))
+
+
+;; for-as-in-list
+(null (loop for a in '()))
+(equal (let (stack) (loop for a in '(0 1 2) do (push a stack)) stack)
+ '(2 1 0))
+(equal (let (stack)
+ (loop for a in (let ((i 0)) (list (incf i) (incf i) (incf i)))
+ do (push a stack))
+ stack)
+ '(3 2 1))
+(handler-case (loop for a in '(0 1 . 2))
+ (type-error ()
+ t)
+ (error () nil)
+ (:no-error (&rest rest)
+ (declare (ignore rest))
+ nil)) ; check must be done by endp
+(equal (let (stack)
+ (loop for a in '(0 1 2 3) by #'cdr do (push a stack))
+ stack)
+ '(3 2 1 0))
+(equal (let (stack)
+ (loop for a in '(0 1 2 3) by #'cddr do (push a stack))
+ stack)
+ '(2 0))
+(equal (let (stack)
+ (loop for a in '(0 1 2 3) by #'cdddr do (push a stack))
+ stack)
+ '(3 0))
+(equal (let (stack)
+ (loop for a in '(0 1 2 3) by #'cddddr do (push a stack))
+ stack)
+ '(0))
+(equal (let (stack) (loop for a t in '(0 1 2) do (push a stack)) stack) '(2 1 0))
+(equal (let (stack) (loop for a of-type t in '(0 1 2) do (push a stack)) stack)
+ '(2 1 0))
+(equal (let (stack) (loop for a fixnum in '(0 1 2) do (push a stack))
+ stack) '(2 1 0))
+(equal (let (stack) (loop for a of-type fixnum in '(0 1 2) do (push a stack))
+ stack) '(2 1 0))
+(equal (let (stack) (loop for a of-type t in '(0 1 2) do (push a stack))
+ stack) '(2 1 0))
+(equal (let (stack) (loop for a float in '(0.0 1.0 2.0) do (push a stack))
+ stack) '(2.0 1.0 0.0))
+(equal (let (stack) (loop for a of-type float in '(0.0 1.0 2.0)
+ do (push a stack))
+ stack) '(2.0 1.0 0.0))
+
+
+
+
+
+;; for-as-on-list
+(null (loop for a on '()))
+(equal (let (stack) (loop for a on '(0 1 2) do (push a stack)) stack)
+ '((2) (1 2) (0 1 2)))
+(equal (let (stack)
+ (loop for a on (let ((i 0)) (list (incf i) (incf i) (incf i)))
+ do (push (car a) stack))
+ stack)
+ '(3 2 1))
+(equal (let (stack) (loop for a on '(0 1 . 2) do (push a stack)) stack)
+ '((1 . 2) (0 1 . 2))) ; check must be done by atom
+(equal (let (stack)
+ (loop for a on '(0 1 2 3) by #'cdr do (push a stack))
+ stack)
+ '((3) (2 3) (1 2 3) (0 1 2 3)))
+(equal (let (stack)
+ (loop for a on '(0 1 2 3) by #'cddr do (push a stack))
+ stack)
+ '((2 3) (0 1 2 3)))
+(equal (let (stack)
+ (loop for a on '(0 1 2 3) by #'cdddr do (push a stack))
+ stack)
+ '((3) (0 1 2 3)))
+(equal (let (stack)
+ (loop for a on '(0 1 2 3) by #'cddddr do (push a stack))
+ stack)
+ '((0 1 2 3)))
+(equal (let (stack) (loop for a t on '(0 1 2) do (push a stack)) stack)
+ '((2) (1 2) (0 1 2)))
+(equal (let (stack) (loop for a of-type t on '(0 1 2) do (push a stack)) stack)
+ '((2) (1 2) (0 1 2)))
+(equal (let (stack) (loop for a of-type list on '(0 1 2) do (push a stack))
+ stack)
+ '((2) (1 2) (0 1 2)))
+
+(equal (let (stack)
+ (loop for a on '(0 1 2 3) by #'(lambda (arg) (cddddr arg))
+ do (push a stack))
+ stack)
+ '((0 1 2 3)))
+
+
+;; for-as-across
+(null (loop for a across ""))
+(null (let (stack) (loop for a across "" do (push a stack)) stack))
+(equal (let (stack) (loop for a across "abc" do (push a stack)) stack)
+ '(#\c #\b #\a))
+(equal (let (stack) (loop for a across #(x y z) do (push a stack)) stack)
+ '(z y x))
+(equal (let (stack) (loop for a across #*0101 do (push a stack)) stack)
+ '(1 0 1 0))
+(equal (let (stack) (loop for a t across "abc" do (push a stack)) stack)
+ '(#\c #\b #\a))
+(equal (let (stack) (loop for a of-type t across "abc" do (push a stack)) stack)
+ '(#\c #\b #\a))
+(equal (let (stack) (loop for a of-type character across "abc"
+ do (push a stack)) stack)
+ '(#\c #\b #\a))
+(equal (let (stack) (loop for a of-type base-char across "abc"
+ do (push a stack)) stack)
+ '(#\c #\b #\a))
+(equal (let (stack) (loop for a float across #(0.0 1.0 2.0)
+ do (push a stack)) stack)
+ '(2.0 1.0 0.0))
+(equal (let (stack) (loop for a of-type float across #(0.0 1.0 2.0)
+ do (push a stack)) stack)
+ '(2.0 1.0 0.0))
+(equal (let (stack) (loop for a fixnum across #(0 1 2)
+ do (push a stack)) stack)
+ '(2 1 0))
+(equal (let (stack) (loop for a of-type fixnum across #(0 1 2)
+ do (push a stack)) stack)
+ '(2 1 0))
+
+
+
+
+
+
+;; for-as-equals-then
+(= (let ((i 3)) (loop for a = 0 then (1+ a)
+ do (when (zerop (decf i)) (return a))))
+ 2)
+(equal (let (stack) (loop for a = '(0 1 2) then (cdr a)
+ do (if a (push (car a) stack) (return stack))))
+ '(2 1 0))
+(equal (let (stack) (loop with i = 0 for x = i
+ do (when (= i 3) (return))
+ (push x stack) (incf i)) stack)
+ '(2 1 0))
+(equal (let (stack)
+ (loop for i = 0 then (1+ i) do (push i stack) when (= i 3) return t)
+ stack)
+ '(3 2 1 0))
+(equal (let (stack)
+ (loop for i fixnum = 0 then (1+ i) do (push i stack)
+ when (= i 3) return t)
+ stack)
+ '(3 2 1 0))
+(equal (let (stack)
+ (loop for i of-type fixnum = 0 then (1+ i) do (push i stack)
+ when (= i 3) return t)
+ stack)
+ '(3 2 1 0))
+(equal (let (stack)
+ (loop for i float = 0.0 then (1+ i) do (push i stack)
+ when (= i 3.0) return t)
+ stack)
+ '(3.0 2.0 1.0 0.0))
+(equal (let (stack)
+ (loop for i of-type float = 0.0 then (1+ i) do (push i stack)
+ when (= i 3.0) return t)
+ stack)
+ '(3.0 2.0 1.0 0.0))
+(equal (let (stack)
+ (loop for i t = 0.0 then (1+ i) do (push i stack)
+ when (= i 3.0) return t)
+ stack)
+ '(3.0 2.0 1.0 0.0))
+(equal (let (stack)
+ (loop for i of-type t = 0.0 then (1+ i) do (push i stack)
+ when (= i 3.0) return t)
+ stack)
+ '(3.0 2.0 1.0 0.0))
+(let ((chars '(#\a #\b #\c #\d)))
+ (eq t (loop for c = (pop chars) unless chars return t)))
+(let ((chars '(#\a #\b #\c #\d)))
+ (eq t (loop for c of-type character = (pop chars) unless chars return t)))
+(let ((chars '(#\a #\b #\c #\d)))
+ (eq t (loop for c of-type base-char = (pop chars) unless chars return t)))
+(equal (let (stack)
+ (loop for i of-type (integer 0 3) = 0 then (1+ i) do (push i stack)
+ when (= i 3) return t)
+ stack)
+ '(3 2 1 0))
+
+(flet ((triple (n) (values n (+ n 1) (+ n 2))))
+ (equal (loop for i from 0 upto 2
+ for (a b c) = (multiple-value-list (triple i))
+ append `(,a ,b ,c))
+ '(0 1 2 1 2 3 2 3 4)))
+(flet ((triple (n) (values n `(,(+ n 1)) `((,(+ n 2))))))
+ (equal (loop for i from 0 upto 2
+ for (a (b) ((c))) = (multiple-value-list (triple i))
+ append `(,a ,b ,c))
+ '(0 1 2 1 2 3 2 3 4)))
+(flet ((triple (n) (values n
+ `(,(+ n 10) ,(+ n 11) ,(+ n 12) ,(+ n 13))
+ `(,(+ n 20) ,(+ n 21) ,(+ n 22)))))
+ (equal (loop for i from 0 upto 2
+ for (a (b0 b1 b2 b3) (c0 c1 c2)) = (multiple-value-list (triple i))
+ append `(,a ,b0 ,b1 ,b2 ,b3 ,c0 ,c1 ,c2))
+ '(0 10 11 12 13 20 21 22 1 11 12 13 14 21 22 23 2 12 13 14 15 22 23 24)))
+
+(flet ((triple (n) (values n
+ `(,(+ n 10) ,(+ n 11) ,(+ n 12) ,(+ n 13))
+ `(,(+ n 200)
+ (,(+ n 210) ,(+ n 211) ,(+ n 212) ,(+ n 213))
+ ,(+ n 220)))))
+ (equal (loop for i from 0 upto 2
+ for (a (b0 b1 b2 b3) (c0 (c10 c11 c12) c2)) =
+ (multiple-value-list (triple i))
+ append `(,a ,b0 ,b1 ,b2 ,b3 ,c0 ,c10 ,c11 ,c12 ,c2))
+ '(0 10 11 12 13 200 210 211 212 220
+ 1 11 12 13 14 201 211 212 213 221
+ 2 12 13 14 15 202 212 213 214 222)))
+
+
+
+
+
+
+
+;; for-as-hash
+(let ((table (make-hash-table))
+ stack)
+ (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2))
+ (loop for k being each hash-key of table do (push k stack))
+ (null (set-difference stack '(k0 k1 k2))))
+(let ((table (make-hash-table))
+ stack)
+ (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2))
+ (loop for k being the hash-key of table do (push k stack))
+ (null (set-difference stack '(k0 k1 k2))))
+(let ((table (make-hash-table))
+ stack)
+ (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2))
+ (loop for k being each hash-keys of table do (push k stack))
+ (null (set-difference stack '(k0 k1 k2))))
+(let ((table (make-hash-table))
+ stack)
+ (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2))
+ (loop for k being the hash-keys of table do (push k stack))
+ (null (set-difference stack '(k0 k1 k2))))
+
+(let ((table (make-hash-table))
+ stack)
+ (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2))
+ (loop for k being each hash-key in table do (push k stack))
+ (null (set-difference stack '(k0 k1 k2))))
+(let ((table (make-hash-table))
+ stack)
+ (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2))
+ (loop for k being the hash-key in table do (push k stack))
+ (null (set-difference stack '(k0 k1 k2))))
+(let ((table (make-hash-table))
+ stack)
+ (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2))
+ (loop for k being each hash-keys in table do (push k stack))
+ (null (set-difference stack '(k0 k1 k2))))
+(let ((table (make-hash-table))
+ stack)
+ (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2))
+ (loop for k being the hash-keys in table do (push k stack))
+ (null (set-difference stack '(k0 k1 k2))))
+
+(let ((table (make-hash-table))
+ stack)
+ (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2))
+ (loop for k being each hash-key of table using (hash-value v)
+ do (push (list k v) stack))
+ (null (set-difference stack '((k0 v0) (k1 v1) (k2 v2)) :test #'equal)))
+(let ((table (make-hash-table))
+ stack)
+ (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2))
+ (loop for k being the hash-key of table using (hash-value v)
+ do (push (list k v) stack))
+ (null (set-difference stack '((k0 v0) (k1 v1) (k2 v2)) :test #'equal)))
+(let ((table (make-hash-table))
+ stack)
+ (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2))
+ (loop for k being each hash-keys of table using (hash-value v)
+ do (push (list k v) stack))
+ (null (set-difference stack '((k0 v0) (k1 v1) (k2 v2)) :test #'equal)))
+(let ((table (make-hash-table))
+ stack)
+ (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2))
+ (loop for k being the hash-keys of table using (hash-value v)
+ do (push (list k v) stack))
+ (null (set-difference stack '((k0 v0) (k1 v1) (k2 v2)) :test #'equal)))
+(let ((table (make-hash-table))
+ stack)
+ (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2))
+ (loop for k being each hash-key in table using (hash-value v)
+ do (push (list k v) stack))
+ (null (set-difference stack '((k0 v0) (k1 v1) (k2 v2)) :test #'equal)))
+(let ((table (make-hash-table))
+ stack)
+ (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2))
+ (loop for k being the hash-key in table using (hash-value v)
+ do (push (list k v) stack))
+ (null (set-difference stack '((k0 v0) (k1 v1) (k2 v2)) :test #'equal)))
+(let ((table (make-hash-table))
+ stack)
+ (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2))
+ (loop for k being each hash-keys in table using (hash-value v)
+ do (push (list k v) stack))
+ (null (set-difference stack '((k0 v0) (k1 v1) (k2 v2)) :test #'equal)))
+(let ((table (make-hash-table))
+ stack)
+ (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2))
+ (loop for k being the hash-keys in table using (hash-value v)
+ do (push (list k v) stack))
+ (null (set-difference stack '((k0 v0) (k1 v1) (k2 v2)) :test #'equal)))
+
+
+
+(let ((table (make-hash-table))
+ stack)
+ (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2))
+ (loop for v being each hash-value of table do (push v stack))
+ (null (set-exclusive-or stack '(v0 v1 v2))))
+(let ((table (make-hash-table))
+ stack)
+ (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2))
+ (loop for v being the hash-value of table do (push v stack))
+ (null (set-exclusive-or stack '(v0 v1 v2))))
+(let ((table (make-hash-table))
+ stack)
+ (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2))
+ (loop for v being each hash-values of table do (push v stack))
+ (null (set-exclusive-or stack '(v0 v1 v2))))
+(let ((table (make-hash-table))
+ stack)
+ (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2))
+ (loop for v being the hash-values of table do (push v stack))
+ (null (set-exclusive-or stack '(v0 v1 v2))))
+(let ((table (make-hash-table))
+ stack)
+ (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2))
+ (loop for v being each hash-value in table do (push v stack))
+ (null (set-exclusive-or stack '(v0 v1 v2))))
+(let ((table (make-hash-table))
+ stack)
+ (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2))
+ (loop for v being the hash-value in table do (push v stack))
+ (null (set-exclusive-or stack '(v0 v1 v2))))
+(let ((table (make-hash-table))
+ stack)
+ (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2))
+ (loop for v being each hash-values in table do (push v stack))
+ (null (set-exclusive-or stack '(v0 v1 v2))))
+(let ((table (make-hash-table))
+ stack)
+ (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2))
+ (loop for v being the hash-values in table do (push v stack))
+ (null (set-exclusive-or stack '(v0 v1 v2))))
+
+(let ((table (make-hash-table))
+ stack)
+ (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2))
+ (loop for v being each hash-value of table using (hash-key k)
+ do (push (list k v) stack))
+ (null (set-exclusive-or stack '((k0 v0) (k1 v1) (k2 v2)) :test #'equal)))
+(let ((table (make-hash-table))
+ stack)
+ (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2))
+ (loop for v being the hash-value of table using (hash-key k)
+ do (push (list k v) stack))
+ (null (set-exclusive-or stack '((k0 v0) (k1 v1) (k2 v2)) :test #'equal)))
+(let ((table (make-hash-table))
+ stack)
+ (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2))
+ (loop for v being each hash-values of table using (hash-key k)
+ do (push (list k v) stack))
+ (null (set-exclusive-or stack '((k0 v0) (k1 v1) (k2 v2)) :test #'equal)))
+(let ((table (make-hash-table))
+ stack)
+ (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2))
+ (loop for v being the hash-values of table using (hash-key k)
+ do (push (list k v) stack))
+ (null (set-exclusive-or stack '((k0 v0) (k1 v1) (k2 v2)) :test #'equal)))
+(let ((table (make-hash-table))
+ stack)
+ (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2))
+ (loop for v being each hash-value in table using (hash-key k)
+ do (push (list k v) stack))
+ (null (set-exclusive-or stack '((k0 v0) (k1 v1) (k2 v2)) :test #'equal)))
+(let ((table (make-hash-table))
+ stack)
+ (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2))
+ (loop for v being the hash-value in table using (hash-key k)
+ do (push (list k v) stack))
+ (null (set-exclusive-or stack '((k0 v0) (k1 v1) (k2 v2)) :test #'equal)))
+(let ((table (make-hash-table))
+ stack)
+ (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2))
+ (loop for v being each hash-values in table using (hash-key k)
+ do (push (list k v) stack))
+ (null (set-exclusive-or stack '((k0 v0) (k1 v1) (k2 v2)) :test #'equal)))
+(let ((table (make-hash-table))
+ stack)
+ (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2))
+ (loop for v being the hash-values in table using (hash-key k)
+ do (push (list k v) stack))
+ (null (set-exclusive-or stack '((k0 v0) (k1 v1) (k2 v2)) :test #'equal)))
+
+(let ((table (make-hash-table :test 'equal))
+ stack)
+ (mapc #'(lambda (k v) (setf (gethash k table) v))
+ '((k0 k00) (k1 k11) (k2 k22)) '((v0 v00) (v1 v11) (v2 v22)))
+ (loop for (k kk) being each hash-key of table do (push (list k kk) stack))
+ (null (set-exclusive-or stack '((k0 k00) (k1 k11) (k2 k22)) :test #'equal)))
+
+(let ((table (make-hash-table :test 'equal))
+ stack)
+ (mapc #'(lambda (k v) (setf (gethash k table) v))
+ '((k0 k00) (k1 k11) (k2 k22)) '((v0 v00) (v1 v11) (v2 v22)))
+ (loop :for (k kk) :being :each :hash-key :of table :using (hash-value (v vv))
+ do (push (list k kk v vv) stack))
+ (null (set-exclusive-or stack
+ '((k0 k00 v0 v00) (k1 k11 v1 v11) (k2 k22 v2 v22))
+ :test #'equal)))
+
+(let ((table (make-hash-table :test 'equal))
+ stack)
+ (mapc #'(lambda (k v) (setf (gethash k table) v))
+ '((k0 k00) (k1 k11) (k2 k22)) '((v0 v00) (v1 v11) (v2 v22)))
+ (loop :for (v vv) :being :each :hash-value :of table :using (hash-key (k kk))
+ do (push (list k kk v vv) stack))
+ (null (set-exclusive-or stack
+ '((k0 k00 v0 v00) (k1 k11 v1 v11) (k2 k22 v2 v22))
+ :test #'equal)))
+
+(let ((table (make-hash-table))
+ stack)
+ (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2))
+ (loop for k of-type symbol being each hash-key of table do (push k stack))
+ (null (set-exclusive-or stack '(k0 k1 k2))))
+
+(let ((table (make-hash-table :test 'equal))
+ stack)
+ (mapc #'(lambda (k v) (setf (gethash k table) v))
+ '((k0 k00) (k1 k11) (k2 k22)) '((v0 v00) (v1 v11) (v2 v22)))
+ (loop for (k kk) of-type symbol being each hash-key of table
+ do (push (list k kk) stack))
+ (null (set-exclusive-or stack '((k0 k00) (k1 k11) (k2 k22)) :test #'equal)))
+
+(let ((table (make-hash-table :test 'equal))
+ stack)
+ (mapc #'(lambda (k v) (setf (gethash k table) v))
+ '((k0 k00) (k1 k11) (k2 k22)) '((v0 v00) (v1 v11) (v2 v22)))
+ (loop for (k kk) of-type (symbol symbol) being each hash-key of table
+ do (push (list k kk) stack))
+ (null (set-exclusive-or stack '((k0 k00) (k1 k11) (k2 k22)) :test #'equal)))
+
+(let ((table (make-hash-table))
+ stack)
+ (mapc #'(lambda (k v) (setf (gethash k table) v)) '(0 1 2) '(v0 v1 v2))
+ (loop for k fixnum being each hash-key of table do (push k stack))
+ (null (set-exclusive-or stack '(0 1 2))))
+(let ((table (make-hash-table))
+ stack)
+ (mapc #'(lambda (k v) (setf (gethash k table) v)) '(0 1 2) '(v0 v1 v2))
+ (loop for k of-type fixnum being each hash-key of table do (push k stack))
+ (null (set-exclusive-or stack '(0 1 2))))
+(let ((table (make-hash-table))
+ stack)
+ (mapc #'(lambda (k v) (setf (gethash k table) v)) '(0.0 1.0 2.0) '(v0 v1 v2))
+ (loop for k float being each hash-key of table do (push k stack))
+ (null (set-exclusive-or stack '(0.0 1.0 2.0))))
+(let ((table (make-hash-table))
+ stack)
+ (mapc #'(lambda (k v) (setf (gethash k table) v)) '(0.0 1.0 2.0) '(v0 v1 v2))
+ (loop for k of-type float being each hash-key of table do (push k stack))
+ (null (set-exclusive-or stack '(0.0 1.0 2.0))))
+(let ((table (make-hash-table))
+ stack)
+ (mapc #'(lambda (k v) (setf (gethash k table) v)) '(0.0 1.0 2.0) '(v0 v1 v2))
+ (loop for k t being each hash-key of table do (push k stack))
+ (null (set-exclusive-or stack '(0.0 1.0 2.0))))
+(let ((table (make-hash-table))
+ stack)
+ (mapc #'(lambda (k v) (setf (gethash k table) v)) '(0.0 1.0 2.0) '(v0 v1 v2))
+ (loop for k of-type t being each hash-key of table do (push k stack))
+ (null (set-exclusive-or stack '(0.0 1.0 2.0))))
+(let ((table (make-hash-table))
+ stack)
+ (mapc #'(lambda (k v) (setf (gethash k table) v)) '(#\a #\b #\c) '(v0 v1 v2))
+ (loop for k of-type character being each hash-key of table do (push k stack))
+ (null (set-exclusive-or stack '(#\a #\b #\c))))
+(let ((table (make-hash-table))
+ stack)
+ (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2))
+ (loop for v t being each hash-value of table do (push v stack))
+ (null (set-exclusive-or stack '(v0 v1 v2))))
+(let ((table (make-hash-table))
+ stack)
+ (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2))
+ (loop for v of-type t being each hash-value of table do (push v stack))
+ (null (set-exclusive-or stack '(v0 v1 v2))))
+(let ((table (make-hash-table))
+ stack)
+ (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2))
+ (loop for v of-type symbol being each hash-value of table do (push v stack))
+ (null (set-exclusive-or stack '(v0 v1 v2))))
+(let ((table (make-hash-table))
+ stack)
+ (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(0 1 2))
+ (loop for v fixnum being each hash-value of table do (push v stack))
+ (null (set-exclusive-or stack '(0 1 2))))
+(let ((table (make-hash-table))
+ stack)
+ (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(0 1 2))
+ (loop for v of-type (integer 0 2) being each hash-value of table
+ do (push v stack))
+ (null (set-exclusive-or stack '(0 1 2))))
+(let ((table (make-hash-table))
+ stack)
+ (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(0.0 1.0 2.0))
+ (loop for v float being each hash-value of table do (push v stack))
+ (null (set-exclusive-or stack '(0.0 1.0 2.0))))
+(let ((table (make-hash-table))
+ stack)
+ (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(#\a #\b #\c))
+ (loop for v of-type base-char being each hash-value of table do (push v stack))
+ (null (set-exclusive-or stack '(#\a #\b #\c))))
+
+
+
+
+;; for-as and preposition
+(equal (let (stack)
+ (loop for a from 1 upto 3 and x = 0 then a
+ do (push x stack))
+ stack)
+ '(2 1 0))
+(equal (let (stack)
+ (loop for a from 0 upto 3
+ for x = 0 then a
+ do (push x stack))
+ stack)
+ '(3 2 1 0))
+(equal (let ((i 4)
+ stack)
+ (loop for a = 0 then (1+ a)
+ for b = 0 then a
+ for c = 0 then b
+ do (when (zerop (decf i)) (return))
+ (push (list a b c) stack))
+ stack)
+ '((2 2 2) (1 1 1) (0 0 0)))
+(equal (let ((i 5)
+ stack)
+ (loop for a = 0 then (1+ a) and b = 0 then a and c = 0 then b
+ do (when (zerop (decf i)) (return))
+ (push (list a b c) stack))
+ stack)
+ '((3 2 1) (2 1 0) (1 0 0) (0 0 0)))
+(equal (let (stack) (loop for a in '(0 1 2 3) for x = a do (push x stack)) stack)
+ '(3 2 1 0))
+(equal (let (stack) (loop for a in '(0 1 2 3) and x = 100 then a
+ do (push x stack)) stack)
+ '(2 1 0 100))
+(equal (let (stack) (loop for a on '(0 1 2 3) for x = (car a)
+ do (push x stack)) stack)
+ '(3 2 1 0))
+(equal (let (stack) (loop for a on '(0 1 2 3) and x = 100 then (car a)
+ do (push x stack)) stack)
+ '(2 1 0 100))
+(equal (let (stack) (loop for a across #(0 1 2 3) for x = a
+ do (push x stack)) stack)
+ '(3 2 1 0))
+(equal (let (stack) (loop for a across #(0 1 2 3) and x = 100 then a
+ do (push x stack)) stack)
+ '(2 1 0 100))
+(equal (loop for x from 1 to 10
+ for y = nil then x
+ collect (list x y))
+ '((1 NIL) (2 2) (3 3) (4 4) (5 5) (6 6) (7 7) (8 8) (9 9) (10 10)))
+(equal (loop for x from 1 to 10
+ and y = nil then x
+ collect (list x y))
+ '((1 NIL) (2 1) (3 2) (4 3) (5 4) (6 5) (7 6) (8 7) (9 8) (10 9)))
+(= 280 (loop for a upfrom 0 upto 9
+ and b downfrom 9 downto 0
+ and c from 0 to 9
+ and d from 10 above 0
+ and e below 10
+ and f to 9
+ summing (+ a b c d e f)))
+(equal (loop for a from 1 upto 9
+ as b = 0 then a
+ as c = -1 then b
+ as d = -2 then c
+ as e = -3 then d
+ as f = -4 then e
+ collecting (list a b c d e f))
+ '((1 0 -1 -2 -3 -4) (2 2 2 2 2 2) (3 3 3 3 3 3) (4 4 4 4 4 4)
+ (5 5 5 5 5 5) (6 6 6 6 6 6) (7 7 7 7 7 7) (8 8 8 8 8 8) (9 9 9 9 9 9)))
+(equal (loop for a from 1 upto 9
+ and b = 0 then a
+ and c = -1 then b
+ and d = -2 then c
+ and e = -3 then d
+ and f = -4 then e
+ collecting (list a b c d e f))
+ '((1 0 -1 -2 -3 -4) (2 1 0 -1 -2 -3) (3 2 1 0 -1 -2) (4 3 2 1 0 -1)
+ (5 4 3 2 1 0) (6 5 4 3 2 1) (7 6 5 4 3 2) (8 7 6 5 4 3) (9 8 7 6 5 4)))
+(equal (loop for a from 1 upto 9
+ and b = 0 then a
+ and c = -1 then b
+ and d = -2 then c
+ and e = -3 then d
+ and f = -4 then e
+ for i from 9 downto 1
+ and j = 8 then i
+ and k = 7 then j
+ and l = 6 then k
+ and m = 5 then l
+ and n = 4 then m
+ collecting (list a b c d e f)
+ collecting (list i j k l m n))
+ '((1 0 -1 -2 -3 -4) (9 8 7 6 5 4) (2 1 0 -1 -2 -3) (8 9 8 7 6 5)
+ (3 2 1 0 -1 -2)
+ (7 8 9 8 7 6) (4 3 2 1 0 -1) (6 7 8 9 8 7) (5 4 3 2 1 0) (5 6 7 8 9 8)
+ (6 5 4 3 2 1) (4 5 6 7 8 9) (7 6 5 4 3 2) (3 4 5 6 7 8) (8 7 6 5 4 3)
+ (2 3 4 5 6 7) (9 8 7 6 5 4) (1 2 3 4 5 6)))
+
+(let (stack)
+ (loop for a on (progn (push 1 stack) '(0 1 2))
+ and b across (progn (push 2 stack) "abc"))
+ (equal '(2 1) stack))
+
+
+
+;; ambiguous cases
+(equal (let ((a 5))
+ (loop for a from 0 upto 5
+ and b from a downto 0
+ collect (list a b)))
+ '((0 5) (1 4) (2 3) (3 2) (4 1) (5 0)))
+(equal (let ((a :outer))
+ (loop for a from 0 upto 5
+ and b in (list a)
+ collect (list a b)))
+ '((0 :outer)))
+(equal (let ((b 0))
+ (loop for a from b upto 5
+ and b in '(a b c)
+ collecting (list a b)))
+ '((0 a) (1 b) (2 c)))
+
+
+;; with-clause
+(zerop (loop with x = 0 do (return x)))
+(equal (let (stack)
+ (loop with x = 1 for a from x to 3 by 1 do (push a stack)) stack)
+ '(3 2 1))
+(equal (loop with a = 1
+ with b = (+ a 2)
+ with c = (+ b 3)
+ return (list a b c))
+ '(1 3 6))
+(equal (loop with a = 1
+ and b = 2
+ and c = 3
+ return (list a b c))
+ '(1 2 3))
+(let ((a 5)
+ (b 10))
+ (equal (loop with a = 1
+ and b = (+ a 2)
+ and c = (+ b 3)
+ return (list a b c))
+ '(1 7 13)))
+(equal (loop with (a b c) of-type (float integer float)
+ return (list a b c))
+ '(0.0 0 0.0))
+(equal (loop with (a b c) of-type float
+ return (list a b c))
+ '(0.0 0.0 0.0))
+(flet ((triple () (values 0 1 2)))
+ (equal (loop with (a b c) = (multiple-value-list (triple))
+ do (return (list a b c)))
+ '(0 1 2)))
+(flet ((triple () (values 0 '(1) 2)))
+ (equal (loop with (a (b) c) = (multiple-value-list (triple))
+ do (return (list a b c)))
+ '(0 1 2)))
+(flet ((triple () (values 0 '(0 1 2) 2)))
+ (equal (loop with (a (nil b) c d) = (multiple-value-list (triple))
+ do (return (list a b c d)))
+ '(0 1 2 nil)))
+
+(flet ((triple () (values 0 1 2)))
+ (equal (loop with (a b c) fixnum = (multiple-value-list (triple))
+ do (return (list a b c)))
+ '(0 1 2)))
+(flet ((triple () (values 0 '(1) 2)))
+ (equal (loop with (a (b) c) of-type (fixnum (fixnum) fixnum) =
+ (multiple-value-list (triple))
+ do (return (list a b c)))
+ '(0 1 2)))
+
+
+
+;; binding (preferable)
+(equal (loop for a from 0 upto 5
+ for b from a downto -5
+ collect (list a b))
+ '((0 0) (1 -1) (2 -2) (3 -3) (4 -4) (5 -5)))
+(equal (loop for a from 0 upto 5
+ with x = a
+ collect (list a x))
+ '((0 0) (1 0) (2 0) (3 0) (4 0) (5 0)))
+
+
+;; initial-final-clause
+(zerop (loop initially (return 0)))
+(zerop (loop repeat 2 finally (return 0)))
+(= (loop with x = 0 initially (incf x) return x) 1)
+(= (loop with x = 0 for a from 0 below 3
+ initially (incf x) finally (return (incf x)))
+ 2)
+(= (loop with x = 0 for a from 0 below 3
+ initially (incf x) (incf x) finally (return (incf x)))
+ 3)
+(= (loop with x = 0 for a from 0 upto 3
+ initially (incf x) finally (incf x) (return (incf x)))
+ 3)
+(= (loop with x = 0 for a from 0 upto 3
+ initially (incf x) (incf x) finally (incf x) (return (incf x)))
+ 4)
+(= (loop with x = 0 for a from 0 below 3
+ do (incf x)
+ initially (incf x) (incf x) finally (incf x) (return (incf x)))
+ 7)
+
+; #-CLISP
+; ;;Bruno: unfounded expectations about the value of for-as iteration
+; ;;variables in INITIALLY and FINALLY clauses
+; ;;(See http://www.cliki.net/Proposed%20ANSI%20Revisions%20and%20Clarifications
+; ;;for a discussion of this spec weakness.)
+; (equal (let (val) (loop for a downto 3 from 100
+; for b in '(x y z) and c = 50 then (1+ c)
+; initially (setq val (list a b c))
+; finally (setq val (append (list a b c) val)))
+; val)
+; '(97 z 52 100 x 50))
+(= 33 (loop with x = 2
+ initially (setq x (* x 3))
+ for i below 3
+ initially (setq x (* x 5))
+ do (incf x i)
+ finally (return x)))
+(equal (loop with x = nil
+ repeat 2
+ initially (push 'initially0 x)
+ finally (push 'finally0 x)
+ initially (push 'initially1 x)
+ finally (push 'finally1 x)
+ do (push 'body0 x)
+ finally (push 'finally2 x) (push 'finally3 x)
+ finally (return (reverse x))
+ initially (push 'initially2 x) (push 'initially3 x)
+ do (push 'body1 x))
+ '(initially0 initially1 initially2 initially3
+ body0 body1 body0 body1
+ finally0 finally1 finally2 finally3))
+
+
+
+;; do-clause
+(equal (loop with i = 3
+ with stack = nil
+ do (when (zerop i) (loop-finish))
+ (decf i)
+ (push i stack)
+ finally (return stack))
+ '(0 1 2))
+(equal (loop with i = 3
+ with stack = nil
+ doing (when (zerop i) (loop-finish))
+ (decf i)
+ (push i stack)
+ finally (return stack))
+ '(0 1 2))
+(= (loop with x = 10 do (return x)) 10)
+(= (loop with x = 10 doing (return x)) 10)
+(= (loop with x = 0 do (incf x) doing (incf x) (return x)) 2)
+(= (loop with x = 0 do (incf x) doing (incf x) do (return x)) 2)
+(= (loop with x = 0 do (incf x) (incf x) doing (return x)) 2)
+(= (loop with x = 0 do (incf x) (incf x) (incf x) doing (incf x) (return x)) 4)
+
+
+
+;; conditional-clauses
+(let ((odd 0)
+ (even 0))
+ (and (null (loop for a from 1 upto 10
+ if (oddp a) do (incf odd) else do (incf even) end))
+ (= 5 odd even)))
+(let ((odd+ 0) (even+ 0) (odd- 0) (even- 0))
+ (and (null (loop for a from -10 upto 10
+ if (oddp a) if (> a 0) do (incf odd+) else do (incf odd-) end
+ else if (> a 0) do (incf even+) else do (incf even-)))
+ (= 5 odd+ even+ odd-)
+ (= even- 6)))
+(let ((odd+ 0) (even+ 0) (odd- 0) (even- 0))
+ (and (null (loop for a from -10 upto 10
+ unless (zerop a)
+ if (oddp a)
+ if (> a 0) do (incf odd+) else do (incf odd-) end
+ else
+ if (> a 0) do (incf even+) else do (incf even-)))
+ (= 5 odd+ even+ odd- even-)))
+(let ((odd+ 0) (even+ 0) (odd- 0) (even- 0))
+ (and (null (loop for a from -10 upto 10
+ if (not (zerop a))
+ when (oddp a)
+ unless (< a 0) do (incf odd+) else do (incf odd-) end
+ else
+ unless (<= a 0) do (incf even+) else do (incf even-)))
+ (= 5 odd+ even+ odd- even-)))
+(handler-bind ((simple-error #'(lambda (c) (declare (ignore c)) (continue))))
+ (eq 'continued
+ (loop for item in '(1 2 3 a 4 5)
+ when (not (numberp item))
+ return (or (cerror "ignore this error" "non-numeric value: ~s" item)
+ 'continued))))
+(equal (loop for i in '(1 324 2345 323 2 4 235 252)
+ when (oddp i) collect i into odd-numbers
+ else ; I is even.
+ collect i into even-numbers
+ finally
+ (return (list odd-numbers even-numbers)))
+ '((1 2345 323 235) (324 2 4 252)))
+(equal (loop for i in '(1 2 3 4 5 6)
+ when (and (> i 3) i)
+ collect it)
+ '(4 5 6))
+(= 4 (loop for i in '(1 2 3 4 5 6)
+ when (and (> i 3) i)
+ return it))
+(equal (let ((list '(0 3.0 apple 4 5 9.8 orange banana)))
+ (loop for i in list
+ when (numberp i)
+ when (floatp i)
+ collect i into float-numbers
+ else ; Not (floatp i)
+ collect i into other-numbers
+ else ; Not (numberp i)
+ when (symbolp i)
+ collect i into symbol-list
+ else ; Not (symbolp i)
+ do (error "found a funny value in list ~S, value ~S~%" list i)
+ finally (return (list float-numbers other-numbers symbol-list))))
+ '((3.0 9.8) (0 4 5) (APPLE ORANGE BANANA)))
+(equal (loop for i below 5 if (oddp i) collecting i) '(1 3))
+(equal (loop for i below 5 when (oddp i) collecting i) '(1 3))
+(equal (loop for i below 5
+ if (oddp i) collecting i else collecting (list i))
+ '((0) 1 (2) 3 (4)))
+(equal (loop for i below 5
+ when (oddp i) collecting i else collecting (list i))
+ '((0) 1 (2) 3 (4)))
+(equal (loop for i below 5 unless (evenp i) collecting i) '(1 3))
+(equal (loop for i below 5
+ unless (evenp i) collecting i else collecting (list i))
+ '((0) 1 (2) 3 (4)))
+
+(equal (loop for i below 5 if (oddp i) collecting i end) '(1 3))
+(equal (loop for i below 5 when (oddp i) collecting i end) '(1 3))
+(equal (loop for i below 5
+ if (oddp i) collecting i else collecting (list i) end)
+ '((0) 1 (2) 3 (4)))
+(equal (loop for i below 5
+ when (oddp i) collecting i else collecting (list i) end)
+ '((0) 1 (2) 3 (4)))
+(equal (loop for i below 5 unless (evenp i) collecting i end) '(1 3))
+(equal (loop for i below 5
+ unless (evenp i) collecting i else collecting (list i) end)
+ '((0) 1 (2) 3 (4)))
+
+(equal (loop for (a b) in '((0 0) (0 1))
+ if (zerop a) if (zerop b) collect '0-0 else collect '0-1)
+ '(|0-0| |0-1|))
+(equal (loop for (a b) in '((0 0) (0 1))
+ when (zerop a) if (zerop b) collect '0-0 else collect '0-1)
+ '(|0-0| |0-1|))
+(equal (loop for (a b) in '((0 0) (0 1) (1 0) (1 1))
+ if (zerop a) if (= b 1) collect '0-1 end
+ else collect '1-X)
+ '(|0-1| |1-X| |1-X|))
+(equal (loop for (a b) in '((0 0) (0 1) (1 0) (1 1))
+ when (zerop a) if (= b 1) collect '0-1 end
+ else collect '1-X)
+ '(|0-1| |1-X| |1-X|))
+(equal (loop for (a b) in '((0 0) (0 1))
+ unless (not (zerop a)) if (zerop b) collect '0-0 else collect '0-1)
+ '(|0-0| |0-1|))
+(equal (loop for (a b) in '((0 0) (0 1) (1 0) (1 1))
+ unless (not (zerop a)) if (= b 1) collect '0-1 end
+ else collect '1-X)
+ '(|0-1| |1-X| |1-X|))
+
+(equal (loop for (a b c) in '((0 0 0) (0 0 1)
+ (0 1 0) (0 1 1)
+ (1 0 0) (1 0 1)
+ (1 1 0) (1 1 1))
+ if (zerop a)
+ if (zerop b)
+ if (zerop c) collect 'x0-0-0 else collect 'x0-0-1
+ else if (zerop c) collect 'x0-1-0 else collect 'x0-1-1
+ else if (zerop b)
+ if (zerop c) collect 'x1-0-0 else collect 'x1-0-1
+ else if (zerop c) collect 'x1-1-0 else collect 'x1-1-1)
+ '(x0-0-0 x0-0-1 x0-1-0 x0-1-1 x1-0-0 x1-0-1 x1-1-0 x1-1-1))
+
+(equal (loop for a below 10
+ if (oddp a) collect a into bag and sum a into odd
+ else collect (list a) into bag and sum a into even
+ finally (return (list bag odd even)))
+ '(((0) 1 (2) 3 (4) 5 (6) 7 (8) 9) 25 20))
+
+(equal (loop for a below 10
+ if (oddp a)
+ collect a and collect (list a) and collect (list (list a))
+ else collect a)
+ '(0 1 (1) ((1)) 2 3 (3) ((3)) 4 5 (5) ((5)) 6 7 (7) ((7)) 8 9 (9) ((9))))
+
+(let ((c0 0) (c1 0))
+ (and (equal (loop for a below 10
+ when (oddp a)
+ collect a and do (incf c0) (decf c1) and collect (list a))
+ '(1 (1) 3 (3) 5 (5) 7 (7) 9 (9)))
+ (= c0 5)
+ (= c1 -5)))
+
+
+
+
+
+
+;; return-clause
+(zerop (loop return 0))
+(= (loop for a from 0 below 3 when (and (oddp a) a) return it) 1)
+(eq (loop for a in '(nil nil ok nil ok2) when a return it) 'ok)
+(eq 'ok (loop with a = 'ok if a return it else return it))
+(equal (multiple-value-list (loop return (values 0 1 2))) '(0 1 2))
+(let ((flag nil))
+ (and (eq t (loop for a below 3 when (oddp a) return t finally (setq flag t)))
+ (not flag)))
+(equal (loop for a in '(0 1 2 3) and b in '(3 2 1 0)
+ if (and (oddp a) a)
+ if (and (evenp b) b)
+ when (and (= (* a b) 0) (list a b)) return it)
+ '(3 0))
+
+
+;;; list-accumulation-clauses
+
+;; collect
+(equal (loop for a from 0 below 3 collect a) '(0 1 2))
+(equal (loop for a from 0 below 3 collecting a) '(0 1 2))
+(equal (loop for a in '(nil 0 nil nil 1 2 nil 3 nil 4)
+ when a collect it) '(0 1 2 3 4))
+(equal (loop for a in '(nil 0 nil nil 1 2 nil 3 nil 4)
+ when a collecting it) '(0 1 2 3 4))
+(equal (loop for a in '(nil 0 nil nil 1 2 nil 3 nil 4)
+ when a collect it into bag
+ finally (return bag))
+ '(0 1 2 3 4))
+(equal (loop for a in '(nil 0 nil nil 1 2 nil 3 nil 4)
+ when a collecting it into bag
+ finally (return bag))
+ '(0 1 2 3 4))
+(equal (loop for a below 10
+ if (oddp a) collect a into odd else collect a into even end
+ finally (return (list odd even)))
+ '((1 3 5 7 9) (0 2 4 6 8)))
+(equal (loop for a below 3
+ for b on '(2 1 0)
+ collecting a
+ appending b)
+ '(0 2 1 0 1 1 0 2 0))
+
+
+
+(= 15 (loop for i of-type fixnum in '(1 2 3 4 5) sum i))
+(= 22.4 (let ((series '(1.2 4.3 5.7))) (loop for v in series sum (* 2.0 v))))
+(equal (loop for a below 10
+ if (oddp a) collect a into odd and sum a into sum
+ finally (return (list odd sum)))
+ '((1 3 5 7 9) 25))
+
+(equal (loop for a below 10
+ if (oddp a) collect a into odd and sum a into odd-sum
+ else collect a into even and sum a into even-sum
+ end
+ finally (return (list odd odd-sum even even-sum)))
+ '((1 3 5 7 9) 25 (0 2 4 6 8) 20))
+(equal (loop for i in '(bird 3 4 turtle (1 . 4) horse cat)
+ when (symbolp i) collect i)
+ '(BIRD TURTLE HORSE CAT))
+(equal (loop for i below 3
+ for j upto 2
+ collecting i
+ collecting j)
+ '(0 0 1 1 2 2))
+(equal (loop for a from -10 upto 0
+ collecting a)
+ '(-10 -9 -8 -7 -6 -5 -4 -3 -2 -1 0))
+(null (loop for a from -10 upto 0
+ collecting a into list)) ;; not return automatically
+
+
+;; append
+(let* ((zero (list 0))
+ (one (list 1))
+ (two (list 2))
+ (list (list zero one two)))
+ (and (equal (loop for a in list append a) '(0 1 2))
+ (equal zero '(0))
+ (equal one '(1))
+ (equal two '(2))))
+(equal (loop for a in '(nil (1) nil (2)) when a append a) '(1 2))
+(equal (loop for a in '(nil (1) nil (2)) when a appending a) '(1 2))
+(null (loop for a in '(nil (1) nil (2)) when a append a into x))
+(null (loop for a in '(nil (1) nil (2)) when a appending a into x))
+(equal (loop for a in '(nil (1) nil (2)) when a append a into x
+ finally (return x)) '(1 2))
+(equal (loop for a in '(nil (1) nil (2)) when a appending a into x
+ finally (return x)) '(1 2))
+(equal (loop for a in '(nil (1) nil (2)) when a append it) '(1 2))
+(equal (loop for a in '(nil (1) nil (2)) when a appending it) '(1 2))
+(equal (loop for a on (list 0 1 2 3 4) when (oddp (car a)) append a)
+ '(1 2 3 4 3 4))
+(equal (loop for a on (list 0 1 2 3 4) when (oddp (car a)) appending a)
+ '(1 2 3 4 3 4))
+(equal (loop for x in '((a) (b) ((c))) append x) '(A B (C)))
+
+;; nconc
+(let ((list (list (list 0) (list 1) (list 2) (list 3))))
+ (and (equal (loop for a in list nconc a) '(0 1 2 3))
+ (equal list '((0 1 2 3) (1 2 3) (2 3) (3)))))
+(let ((list (list (list 0) (list 1) (list 2) (list 3))))
+ (and (equal (loop for a in list nconcing a) '(0 1 2 3))
+ (equal list '((0 1 2 3) (1 2 3) (2 3) (3)))))
+(let ((list (list nil (list 0) nil nil (list 1) (list 2) nil (list 3) nil)))
+ (and (equal (loop for a in list when a nconc it) '(0 1 2 3))
+ (equal list '(nil (0 1 2 3) nil nil (1 2 3) (2 3) nil (3) nil))))
+(let ((list (list nil (list 0) nil nil (list 1) (list 2) nil (list 3) nil)))
+ (and (equal (loop for a in list when a nconcing it) '(0 1 2 3))
+ (equal list '(nil (0 1 2 3) nil nil (1 2 3) (2 3) nil (3) nil))))
+(null (loop for a in (list (list (list 0) (list 1) (list 2) (list 3)))
+ nconc a into x))
+(null (loop for a in (list (list (list 0) (list 1) (list 2) (list 3)))
+ nconcing a into x))
+(let ((list (list (list 0) (list 1) (list 2) (list 3))))
+ (and (equal (loop for a in list nconc a into x finally (return x)) '(0 1 2 3))
+ (equal list '((0 1 2 3) (1 2 3) (2 3) (3)))))
+(let ((list (list (list 0) (list 1) (list 2) (list 3))))
+ (and (equal (loop for a in list nconcing a into x finally (return x)) '(0 1 2 3))
+ (equal list '((0 1 2 3) (1 2 3) (2 3) (3)))))
+(equal (loop for i upfrom 0 as x in '(a b (c))
+ nconc (if (evenp i) (list x) nil))
+ '(A (C)))
+
+
+(equal (loop for a in '(0 3 6)
+ for b in '((1) (4) (7))
+ for c in (copy-tree '((2) (5) (8)))
+ collecting a
+ appending b
+ nconcing c)
+ '(0 1 2 3 4 5 6 7 8))
+(equal (loop for a in '(0 3 6)
+ for b in (copy-tree '((1) (4) (7)))
+ for c in (list (list 2) (list 5) (list 8))
+ collecting a
+ nconcing b
+ appending c)
+ '(0 1 2 3 4 5 6 7 8))
+(equal (loop for a in '((0) (3) (6))
+ for b in (copy-tree '((1) (4) (7)))
+ for c in '(2 5 8)
+ appending a
+ nconcing b
+ collecting c)
+ '(0 1 2 3 4 5 6 7 8))
+(equal (loop for a in '((0) (3) (6))
+ for b in '(1 4 7)
+ for c in (copy-tree '((2) (5) (8)))
+ appending a
+ collecting b
+ nconcing c)
+ '(0 1 2 3 4 5 6 7 8))
+(equal (loop for a in (copy-tree '((0) (3) (6)))
+ for b in '(1 4 7)
+ for c in '((2) (5) (8))
+ nconcing a
+ collecting b
+ appending c)
+ '(0 1 2 3 4 5 6 7 8))
+(equal (loop for a in (copy-tree '((0) (3) (6)))
+ for b in '((1) (4) (7))
+ for c in '(2 5 8)
+ nconcing a
+ appending b
+ collecting c)
+ '(0 1 2 3 4 5 6 7 8))
+(equal (loop for a in '(0 6)
+ for b in '((1 2 3) (7 8 9))
+ for c in (copy-tree '((4 5) (10)))
+ collect a
+ append b
+ nconc c)
+ '(0 1 2 3 4 5 6 7 8 9 10))
+(null (loop for a in '()
+ for b in '((1 2 3) (7 8 9))
+ for c in (copy-tree '((4 5) (10)))
+ collect a
+ append b
+ nconc c))
+(equal (loop for a in '(0 3 6)
+ for b in '((1) (4) (7))
+ for c in (copy-tree '((2) (5) (8)))
+ collecting a into list
+ appending b into list
+ nconcing c into list
+ finally (return list))
+ '(0 1 2 3 4 5 6 7 8))
+(equal (loop for a in '(0 3 6)
+ for b in '(1 4 7)
+ for c in (copy-tree '((2) (5) (8)))
+ collect a collect b nconc c)
+ '(0 1 2 3 4 5 6 7 8))
+
+(= 60 (loop for a upto 10 summing a when (oddp a) counting it))
+(= 220 (loop for a upto 10
+ for b downfrom 20
+ sum a
+ summing b))
+(= 60 (loop for a upto 10
+ summing a into sum
+ when (oddp a) counting it into sum
+ finally (return sum)))
+(= 21 (loop for a in '(a 1 b 3 c 4 5 x 2 y z)
+ if (and (numberp a) a) summing it
+ else counting 1))
+
+
+(= 5 (loop for a from 3 to 5 maximizing a minimizing a))
+(= 3 (loop for a upto 3 for b from 6 downto 3 maximize a minimize b))
+(equal (loop for a in '(0 -1 1 -2 2 -3 3)
+ maximize a into plus
+ minimize a into minus
+ finally (return (list minus plus)))
+ '(-3 3))
+
+(equal (let (val)
+ (list (loop for a below 10
+ collecting a
+ summing a into sum
+ counting a into count
+ maximizing a into max
+ minimizing a into min
+ finally (setq val (list sum count max min)))
+ val))
+ '((0 1 2 3 4 5 6 7 8 9) (45 10 9 0)))
+(eq 'ok (loop for a below 3 collecting a
+ finally (return 'ok)))
+(let ((flag nil))
+ (and (equal (loop for a below 3 collecting a
+ finally (setq flag t))
+ '(0 1 2))
+ flag))
+(eq 'ok (loop for a below 3 appending (list a)
+ finally (return 'ok)))
+(eq 'ok (loop for a below 3 nconcing (list a)
+ finally (return 'ok)))
+
+
+
+
+
+
+
+;; numeric-accumulation-clauses
+;; count
+(= 5 (loop for a from 1 upto 10
+ counting (evenp a)))
+(= (loop for a downfrom 10 above 0 count a) 10)
+(= (loop for a downfrom 10 above 0 counting a) 10)
+(null (loop for a downfrom 10 above 0 count a into x))
+(null (loop for a downfrom 10 above 0 counting a into x))
+(= (loop for a downfrom 10 above 0 count a into x finally (return x)) 10)
+(= (loop for a downfrom 10 above 0 counting a into x finally (return x)) 10)
+(= (loop for a in '(nil a nil nil b nil c d e nil nil nil nil f)
+ when a count it) 6)
+(= (loop for a in '(nil a nil nil b nil c d e nil nil nil nil f)
+ when a counting it) 6)
+(null (loop for a in '(nil a nil nil b nil c d e nil nil nil nil f)
+ when a count it into x))
+(null (loop for a in '(nil a nil nil b nil c d e nil nil nil nil f)
+ when a counting it into x))
+(= (loop for a in '(nil a nil nil b nil c d e nil nil nil nil f)
+ when a count it into x finally (return x)) 6)
+(= (loop for a in '(nil a nil nil b nil c d e nil nil nil nil f)
+ when a counting it into x finally (return x)) 6)
+(= 5 (loop for i in '(a b nil c nil d e) count i))
+
+;; sum
+(= (loop for a to 10 sum a) 55)
+(= (loop for a to 10 summing a) 55)
+(= (loop for a in '(0 nil 1 nil 2 3 nil 4 5 6 7 nil 8 9 10 nil)
+ if a sum it) 55)
+(= (loop for a in '(0 nil 1 nil 2 3 nil 4 5 6 7 nil 8 9 10 nil)
+ if a summing it) 55)
+(loop for a to 10
+ sum a into sum
+ if (oddp a) sum a into odd
+ else sum a into even
+ finally (return (= sum (+ odd even))))
+(loop for a to 10
+ summing a into sum
+ if (oddp a) sum a into odd
+ else summing a into even
+ finally (return (= sum (+ odd even))))
+(= 15 (loop for a downfrom 5 to 1
+ summing a))
+(null (loop for a downfrom 5 to 1
+ summing a into n)) ;; not return automatically
+
+(= (loop for i from 1 to 4
+ sum i fixnum
+ count t fixnum)
+ 14)
+
+
+;; maximize
+(= 5 (loop for i in '(2 1 5 3 4) maximize i))
+(= (loop for a in '(0 5 9) maximize a) 9)
+(= (loop for a in '(0 5 9) maximizing a) 9)
+(= (loop for a in '(0 9 5) maximize a) 9)
+(= (loop for a in '(0 9 5) maximizing a) 9)
+(= (loop for a in '(9 0 5) maximize a) 9)
+(= (loop for a in '(9 0 5) maximizing a) 9)
+(= (loop for a in '(9 0 9 5) maximize a) 9)
+(= (loop for a in '(9 0 9 5) maximizing a) 9)
+(let (list)
+ (loop (when (= (first (push (random 10) list)) 9) (return)))
+ (= (loop for a in list maximize a) 9))
+(let (list)
+ (loop (when (= (first (push (random 10) list)) 9) (return)))
+ (= (loop for a in list maximizing a) 9))
+(let (list)
+ (loop (when (= (first (push (random 100) list)) 99) (return)))
+ (= (loop for a in list maximize a) 99))
+(let (list)
+ (loop (when (= (first (push (random 100) list)) 99) (return)))
+ (= (loop for a in list maximizing a) 99))
+(let (list)
+ (loop (when (= (first (push (random 1000) list)) 999) (return)))
+ (= (loop for a in list maximize a) 999))
+(let (list)
+ (loop (when (= (first (push (random 1000) list)) 999) (return)))
+ (= (loop for a in list maximizing a) 999))
+(null (loop for a in '(0 5 9) maximize a into max))
+(null (loop for a in '(0 5 9) maximizing a into max))
+(= (loop for a in '(0 5 9) maximize a into max finally (return max)) 9)
+(= (loop for a in '(0 5 9) maximizing a into max finally (return max)) 9)
+(= (loop for a in '(0 5 9) maximize a into max of-type integer
+ finally (return max)) 9)
+(= (loop for a in '(0 5 9) maximizing a into max of-type integer
+ finally (return max)) 9)
+(= (loop for a in '(0.0 5.0 9.0) maximize a into max float
+ finally (return max)) 9.0)
+(= (loop for a in '(0.0 5.0 9.0) maximizing a into max float
+ finally (return max)) 9.0)
+(let ((series '(1.2 4.3 5.7)))
+ (= 6 (loop for v in series maximize (round v) of-type fixnum)))
+
+;; minimize
+(= 1 (loop for i in '(2 1 5 3 4) minimize i))
+(= (loop for a in '(0 5 9) minimize a) 0)
+(= (loop for a in '(0 5 9) minimizing a) 0)
+(= (loop for a in '(9 5 0) minimize a) 0)
+(= (loop for a in '(9 5 0) minimizing a) 0)
+(= (loop for a in '(9 0 5) minimize a) 0)
+(= (loop for a in '(9 0 5) minimizing a) 0)
+(= (loop for a in '(9 0 9 0 5 0) minimizing a) 0)
+(= (loop for a in '(9 0 9 0 5 0) minimizing a) 0)
+(= (loop for a in '(1 5 9) minimize a) 1)
+(= (loop for a in '(1 5 9) minimizing a) 1)
+(= (loop for a in '(9 5 1) minimize a) 1)
+(= (loop for a in '(9 5 1) minimizing a) 1)
+(= (loop for a in '(9 1 5) minimize a) 1)
+(= (loop for a in '(9 1 5) minimizing a) 1)
+(= (loop for a in '(9 1 9 1 5 1) minimizing a) 1)
+(= (loop for a in '(9 1 9 1 5 1) minimizing a) 1)
+(let (list)
+ (loop (when (zerop (first (push (random 10) list))) (return)))
+ (zerop (loop for a in list minimize a)))
+(let (list)
+ (loop (when (zerop (first (push (random 10) list))) (return)))
+ (zerop (loop for a in list minimizing a)))
+(let (list)
+ (loop (when (zerop (first (push (random 100) list))) (return)))
+ (zerop (loop for a in list minimize a)))
+(let (list)
+ (loop (when (zerop (first (push (random 100) list))) (return)))
+ (zerop (loop for a in list minimizing a)))
+(let (list)
+ (loop (when (zerop (first (push (random 1000) list))) (return)))
+ (zerop (loop for a in list minimize a)))
+(let (list)
+ (loop (when (zerop (first (push (random 1000) list))) (return)))
+ (zerop (loop for a in list minimizing a)))
+(null (loop for a in '(0 5 9) minimize a into min))
+(null (loop for a in '(0 5 9) minimizing a into min))
+(zerop (loop for a in '(0 5 9) minimize a into min finally (return min)))
+(zerop (loop for a in '(0 5 9) minimizing a into min finally (return min)))
+(zerop (loop for a in '(0 5 9) minimize a into min of-type integer
+ finally (return min)))
+(zerop (loop for a in '(0 5 9) minimizing a into min of-type integer
+ finally (return min)))
+(= (loop for a in '(0.0 5.0 9.0) minimize a into min float
+ finally (return min)) 0.0)
+(= (loop for a in '(0.0 5.0 9.0) minimizing a into min float
+ finally (return min)) 0.0)
+(= 1 (let ((series '(1.2 4.3 5.7)))
+ (loop for v of-type float in series
+ minimize (round v) into result of-type fixnum
+ finally (return result))))
+(= 10 (loop for a in '(nil 1 nil 2 nil 3 nil 4)
+ when a summing it fixnum))
+(= 10 (loop for a in '(nil 1 nil 2 nil 3 nil 4)
+ when a summing it of-type fixnum))
+(= 10.0 (loop for a in '(nil 1.0 nil 2.0 nil 3.0 nil 4.0)
+ when a summing it float))
+(= 10.0 (loop for a in '(nil 1.0 nil 2.0 nil 3.0 nil 4.0)
+ when a summing it of-type float))
+(= 10 (loop for a in '(nil 1 nil 2 nil 3 nil 4)
+ when a summing it of-type number))
+(= 10 (loop for a in '(nil 1 nil 2 nil 3 nil 4)
+ when a summing it of-type (integer 0)))
+
+(= 10 (loop for a in '(nil 1 nil 2 nil 3 nil 4)
+ when a summing a fixnum))
+(= 10 (loop for a in '(nil 1 nil 2 nil 3 nil 4)
+ when a summing a of-type fixnum))
+(= 10.0 (loop for a in '(nil 1.0 nil 2.0 nil 3.0 nil 4.0)
+ when a summing a float))
+(= 10.0 (loop for a in '(nil 1.0 nil 2.0 nil 3.0 nil 4.0)
+ when a summing a of-type float))
+(= 10 (loop for a in '(nil 1 nil 2 nil 3 nil 4)
+ when a summing a of-type number))
+(= 10 (loop for a in '(nil 1 nil 2 nil 3 nil 4)
+ when a summing a of-type (integer 0)))
+
+(= 10 (loop for a in '(nil 1 nil 2 nil 3 nil 4)
+ when a summing a into sum fixnum finally (return sum)))
+(= 10 (loop for a in '(nil 1 nil 2 nil 3 nil 4)
+ when a summing a into sum of-type fixnum finally (return sum)))
+(= 10.0 (loop for a in '(nil 1.0 nil 2.0 nil 3.0 nil 4.0)
+ when a summing a into sum float finally (return sum)))
+(= 10.0 (loop for a in '(nil 1.0 nil 2.0 nil 3.0 nil 4.0)
+ when a summing a into sum of-type float finally (return sum)))
+(= 10 (loop for a in '(nil 1 nil 2 nil 3 nil 4)
+ when a summing a into sum of-type number finally (return sum)))
+(= 10 (loop for a in '(nil 1 nil 2 nil 3 nil 4)
+ when a summing a into sum of-type (integer 0) finally (return sum)))
+
+
+(= 10 (loop for a in '(nil 1 nil 2 nil 3 nil 4)
+ when a sum it fixnum))
+(= 10 (loop for a in '(nil 1 nil 2 nil 3 nil 4)
+ when a sum it of-type fixnum))
+(= 10.0 (loop for a in '(nil 1.0 nil 2.0 nil 3.0 nil 4.0)
+ when a sum it float))
+(= 10.0 (loop for a in '(nil 1.0 nil 2.0 nil 3.0 nil 4.0)
+ when a sum it of-type float))
+(= 10 (loop for a in '(nil 1 nil 2 nil 3 nil 4)
+ when a sum it of-type number))
+(= 10 (loop for a in '(nil 1 nil 2 nil 3 nil 4)
+ when a sum it of-type (integer 0)))
+
+(= 10 (loop for a in '(nil 1 nil 2 nil 3 nil 4)
+ when a sum a fixnum))
+(= 10 (loop for a in '(nil 1 nil 2 nil 3 nil 4)
+ when a sum a of-type fixnum))
+(= 10.0 (loop for a in '(nil 1.0 nil 2.0 nil 3.0 nil 4.0)
+ when a sum a float))
+(= 10.0 (loop for a in '(nil 1.0 nil 2.0 nil 3.0 nil 4.0)
+ when a sum a of-type float))
+(= 10 (loop for a in '(nil 1 nil 2 nil 3 nil 4)
+ when a sum a of-type number))
+(= 10 (loop for a in '(nil 1 nil 2 nil 3 nil 4)
+ when a sum a of-type (integer 0)))
+
+(= 10 (loop for a in '(nil 1 nil 2 nil 3 nil 4)
+ when a sum a into sum fixnum finally (return sum)))
+(= 10 (loop for a in '(nil 1 nil 2 nil 3 nil 4)
+ when a sum a into sum of-type fixnum finally (return sum)))
+(= 10.0 (loop for a in '(nil 1.0 nil 2.0 nil 3.0 nil 4.0)
+ when a sum a into sum float finally (return sum)))
+(= 10.0 (loop for a in '(nil 1.0 nil 2.0 nil 3.0 nil 4.0)
+ when a sum a into sum of-type float finally (return sum)))
+(= 10 (loop for a in '(nil 1 nil 2 nil 3 nil 4)
+ when a sum a into sum of-type number finally (return sum)))
+(= 10 (loop for a in '(nil 1 nil 2 nil 3 nil 4)
+ when a sum a into sum of-type (integer 0) finally (return sum)))
+
+(= 7 (loop for a in '(nil a nil b nil c nil d e nil f g nil nil nil nil)
+ counting a fixnum))
+(= 7 (loop for a in '(nil a nil b nil c nil d e nil f g nil nil nil nil)
+ counting a of-type fixnum))
+(= 7 (loop for a in '(nil a nil b nil c nil d e nil f g nil nil nil nil)
+ counting a of-type integer))
+(= 7 (loop for a in '(nil a nil b nil c nil d e nil f g nil nil nil nil)
+ counting a of-type (integer 0)))
+(= 7 (loop for a in '(nil a nil b nil c nil d e nil f g nil nil nil nil)
+ counting a of-type number))
+
+(= 7 (loop for a in '(nil a nil b nil c nil d e nil f g nil nil nil nil)
+ counting a into x fixnum finally (return x)))
+(= 7 (loop for a in '(nil a nil b nil c nil d e nil f g nil nil nil nil)
+ counting a into x of-type fixnum finally (return x)))
+(= 7 (loop for a in '(nil a nil b nil c nil d e nil f g nil nil nil nil)
+ counting a into x of-type integer finally (return x)))
+(= 7 (loop for a in '(nil a nil b nil c nil d e nil f g nil nil nil nil)
+ counting a into x of-type (integer 0) finally (return x)))
+(= 7 (loop for a in '(nil a nil b nil c nil d e nil f g nil nil nil nil)
+ counting a into x of-type number finally (return x)))
+
+(= 99 (loop for a in '(3 5 8 0 7 7 99 3) maximize a fixnum))
+(= 99 (loop for a in '(3 5 8 0 7 7 99 3) maximize a of-type fixnum))
+(= 99.0 (loop for a in '(3.0 5.0 8.0 0.0 7.0 7.0 99.0 3.0)
+ maximize a float))
+(= 99.0 (loop for a in '(3.0 5.0 8.0 0.0 7.0 7.0 99.0 3.0)
+ maximize a of-type float))
+(= 99.0 (loop for a in '(3.0 5.0 2.2 8.0 0 3/5 7.0 7 99 3.0)
+ maximize a of-type real))
+(= 99 (loop for a in '(3 5 8 0 7 7 99 3) maximize a of-type (integer 0)))
+
+
+(= 99 (loop for a in '(3 5 8 0 7 7 99 3) maximize a into max fixnum
+ finally (return max)))
+(= 99 (loop for a in '(3 5 8 0 7 7 99 3) maximize a into max of-type fixnum
+ finally (return max)))
+(= 99.0 (loop for a in '(3.0 5.0 8.0 0.0 7.0 7.0 99.0 3.0)
+ maximize a into max float finally (return max)))
+(= 99.0 (loop for a in '(3.0 5.0 8.0 0.0 7.0 7.0 99.0 3.0)
+ maximize a into max of-type float finally (return max)))
+(= 99.0 (loop for a in '(3.0 5.0 2.2 8.0 0 3/5 7.0 7 99 3.0)
+ maximize a into max of-type real finally (return max)))
+(= 99 (loop for a in '(3 5 8 0 7 7 99 3)
+ maximize a into max of-type (integer 0)
+ finally (return max)))
+
+(= 99 (loop for a in '(3 nil 5 8 nil 0 nil 7 7 99 3) when a maximize it fixnum))
+(= 99 (loop for a in '(nil 3 nil 5 nil 8 0 7 7 nil 99 nil 3)
+ when a maximize it of-type fixnum))
+(= 99.0 (loop for a in '(3.0 nil 5.0 8.0 0.0 nil nil nil nil 7.0 nil 7.0 99.0
+ nil 3.0 nil nil nil)
+ when a maximize it float))
+(= 99.0 (loop for a in '(nil nil nil nil nil 3.0 nil 5.0 8.0 0.0
+ nil nil nil 7.0 7.0 nil nil 99.0 3.0)
+ when a maximize it of-type float))
+(= 99.0 (loop for a in '(3.0 5.0 nil nil 2.2 nil nil 8.0 0
+ nil nil 3/5 nil nil 7.0 7 99 3.0)
+ when a maximize it of-type real))
+(= 99 (loop for a in '(3 nil nil 5 8 0 nil nil 7 7 99 nil nil 3)
+ when a maximize a of-type (integer 0)))
+
+(= 99 (loop for a in '(3 nil 5 8 nil 0 nil 7 7 99 3)
+ when a maximize it into max fixnum
+ finally (return max)))
+(= 99 (loop for a in '(nil 3 nil 5 nil 8 0 7 7 nil 99 nil 3)
+ when a maximize it into max of-type fixnum finally (return max)))
+(= 99.0 (loop for a in '(3.0 nil 5.0 8.0 0.0 nil nil nil nil 7.0 nil 7.0 99.0
+ nil 3.0 nil nil nil)
+ when a maximize it into max float finally (return max)))
+(= 99.0 (loop for a in '(nil nil nil nil nil 3.0 nil 5.0 8.0 0.0
+ nil nil nil 7.0 7.0 nil nil 99.0 3.0)
+ when a maximize it into max of-type float finally (return max)))
+(= 99.0 (loop for a in '(3.0 5.0 nil nil 2.2 nil nil 8.0 0
+ nil nil 3/5 nil nil 7.0 7 99 3.0)
+ when a maximize it into max of-type real finally (return max)))
+(= 99 (loop for a in '(3 nil nil 5 8 0 nil nil 7 7 99 nil nil 3)
+ when a maximize it into max of-type (integer 0)
+ finally (return max)))
+
+
+
+(= 99 (loop for a in '(3 5 8 0 7 7 99 3) maximizing a fixnum))
+(= 99 (loop for a in '(3 5 8 0 7 7 99 3) maximizing a of-type fixnum))
+(= 99.0 (loop for a in '(3.0 5.0 8.0 0.0 7.0 7.0 99.0 3.0)
+ maximizing a float))
+(= 99.0 (loop for a in '(3.0 5.0 8.0 0.0 7.0 7.0 99.0 3.0)
+ maximizing a of-type float))
+(= 99.0 (loop for a in '(3.0 5.0 2.2 8.0 0 3/5 7.0 7 99 3.0)
+ maximizing a of-type real))
+(= 99 (loop for a in '(3 5 8 0 7 7 99 3) maximizing a of-type (integer 0)))
+
+
+(= 99 (loop for a in '(3 5 8 0 7 7 99 3) maximizing a into max fixnum
+ finally (return max)))
+(= 99 (loop for a in '(3 5 8 0 7 7 99 3) maximizing a into max of-type fixnum
+ finally (return max)))
+(= 99.0 (loop for a in '(3.0 5.0 8.0 0.0 7.0 7.0 99.0 3.0)
+ maximizing a into max float finally (return max)))
+(= 99.0 (loop for a in '(3.0 5.0 8.0 0.0 7.0 7.0 99.0 3.0)
+ maximizing a into max of-type float finally (return max)))
+(= 99.0 (loop for a in '(3.0 5.0 2.2 8.0 0 3/5 7.0 7 99 3.0)
+ maximizing a into max of-type real finally (return max)))
+(= 99 (loop for a in '(3 5 8 0 7 7 99 3)
+ maximizing a into max of-type (integer 0)
+ finally (return max)))
+
+(= 99 (loop for a in '(3 nil 5 8 nil 0 nil 7 7 99 3) when a maximizing it fixnum))
+(= 99 (loop for a in '(nil 3 nil 5 nil 8 0 7 7 nil 99 nil 3)
+ when a maximizing it of-type fixnum))
+(= 99.0 (loop for a in '(3.0 nil 5.0 8.0 0.0 nil nil nil nil 7.0 nil 7.0 99.0
+ nil 3.0 nil nil nil)
+ when a maximizing it float))
+(= 99.0 (loop for a in '(nil nil nil nil nil 3.0 nil 5.0 8.0 0.0
+ nil nil nil 7.0 7.0 nil nil 99.0 3.0)
+ when a maximizing it of-type float))
+(= 99.0 (loop for a in '(3.0 5.0 nil nil 2.2 nil nil 8.0 0
+ nil nil 3/5 nil nil 7.0 7 99 3.0)
+ when a maximizing it of-type real))
+(= 99 (loop for a in '(3 nil nil 5 8 0 nil nil 7 7 99 nil nil 3)
+ when a maximizing a of-type (integer 0)))
+
+(= 99 (loop for a in '(3 nil 5 8 nil 0 nil 7 7 99 3)
+ when a maximizing it into max fixnum
+ finally (return max)))
+(= 99 (loop for a in '(nil 3 nil 5 nil 8 0 7 7 nil 99 nil 3)
+ when a maximizing it into max of-type fixnum finally (return max)))
+(= 99.0 (loop for a in '(3.0 nil 5.0 8.0 0.0 nil nil nil nil 7.0 nil 7.0 99.0
+ nil 3.0 nil nil nil)
+ when a maximizing it into max float finally (return max)))
+(= 99.0 (loop for a in '(nil nil nil nil nil 3.0 nil 5.0 8.0 0.0
+ nil nil nil 7.0 7.0 nil nil 99.0 3.0)
+ when a maximizing it into max of-type float finally (return max)))
+(= 99.0 (loop for a in '(3.0 5.0 nil nil 2.2 nil nil 8.0 0
+ nil nil 3/5 nil nil 7.0 7 99 3.0)
+ when a maximizing it into max of-type real finally (return max)))
+(= 99 (loop for a in '(3 nil nil 5 8 0 nil nil 7 7 99 nil nil 3)
+ when a maximizing it into max of-type (integer 0)
+ finally (return max)))
+
+
+(= 3 (loop for a in '(3 5 8 4 7 7 99 3) minimize a fixnum))
+(= 3 (loop for a in '(3 5 8 4 7 7 99 3) minimize a of-type fixnum))
+(= 3.0 (loop for a in '(5.0 8.0 7.0 3.0 7.0 99.0) minimize a float))
+(= 3.0 (loop for a in '(5.0 8.0 7.0 3.0 7.0 99.0) minimize a of-type float))
+(= 3.0 (loop for a in '(5.0 8 7 3 7.0 3.0 99.0 1000) minimize a of-type real))
+(= 5 (loop for a in '(6 5 8 7 7 99) minimize a of-type (integer 0)))
+
+(= 3 (loop for a in '(5 8 4 7 7 99 3) minimize a into min fixnum
+ finally (return min)))
+(= 3 (loop for a in '(5 8 4 7 7 99 3) minimize a into min of-type fixnum
+ finally (return min)))
+(= 3.0 (loop for a in '(5.0 8.0 4.0 7.0 7.0 99.0 3.0) minimize a into min float
+ finally (return min)))
+(= 3.0 (loop for a in '(5.0 8.0 4.0 7.0 7.0 99.0 3.0)
+ minimize a into min of-type float finally (return min)))
+(= 3.0 (loop for a in '(5.0 8 4.0 31/3 7.0 7 99.0 3.0)
+ minimize a into min of-type real finally (return min)))
+(= 5 (loop for a in '(6 5 8 7 7 99) minimize a into min of-type (integer 0)
+ finally (return min)))
+
+(= 3 (loop for a in '(nil 5 8 nil nil 7 7 nil 99 3) when a minimize it fixnum))
+(= 3 (loop for a in '(nil 5 8 nil nil 7 7 nil 99 3)
+ when a minimize it of-type fixnum))
+(= 3.0 (loop for a in '(nil 5.0 8.0 nil nil 7.0 7.0 nil 99.0 3.0)
+ when a minimize it float))
+(= 3.0 (loop for a in '(nil 5.0 8.0 nil nil 7.0 7.0 nil 99.0 3.0)
+ when a minimize it of-type float))
+(= 3 (loop for a in '(nil 5.0 8.0 nil nil 7.0 7.0 nil 99.0 3.0)
+ when a minimize it of-type real))
+(= 3 (loop for a in '(nil 5 8 nil nil 7 7 nil 99 3)
+ when a minimize it of-type (integer 0)))
+(= -99 (loop for a in '(nil -5 8 nil nil 7 7 nil -99 3)
+ when a minimize it of-type (integer)))
+
+
+(= 3 (loop for a in '(3 5 8 4 7 7 99 3) minimizing a fixnum))
+(= 3 (loop for a in '(3 5 8 4 7 7 99 3) minimizing a of-type fixnum))
+(= 3.0 (loop for a in '(5.0 8.0 7.0 3.0 7.0 99.0) minimizing a float))
+(= 3.0 (loop for a in '(5.0 8.0 7.0 3.0 7.0 99.0) minimizing a of-type float))
+(= 3.0 (loop for a in '(5.0 8 7 3 7.0 3.0 99.0 1000) minimizing a of-type real))
+(= 5 (loop for a in '(6 5 8 7 7 99) minimizing a of-type (integer 0)))
+
+(= 3 (loop for a in '(5 8 4 7 7 99 3) minimizing a into min fixnum
+ finally (return min)))
+(= 3 (loop for a in '(5 8 4 7 7 99 3) minimizing a into min of-type fixnum
+ finally (return min)))
+(= 3.0 (loop for a in '(5.0 8.0 4.0 7.0 7.0 99.0 3.0) minimizing a into min float
+ finally (return min)))
+(= 3.0 (loop for a in '(5.0 8.0 4.0 7.0 7.0 99.0 3.0)
+ minimizing a into min of-type float finally (return min)))
+(= 3.0 (loop for a in '(5.0 8 4.0 31/3 7.0 7 99.0 3.0)
+ minimizing a into min of-type real finally (return min)))
+(= 5 (loop for a in '(6 5 8 7 7 99) minimizing a into min of-type (integer 0)
+ finally (return min)))
+
+(= 3 (loop for a in '(nil 5 8 nil nil 7 7 nil 99 3) when a minimizing it fixnum))
+(= 3 (loop for a in '(nil 5 8 nil nil 7 7 nil 99 3)
+ when a minimizing it of-type fixnum))
+(= 3.0 (loop for a in '(nil 5.0 8.0 nil nil 7.0 7.0 nil 99.0 3.0)
+ when a minimizing it float))
+(= 3.0 (loop for a in '(nil 5.0 8.0 nil nil 7.0 7.0 nil 99.0 3.0)
+ when a minimizing it of-type float))
+(= 3 (loop for a in '(nil 5.0 8.0 nil nil 7.0 7.0 nil 99.0 3.0)
+ when a minimizing it of-type real))
+(= 3 (loop for a in '(nil 5 8 nil nil 7 7 nil 99 3)
+ when a minimizing it of-type (integer 0)))
+(= -99 (loop for a in '(nil -5 8 nil nil 7 7 nil -99 3)
+ when a minimizing it of-type (integer)))
+(eq 'ok (loop for i from 0 upto 10 summing i finally (return 'ok)))
+(eq 'ok (loop for i in '(nil nil 3 nil 5 nil 6)
+ counting i finally (return 'ok)))
+(eq 'ok (loop for i in '(nil nil 3 nil 5 nil 6)
+ when i maximizing it finally (return 'ok)))
+(eq 'ok (loop for i in '(nil nil 3 nil 5 nil 6)
+ when i minimizing it finally (return 'ok)))
+
+
+
+
+;; termination-test-clauses
+(null (loop with x = '(a b c d) while x do (pop x)))
+(equal (loop with stack = nil and x = '(0 1 2 3)
+ while x do (push (pop x) stack) finally (return stack))
+ '(3 2 1 0))
+(equal (loop with stack = nil and x = '(0 1 2 3)
+ until (null x) do (push (pop x) stack) finally (return stack))
+ '(3 2 1 0))
+(equal (let ((stack '(a b c d e f)))
+ (loop for item = (length stack) then (pop stack)
+ collect item
+ while stack))
+ '(6 A B C D E F))
+(equal (loop for i fixnum from 3
+ when (oddp i) collect i
+ while (< i 5))
+ '(3 5))
+(equal (loop for a below 10
+ when (and (evenp a) a) collect it
+ while (< a 6)
+ collect a)
+ '(0 0 1 2 2 3 4 4 5 6))
+(equal (loop for a below 10
+ when (and (evenp a) a) collect it
+ until (>= a 6)
+ collect a)
+ '(0 0 1 2 2 3 4 4 5 6))
+(equal (loop for a below 10
+ when (and (evenp a) a) collect it
+ while (< a 6)
+ collect a
+ until (>= a 4)
+ collect a)
+ '(0 0 0 1 1 2 2 2 3 3 4 4))
+
+;; repeat
+(= 3 (loop with x = 0 repeat 3 do (incf x) finally (return x)))
+(= 1000 (loop repeat 1000 counting 1))
+(null (loop repeat 3))
+(null (loop repeat 0))
+(let ((body-flag nil))
+ (and (null (loop repeat 0 do (setq body-flag t))) (null body-flag)))
+(= 1 (let ((x 0)) (loop repeat (incf x) sum x)))
+(= 4 (let ((x 1)) (loop repeat (incf x) sum x)))
+(= 9 (let ((x 2)) (loop repeat (incf x) sum x)))
+(= 16 (let ((x 3)) (loop repeat (incf x) sum x)))
+(null (loop repeat -15 return t))
+(let ((body-flag nil))
+ (and (null (loop repeat -10 do (setq body-flag t))) (null body-flag)))
+(let ((eval-count 0)
+ (loop-count 0))
+ (loop repeat (progn (incf eval-count) 2) do (incf loop-count))
+ (and (= 1 eval-count)
+ (= 2 loop-count)))
+(let ((eval-count 0)
+ (loop-count 0))
+ (loop repeat (progn (incf eval-count) 0) do (incf loop-count))
+ (and (= 1 eval-count)
+ (zerop loop-count)))
+(let ((eval-count 0)
+ (loop-count 0))
+ (loop repeat (progn (incf eval-count) -100) do (incf loop-count))
+ (and (= 1 eval-count)
+ (zerop loop-count)))
+
+;; always
+(eq t (loop for i from 0 to 10 always (< i 11)))
+(eq t (loop for a in '() always (oddp a)))
+(null (loop for a in '(0 1 2) always (oddp a)))
+(eq t (loop for a in '(1 3 5) always (oddp a)))
+(let ((flag nil))
+ (and (null (loop for i from 0 to 10 always (< i 5)
+ finally (setq flag t) (return t)))
+ (not flag)))
+(eq 'ok (loop for i below 3 always (numberp i) finally (return 'ok)))
+(eq t (loop repeat 3 always t))
+(handler-case (macroexpand '(loop for i from 0 upto 10
+ always (integerp i)
+ collect i))
+ (program-error () t)
+ (error () nil)
+ (:no-error (&rest rest) (declare (ignore rest)) nil))
+
+;; never
+(eq t (loop for i from 0 to 10 never (> i 11)))
+(eq t (loop for a in '() never (oddp a)))
+(null (loop for a in '(0 1 2) never (oddp a)))
+(eq t (loop for a in '(1 3 5) never (evenp a)))
+(null (loop never t finally (return t)))
+(let ((flag nil))
+ (and (null (loop for a below 3 never (oddp a)
+ finally (setq flag t) (return t)))
+ (null flag)))
+(eq 'ok (loop for i below 3 never (consp i) finally (return 'ok)))
+(eq t (loop repeat 3 never nil))
+(handler-case (macroexpand '(loop for i from 0 upto 10
+ never (integerp i)
+ append (list i)))
+ (program-error () t)
+ (error () nil)
+ (:no-error (&rest rest) (declare (ignore rest)) nil))
+
+;; thereis
+(null (loop for a in '(0 2 4) thereis (oddp a)))
+(= 11 (loop for i from 0 thereis (when (> i 10) i)))
+(eq (loop thereis 'someone) 'someone)
+(eq (loop for i from 1 to 10
+ thereis (> i 11)
+ finally (return 'got-here))
+ 'got-here)
+(let ((count 0))
+ (and (null (loop for a below 10 for b in '(nil nil nil nil c)
+ always (< a 8)
+ never b
+ do (incf count)))
+ (= count 4)))
+(eq (loop for a in '(nil nil nil found-it! nil nil)
+ for b from 10 downto 0
+ never (< b 0)
+ thereis a) 'found-it!)
+(= 4 (loop for i in '(1 2 3 4 5 6)
+ thereis (and (> i 3) i)))
+(let ((flag nil))
+ (loop for a below 3
+ thereis (and (oddp a) a)
+ finally (setq flag t))
+ (null flag))
+(eq 'ok (loop for i below 3 thereis (consp i) finally (return 'ok)))
+(null (loop repeat 3 thereis nil))
+(handler-case (macroexpand '(loop for i from 0 upto 10
+ thereis (integerp i)
+ nconc (list i)))
+ (program-error () t)
+ (error () nil)
+ (:no-error (&rest rest) (declare (ignore rest)) nil))
+
+
+
+;; name-clause
+(loop named bar do (return-from bar t))
+(eq t (loop named outer do (loop named inner do (return-from outer t))))
+
+
+
+
+
+
+;; destructuring
+(equal (loop for (a b c) of-type (integer integer float) in
+ '((1 2 4.0) (5 6 8.3) (8 9 10.4))
+ collect (list c b a))
+ '((4.0 2 1) (8.3 6 5) (10.4 9 8)))
+
+(equal (loop for (a b c) of-type float in
+ '((1.0 2.0 4.0) (5.0 6.0 8.3) (8.0 9.0 10.4))
+ collect (list c b a))
+ '((4.0 2.0 1.0) (8.3 6.0 5.0) (10.4 9.0 8.0)))
+
+(equal (loop with (a b) of-type float = '(1.0 2.0)
+ and (c d) of-type integer = '(3 4)
+ and (e f)
+ return (list a b c d e f))
+ '(1.0 2.0 3 4 NIL NIL))
+(equal (let (stack)
+ (loop for (a (b) ((c))) in '((0 (1) ((2))) (3 (4) ((5))) (6 (7) ((8))))
+ do (push (list a b c) stack))
+ stack)
+ '((6 7 8) (3 4 5) (0 1 2)))
+(equal (let (stack)
+ (loop for (a nil ((b))) in '((0 (1) ((2))) (3 (4) ((5))) (6 (7) ((8))))
+ do (push (list a b) stack))
+ stack)
+ '((6 8) (3 5) (0 2)))
+(equal (let (stack)
+ (loop for (a nil ((((b))))) in
+ '((0 (1) ((((2))))) (3 (4) ((((5))))) (6 (7) ((((8))))))
+ do (push (list a b) stack))
+ stack)
+ '((6 8) (3 5) (0 2)))
+(equal (let (stack)
+ (loop for (a . b) in '((0 . 1) (2 . 3)) do (push (cons a b) stack))
+ stack)
+ '((2 . 3) (0 . 1)))
+(equal (let (stack)
+ (loop for (a . (b)) in '((0 1) (2 3)) do (push (list a b) stack))
+ stack)
+ '((2 3) (0 1)))
+(equal (let (stack)
+ (loop for (a) on '(0 1 2 3) do (push a stack)) stack)
+ '(3 2 1 0))
+(equal (let (stack)
+ (loop for (a . b) on '(0 1 2 3 4) do (push (list a b) stack))
+ stack)
+ '((4 nil) (3 (4)) (2 (3 4)) (1 (2 3 4)) (0 (1 2 3 4))))
+(equal (let (stack) (loop for (a b) across #((0 1) (2 3) (4 5))
+ do (push (list a b) stack))
+ stack)
+ '((4 5) (2 3) (0 1)))
+(equal (let (stack) (loop for (a ((b))) across #((0 ((1))) (2 ((3))) (4 ((5))))
+ do (push (list a b) stack))
+ stack)
+ '((4 5) (2 3) (0 1)))
+(equal (loop with (a b) = '(0 1) return (list a b)) '(0 1))
+(equal (loop with (a b c) = '(0) return (list a b c)) '(0 nil nil))
+(= 2 (loop with (nil nil x) = '(0 1 2) return x))
+(equal (loop for (a b c) in '((0) (1) (2))
+ collect (list a b c))
+ '((0 nil nil) (1 nil nil) (2 nil nil)))
+(equal (loop for (a nil b) in '((0 1 2) (1 2 3) (2 3 4))
+ collect (list a b))
+ '((0 2) (1 3) (2 4)))
+
+(equal (loop for (a . b) t in '((0 . x) (1 . y) (2 . z)) collecting (cons a b))
+ '((0 . x) (1 . y) (2 . z)))
+(equal (loop for (a . b) of-type t in '((0 . x) (1 . y) (2 . z))
+ collecting (cons a b))
+ '((0 . x) (1 . y) (2 . z)))
+(equal (loop for (a . b) of-type (fixnum . symbol) in '((0 . x) (1 . y) (2 . z))
+ collecting (cons a b))
+ '((0 . x) (1 . y) (2 . z)))
+(equal (loop for (a ((b))) of-type (fixnum ((symbol))) in
+ '((0 ((x))) (1 ((y))) (2 ((z))))
+ collecting (cons a b))
+ '((0 . x) (1 . y) (2 . z)))
+(equal (loop for (a ((b))) of-type (fixnum symbol) in
+ '((0 ((x))) (1 ((y))) (2 ((z))))
+ collecting (cons a b))
+ '((0 . x) (1 . y) (2 . z)))
+(equal (loop for (a ((b))) fixnum in '((0 ((10))) (1 ((11))) (2 ((12))))
+ collecting (cons a b))
+ '((0 . 10) (1 . 11) (2 . 12)))
+(equal (loop for (a ((b)) c (((d)))) fixnum in
+ '((0 ((10)) 20 (((30))))
+ (1 ((11)) 21 (((31))))
+ (2 ((12)) 22 (((32)))))
+ collecting (list a b c d))
+ '((0 10 20 30) (1 11 21 31) (2 12 22 32)))
+(equal (loop for (a ((b)) c (((d))))
+ of-type (fixnum ((fixnum)) fixnum (((fixnum)))) in
+ '((0 ((10)) 20 (((30))))
+ (1 ((11)) 21 (((31))))
+ (2 ((12)) 22 (((32)))))
+ collecting (list a b c d))
+ '((0 10 20 30) (1 11 21 31) (2 12 22 32)))
+(equal (loop for (a nil nil (((b)))) of-type (fixnum nil nil (((fixnum)))) in
+ '((0 ((10)) 20 (((30))))
+ (1 ((11)) 21 (((31))))
+ (2 ((12)) 22 (((32)))))
+ collecting (list a b))
+ '((0 30) (1 31) (2 32)))
+
+(equal (loop for (a) fixnum on '(0 1 2) collecting a) '(0 1 2))
+(equal (loop for (a) of-type fixnum on '(0 1 2) collecting a) '(0 1 2))
+(equal (loop for (a) float on '(0.3 1.3 2.3) collecting a) '(0.3 1.3 2.3))
+(equal (loop for (a) of-type float on '(0.3 1.3 2.3) collecting a)
+ '(0.3 1.3 2.3))
+(equal (loop for (a) t on '(0 1 2) collecting a) '(0 1 2))
+(equal (loop for (a) of-type t on '(0 1 2) collecting a) '(0 1 2))
+(equal (loop for (a) of-type real on '(0 1.0 2/3) collecting a) '(0 1.0 2/3))
+(equal (loop for (a nil b) fixnum on '(0 1 2) collecting (list a b))
+ '((0 2) (1 nil) (2 nil)))
+(equal (loop for (a nil b) of-type (fixnum nil fixnum) on '(0 1 2)
+ collecting (list a b))
+ '((0 2) (1 nil) (2 nil)))
+(equal (loop for (nil . tail) t on '(0 1 2 3) append tail)
+ '(1 2 3 2 3 3))
+(equal (loop for (nil . tail) of-type t on '(0 1 2 3) append tail)
+ '(1 2 3 2 3 3))
+(equal (loop for (nil . tail) of-type list on '(0 1 2 3) append tail)
+ '(1 2 3 2 3 3))
+
+(equal (loop for (a b) t across #((x 0) (y 1) (z 2)) collecting (list b a))
+ '((0 x) (1 y) (2 z)))
+(equal (loop for (a b) of-type t across #((x 0) (y 1) (z 2))
+ collecting (list b a))
+ '((0 x) (1 y) (2 z)))
+(equal (loop for (a b) of-type ((member x y z) (member 0 1 2))
+ across #((x 0) (y 1) (z 2))
+ collecting (list b a))
+ '((0 x) (1 y) (2 z)))
+
+
+(eq t (loop for (a) t := '(0) then (list (1+ a))
+ when (= a 3) return t))
+(eq t (loop for (a) of-type t := '(0) then (list (1+ a))
+ when (= a 3) return t))
+(eq t (loop for (a) of-type (t) := '(0) then (list (1+ a))
+ when (= a 3) return t))
+(eq t (loop for (a) fixnum := '(0) then (list (1+ a))
+ when (= a 3) return t))
+(eq t (loop for (a) of-type fixnum := '(0) then (list (1+ a))
+ when (= a 3) return t))
+(eq t (loop for (a) of-type (fixnum) := '(0) then (list (1+ a))
+ when (= a 3) return t))
+(eq t (loop for (a) float := '(0.0) then (list (1+ a))
+ when (= a 3.0) return t))
+(eq t (loop for (a) of-type float := '(0.0) then (list (1+ a))
+ when (= a 3.0) return t))
+(eq t (loop for (a) of-type (float) := '(0.0) then (list (1+ a))
+ when (= a 3.0) return t))
+(equal (loop for (a b) t := '(0 1) then (list (1+ b) (+ b 2))
+ when (> a 5) do (loop-finish)
+ collect (list a b))
+ '((0 1) (2 3) (4 5)))
+(equal (loop for (a b) of-type t := '(0 1) then (list (1+ b) (+ b 2))
+ when (> a 5) do (loop-finish)
+ collect (list a b))
+ '((0 1) (2 3) (4 5)))
+(equal (loop for (a b) of-type (t t) := '(0 1) then (list (1+ b) (+ b 2))
+ when (> a 5) do (loop-finish)
+ collect (list a b))
+ '((0 1) (2 3) (4 5)))
+(equal (loop for (a b) fixnum := '(0 1) then (list (1+ b) (+ b 2))
+ when (> a 5) do (loop-finish)
+ collect (list a b))
+ '((0 1) (2 3) (4 5)))
+(equal (loop for (a b) of-type fixnum := '(0 1) then (list (1+ b) (+ b 2))
+ when (> a 5) do (loop-finish)
+ collect (list a b))
+ '((0 1) (2 3) (4 5)))
+(equal (loop for (a b) of-type (fixnum fixnum) := '(0 1)
+ then (list (1+ b) (+ b 2))
+ when (> a 5) do (loop-finish)
+ collect (list a b))
+ '((0 1) (2 3) (4 5)))
+(equal (loop for (a b) float := '(0.0 1.0) then (list (1+ b) (+ b 2.0))
+ when (> a 5) do (loop-finish)
+ collect (list a b))
+ '((0.0 1.0) (2.0 3.0) (4.0 5.0)))
+(equal (loop for (a b) of-type float := '(0.0 1.0) then (list (1+ b) (+ b 2.0))
+ when (> a 5) do (loop-finish)
+ collect (list a b))
+ '((0.0 1.0) (2.0 3.0) (4.0 5.0)))
+(equal (loop for (a b) of-type (float float) := '(0.0 1.0)
+ then (list (1+ b) (+ b 2.0))
+ when (> a 5) do (loop-finish)
+ collect (list a b))
+ '((0.0 1.0) (2.0 3.0) (4.0 5.0)))
+(equal (loop for (a b) of-type (fixnum float) := '(0 1.0)
+ then (list (+ a 2) (+ b 2.0))
+ when (> a 5) do (loop-finish)
+ collect (list a b))
+ '((0 1.0) (2 3.0) (4 5.0)))
+
+(let ((table (make-hash-table :test 'equal))
+ stack)
+ (mapc #'(lambda (k v) (setf (gethash k table) v))
+ '((k0 0) (k1 1) (k2 2)) '(v0 v1 v2))
+ (loop for (k kn) t being each hash-key of table do (push (list k kn) stack))
+ (null (set-exclusive-or stack '((k0 0) (k1 1) (k2 2)) :test #'equal)))
+(let ((table (make-hash-table :test 'equal))
+ stack)
+ (mapc #'(lambda (k v) (setf (gethash k table) v))
+ '((k0 0) (k1 1) (k2 2)) '(v0 v1 v2))
+ (loop for (k kn) of-type t being each hash-key of table
+ do (push (list k kn) stack))
+ (null (set-exclusive-or stack '((k0 0) (k1 1) (k2 2)) :test #'equal)))
+(let ((table (make-hash-table :test 'equal))
+ stack)
+ (mapc #'(lambda (k v) (setf (gethash k table) v))
+ '((k0 0) (k1 1) (k2 2)) '(v0 v1 v2))
+ (loop for (k kn) of-type (symbol fixnum) being each hash-key of table
+ do (push (list k kn) stack))
+ (null (set-exclusive-or stack '((k0 0) (k1 1) (k2 2)) :test #'equal)))
+(let ((table (make-hash-table :test 'equal))
+ stack)
+ (mapc #'(lambda (k v) (setf (gethash k table) v))
+ '((k0 0) (k1 1) (k2 2)) '(v0 v1 v2))
+ (loop for (k kn) of-type t being each hash-key of table
+ do (push (list k kn) stack))
+ (null (set-exclusive-or stack '((k0 0) (k1 1) (k2 2)) :test #'equal)))
+(let ((table (make-hash-table :test 'equal))
+ stack)
+ (mapc #'(lambda (k v) (setf (gethash k table) v))
+ '((k0 0) (k1 1) (k2 2)) '(v0 v1 v2))
+ (loop for (k kn) of-type (t t) being each hash-key of table
+ do (push (list k kn) stack))
+ (null (set-exclusive-or stack '((k0 0) (k1 1) (k2 2)) :test #'equal)))
+
+
+
+
+;; double binding
+(handler-case
+ (macroexpand '(loop with a = 0 for a downfrom 10 to 0 do (print a)))
+ (program-error () t)
+ (error () nil)
+ (:no-error (&rest rest)
+ (declare (ignore rest))
+ nil))
+(handler-case
+ (macroexpand '(loop for a from 0 upto 10 collect t into a))
+ (program-error () t)
+ (error () nil)
+ (:no-error (&rest rest)
+ (declare (ignore rest))
+ nil))
+
+
+
+
+;; misc
+(= 4 (loop for (item . x) of-type (t . fixnum) in '((A . 1) (B . 2) (C . 3))
+ unless (eq item 'B) sum x))
+(equal (loop for sublist on '(a b c d) collect sublist)
+ '((A B C D) (B C D) (C D) (D)))
+(equal (loop for (item) on '(1 2 3) collect item) '(1 2 3))
+(equal (loop for item = 1 then (+ item 10)
+ for iteration from 1 to 5
+ collect item)
+ '(1 11 21 31 41))
+(equal (loop for i below 3 collecting (loop for j below 2 collecting (list i j)))
+ '(((0 0) (0 1)) ((1 0) (1 1)) ((2 0) (2 1))))
+(zerop (loop for i from -10 upto 0 maximizing i))
+(equal (loop for i from -10 upto 0 maximizing i into max minimizing i into min
+ finally (return (list max min)))
+ '(0 -10))
+(equal (loop for c across "aBcDeFg" when (and (upper-case-p c) c) collecting it)
+ '(#\B #\D #\F))
+(equal (loop named my-loop for i below 3 collect i into x
+ finally (return-from my-loop x))
+ '(0 1 2))
+(equal (loop named nil for i below 3 collect i into x
+ finally (return-from nil x))
+ '(0 1 2))
+(equal (loop for i below 3 collect i into x
+ finally (return-from nil x))
+ '(0 1 2))
+(equal (loop for i below 3 collect i into x
+ finally (return x))
+ '(0 1 2))
+(equal (loop for a from 10 above 0
+ for b in '(1 2 3 4 5 6 7 8 9 10)
+ for c on '(j k l m n o p q r s)
+ for d = 100 then (1- d)
+ collect (list a b (first c) d))
+ '((10 1 j 100) (9 2 k 99) (8 3 l 98) (7 4 m 97) (6 5 n 96)
+ (5 6 o 95) (4 7 p 94) (3 8 q 93) (2 9 r 92) (1 10 s 91)))
+
+(equal (loop with e = 0
+ for a from 10 above 0
+ for b in '(1 2 3 4 5 6 7 8 9 10)
+ for c on '(j k l m n o p q r s)
+ for d = 100 then (1- d)
+ append (list a b (first c) d) into values
+ initially (setq e 1000)
+ repeat 1
+ finally (return (cons e values)))
+ '(1000 10 1 j 100))
+(equal (loop with e = 0
+ for a from 10 above 0
+ for b in '(1 2 3 4 5 6 7 8 9 10)
+ for c on '(j k l m n o p q r s)
+ for d = 100 then (1- d)
+ append (list a b (first c) d) into values
+ initially (setq e 1000)
+ repeat 2
+ finally (return (cons e values)))
+ '(1000 10 1 j 100 9 2 k 99))
+
+(equal (loop for a from 0 upto 100 by 2
+ repeat 1000
+ when (zerop (mod a 10)) collect a)
+ '(0 10 20 30 40 50 60 70 80 90 100))
+
+
+;; it
+(let ((it '0))
+ (equal (loop for a in '(nil x y nil z) when a collect it and collect it)
+ '(x 0 y 0 z 0)))
+
+(let ((it '0))
+ (equal (loop for a in '(x nil y nil z nil)
+ if a collect it end
+ collect it)
+ '(X 0 0 Y 0 0 Z 0 0)))
+
+
+
+;; for-as-package
+(subsetp '(cl:car cl:cdr cl:list)
+ (let (bag)
+ (loop for sym being the external-symbols of 'common-lisp
+ do (push sym bag))
+ bag))
+
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((pkg (make-package "TB-FOO" :use nil))
+ bag)
+ (and (null (loop for sym being the symbols of pkg do (push sym bag)))
+ (null bag))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((pkg (make-package "TB-FOO" :use nil))
+ bag)
+ (and (null (loop for sym being the external-symbols of pkg
+ do (push sym bag)))
+ (null bag))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((pkg (make-package "TB-FOO" :use nil))
+ bag)
+ (and (null (loop for sym being the present-symbols of pkg
+ do (push sym bag)))
+ (null bag))))
+
+
+(progn
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE")
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE")))
+ bag0 bag)
+ (mapc #'(lambda (name)
+ (push (intern name "TB-BAR-TO-USE") bag0)
+ (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE"))
+ '("J" "K" "L"))
+ (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C"))
+ (mapc #'(lambda (name)
+ (push (intern name pkg) bag0)
+ (export (intern name pkg) pkg)) '("X" "Y" "Z"))
+ (loop for sym being the symbols of pkg do (push sym bag))
+ (null (set-exclusive-or bag0 bag))))
+(progn
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE")
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE")))
+ bag0 bag)
+ (mapc #'(lambda (name)
+ (push (intern name "TB-BAR-TO-USE") bag0)
+ (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE"))
+ '("J" "K" "L"))
+ (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C"))
+ (mapc #'(lambda (name)
+ (push (intern name pkg) bag0)
+ (export (intern name pkg) pkg)) '("X" "Y" "Z"))
+ (loop for sym being each symbols of pkg do (push sym bag))
+ (null (set-exclusive-or bag0 bag))))
+
+
+(progn
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE")
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE")))
+ bag0 bag)
+ (mapc #'(lambda (name)
+ (push (intern name "TB-BAR-TO-USE") bag0)
+ (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE"))
+ '("J" "K" "L"))
+ (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C"))
+ (mapc #'(lambda (name)
+ (push (intern name pkg) bag0)
+ (export (intern name pkg) pkg)) '("X" "Y" "Z"))
+ (loop for sym being the symbol of pkg do (push sym bag))
+ (null (set-exclusive-or bag0 bag))))
+(progn
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE")
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE")))
+ bag0 bag)
+ (mapc #'(lambda (name)
+ (push (intern name "TB-BAR-TO-USE") bag0)
+ (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE"))
+ '("J" "K" "L"))
+ (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C"))
+ (mapc #'(lambda (name)
+ (push (intern name pkg) bag0)
+ (export (intern name pkg) pkg)) '("X" "Y" "Z"))
+ (loop for sym being each symbol of pkg do (push sym bag))
+ (null (set-exclusive-or bag0 bag))))
+
+
+(progn
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE")
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE")))
+ bag0 bag)
+ (mapc #'(lambda (name)
+ (push (intern name "TB-BAR-TO-USE") bag0)
+ (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE"))
+ '("J" "K" "L"))
+ (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C"))
+ (mapc #'(lambda (name)
+ (push (intern name pkg) bag0)
+ (export (intern name pkg) pkg)) '("X" "Y" "Z"))
+ (loop for sym being the symbols in pkg do (push sym bag))
+ (null (set-exclusive-or bag0 bag))))
+(progn
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE")
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE")))
+ bag0 bag)
+ (mapc #'(lambda (name)
+ (push (intern name "TB-BAR-TO-USE") bag0)
+ (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE"))
+ '("J" "K" "L"))
+ (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C"))
+ (mapc #'(lambda (name)
+ (push (intern name pkg) bag0)
+ (export (intern name pkg) pkg)) '("X" "Y" "Z"))
+ (loop for sym being each symbols in pkg do (push sym bag))
+ (null (set-exclusive-or bag0 bag))))
+
+
+(progn
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE")
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE")))
+ bag0 bag)
+ (mapc #'(lambda (name)
+ (push (intern name "TB-BAR-TO-USE") bag0)
+ (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE"))
+ '("J" "K" "L"))
+ (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C"))
+ (mapc #'(lambda (name)
+ (push (intern name pkg) bag0)
+ (export (intern name pkg) pkg)) '("X" "Y" "Z"))
+ (loop for sym being the symbol in pkg do (push sym bag))
+ (null (set-exclusive-or bag0 bag))))
+(progn
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE")
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE")))
+ bag0 bag)
+ (mapc #'(lambda (name)
+ (push (intern name "TB-BAR-TO-USE") bag0)
+ (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE"))
+ '("J" "K" "L"))
+ (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C"))
+ (mapc #'(lambda (name)
+ (push (intern name pkg) bag0)
+ (export (intern name pkg) pkg)) '("X" "Y" "Z"))
+ (loop for sym being each symbol in pkg do (push sym bag))
+ (null (set-exclusive-or bag0 bag))))
+
+
+
+(progn
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE")
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE")))
+ bag0 bag)
+ (mapc #'(lambda (name)
+ (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE"))
+ '("J" "K" "L"))
+ (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C"))
+ (mapc #'(lambda (name)
+ (push (intern name pkg) bag0)
+ (export (intern name pkg) pkg)) '("X" "Y" "Z"))
+ (loop for sym being the present-symbols of pkg do (push sym bag))
+ (null (set-exclusive-or bag0 bag))))
+(progn
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE")
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE")))
+ bag0 bag)
+ (mapc #'(lambda (name)
+ (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE"))
+ '("J" "K" "L"))
+ (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C"))
+ (mapc #'(lambda (name)
+ (push (intern name pkg) bag0)
+ (export (intern name pkg) pkg)) '("X" "Y" "Z"))
+ (loop for sym being each present-symbols of pkg do (push sym bag))
+ (null (set-exclusive-or bag0 bag))))
+
+
+(progn
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE")
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE")))
+ bag0 bag)
+ (mapc #'(lambda (name)
+ (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE"))
+ '("J" "K" "L"))
+ (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C"))
+ (mapc #'(lambda (name)
+ (push (intern name pkg) bag0)
+ (export (intern name pkg) pkg)) '("X" "Y" "Z"))
+ (loop for sym being the present-symbol of pkg do (push sym bag))
+ (null (set-exclusive-or bag0 bag))))
+(progn
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE")
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE")))
+ bag0 bag)
+ (mapc #'(lambda (name)
+ (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE"))
+ '("J" "K" "L"))
+ (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C"))
+ (mapc #'(lambda (name)
+ (push (intern name pkg) bag0)
+ (export (intern name pkg) pkg)) '("X" "Y" "Z"))
+ (loop for sym being each present-symbol of pkg do (push sym bag))
+ (null (set-exclusive-or bag0 bag))))
+
+
+(progn
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE")
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE")))
+ bag0 bag)
+ (mapc #'(lambda (name)
+ (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE"))
+ '("J" "K" "L"))
+ (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C"))
+ (mapc #'(lambda (name)
+ (push (intern name pkg) bag0)
+ (export (intern name pkg) pkg)) '("X" "Y" "Z"))
+ (loop for sym being the present-symbols in pkg do (push sym bag))
+ (null (set-exclusive-or bag0 bag))))
+(progn
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE")
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE")))
+ bag0 bag)
+ (mapc #'(lambda (name)
+ (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE"))
+ '("J" "K" "L"))
+ (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C"))
+ (mapc #'(lambda (name)
+ (push (intern name pkg) bag0)
+ (export (intern name pkg) pkg)) '("X" "Y" "Z"))
+ (loop for sym being each present-symbols in pkg do (push sym bag))
+ (null (set-exclusive-or bag0 bag))))
+
+
+(progn
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE")
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE")))
+ bag0 bag)
+ (mapc #'(lambda (name)
+ (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE"))
+ '("J" "K" "L"))
+ (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C"))
+ (mapc #'(lambda (name)
+ (push (intern name pkg) bag0)
+ (export (intern name pkg) pkg)) '("X" "Y" "Z"))
+ (loop for sym being the present-symbol in pkg do (push sym bag))
+ (null (set-exclusive-or bag0 bag))))
+(progn
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE")
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE")))
+ bag0 bag)
+ (mapc #'(lambda (name)
+ (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE"))
+ '("J" "K" "L"))
+ (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C"))
+ (mapc #'(lambda (name)
+ (push (intern name pkg) bag0)
+ (export (intern name pkg) pkg)) '("X" "Y" "Z"))
+ (loop for sym being each present-symbol in pkg do (push sym bag))
+ (null (set-exclusive-or bag0 bag))))
+
+
+
+(progn
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE")
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE")))
+ bag0 bag)
+ (mapc #'(lambda (name)
+ (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE"))
+ '("J" "K" "L"))
+ (mapc #'(lambda (name) (intern name pkg)) '("A" "B" "C"))
+ (mapc #'(lambda (name)
+ (push (intern name pkg) bag0)
+ (export (intern name pkg) pkg)) '("X" "Y" "Z"))
+ (loop for sym being the external-symbols of pkg do (push sym bag))
+ (null (set-exclusive-or bag0 bag))))
+(progn
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE")
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE")))
+ bag0 bag)
+ (mapc #'(lambda (name)
+ (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE"))
+ '("J" "K" "L"))
+ (mapc #'(lambda (name) (intern name pkg)) '("A" "B" "C"))
+ (mapc #'(lambda (name)
+ (push (intern name pkg) bag0)
+ (export (intern name pkg) pkg)) '("X" "Y" "Z"))
+ (loop for sym being each external-symbols of pkg do (push sym bag))
+ (null (set-exclusive-or bag0 bag))))
+(progn
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE")
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE")))
+ bag0 bag)
+ (mapc #'(lambda (name)
+ (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE"))
+ '("J" "K" "L"))
+ (mapc #'(lambda (name) (intern name pkg)) '("A" "B" "C"))
+ (mapc #'(lambda (name)
+ (push (intern name pkg) bag0)
+ (export (intern name pkg) pkg)) '("X" "Y" "Z"))
+ (loop for sym being the external-symbol of pkg do (push sym bag))
+ (null (set-exclusive-or bag0 bag))))
+(progn
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE")
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE")))
+ bag0 bag)
+ (mapc #'(lambda (name)
+ (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE"))
+ '("J" "K" "L"))
+ (mapc #'(lambda (name) (intern name pkg)) '("A" "B" "C"))
+ (mapc #'(lambda (name)
+ (push (intern name pkg) bag0)
+ (export (intern name pkg) pkg)) '("X" "Y" "Z"))
+ (loop for sym being each external-symbol of pkg do (push sym bag))
+ (null (set-exclusive-or bag0 bag))))
+(progn
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE")
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE")))
+ bag0 bag)
+ (mapc #'(lambda (name)
+ (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE"))
+ '("J" "K" "L"))
+ (mapc #'(lambda (name) (intern name pkg)) '("A" "B" "C"))
+ (mapc #'(lambda (name)
+ (push (intern name pkg) bag0)
+ (export (intern name pkg) pkg)) '("X" "Y" "Z"))
+ (loop for sym being the external-symbols in pkg do (push sym bag))
+ (null (set-exclusive-or bag0 bag))))
+(progn
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE")
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE")))
+ bag0 bag)
+ (mapc #'(lambda (name)
+ (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE"))
+ '("J" "K" "L"))
+ (mapc #'(lambda (name) (intern name pkg)) '("A" "B" "C"))
+ (mapc #'(lambda (name)
+ (push (intern name pkg) bag0)
+ (export (intern name pkg) pkg)) '("X" "Y" "Z"))
+ (loop for sym being each external-symbols in pkg do (push sym bag))
+ (null (set-exclusive-or bag0 bag))))
+(progn
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE")
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE")))
+ bag0 bag)
+ (mapc #'(lambda (name)
+ (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE"))
+ '("J" "K" "L"))
+ (mapc #'(lambda (name) (intern name pkg)) '("A" "B" "C"))
+ (mapc #'(lambda (name)
+ (push (intern name pkg) bag0)
+ (export (intern name pkg) pkg)) '("X" "Y" "Z"))
+ (loop for sym being the external-symbol in pkg do (push sym bag))
+ (null (set-exclusive-or bag0 bag))))
+(progn
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE")
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE")))
+ bag0 bag)
+ (mapc #'(lambda (name)
+ (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE"))
+ '("J" "K" "L"))
+ (mapc #'(lambda (name) (intern name pkg)) '("A" "B" "C"))
+ (mapc #'(lambda (name)
+ (push (intern name pkg) bag0)
+ (export (intern name pkg) pkg)) '("X" "Y" "Z"))
+ (loop for sym being each external-symbol in pkg do (push sym bag))
+ (null (set-exclusive-or bag0 bag))))
+
+(progn
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE")
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE")))
+ bag0 bag)
+ (mapc #'(lambda (name)
+ (push (intern name "TB-BAR-TO-USE") bag0)
+ (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE"))
+ '("J" "K" "L"))
+ (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C"))
+ (mapc #'(lambda (name)
+ (push (intern name pkg) bag0)
+ (export (intern name pkg) pkg)) '("X" "Y" "Z"))
+ (loop as sym being the symbols of pkg do (push sym bag))
+ (null (set-exclusive-or bag0 bag))))
+(progn
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE")
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE")))
+ bag0 bag)
+ (mapc #'(lambda (name)
+ (push (intern name "TB-BAR-TO-USE") bag0)
+ (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE"))
+ '("J" "K" "L"))
+ (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C"))
+ (mapc #'(lambda (name)
+ (push (intern name pkg) bag0)
+ (export (intern name pkg) pkg)) '("X" "Y" "Z"))
+ (loop as sym being each symbols of pkg do (push sym bag))
+ (null (set-exclusive-or bag0 bag))))
+
+
+(progn
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE")
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE")))
+ bag0 bag)
+ (mapc #'(lambda (name)
+ (push (intern name "TB-BAR-TO-USE") bag0)
+ (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE"))
+ '("J" "K" "L"))
+ (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C"))
+ (mapc #'(lambda (name)
+ (push (intern name pkg) bag0)
+ (export (intern name pkg) pkg)) '("X" "Y" "Z"))
+ (loop as sym being the symbol of pkg do (push sym bag))
+ (null (set-exclusive-or bag0 bag))))
+(progn
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE")
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE")))
+ bag0 bag)
+ (mapc #'(lambda (name)
+ (push (intern name "TB-BAR-TO-USE") bag0)
+ (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE"))
+ '("J" "K" "L"))
+ (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C"))
+ (mapc #'(lambda (name)
+ (push (intern name pkg) bag0)
+ (export (intern name pkg) pkg)) '("X" "Y" "Z"))
+ (loop as sym being each symbol of pkg do (push sym bag))
+ (null (set-exclusive-or bag0 bag))))
+
+
+(progn
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE")
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE")))
+ bag0 bag)
+ (mapc #'(lambda (name)
+ (push (intern name "TB-BAR-TO-USE") bag0)
+ (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE"))
+ '("J" "K" "L"))
+ (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C"))
+ (mapc #'(lambda (name)
+ (push (intern name pkg) bag0)
+ (export (intern name pkg) pkg)) '("X" "Y" "Z"))
+ (loop as sym being the symbols in pkg do (push sym bag))
+ (null (set-exclusive-or bag0 bag))))
+(progn
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE")
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE")))
+ bag0 bag)
+ (mapc #'(lambda (name)
+ (push (intern name "TB-BAR-TO-USE") bag0)
+ (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE"))
+ '("J" "K" "L"))
+ (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C"))
+ (mapc #'(lambda (name)
+ (push (intern name pkg) bag0)
+ (export (intern name pkg) pkg)) '("X" "Y" "Z"))
+ (loop as sym being each symbols in pkg do (push sym bag))
+ (null (set-exclusive-or bag0 bag))))
+
+
+(progn
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE")
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE")))
+ bag0 bag)
+ (mapc #'(lambda (name)
+ (push (intern name "TB-BAR-TO-USE") bag0)
+ (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE"))
+ '("J" "K" "L"))
+ (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C"))
+ (mapc #'(lambda (name)
+ (push (intern name pkg) bag0)
+ (export (intern name pkg) pkg)) '("X" "Y" "Z"))
+ (loop as sym being the symbol in pkg do (push sym bag))
+ (null (set-exclusive-or bag0 bag))))
+(progn
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE")
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE")))
+ bag0 bag)
+ (mapc #'(lambda (name)
+ (push (intern name "TB-BAR-TO-USE") bag0)
+ (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE"))
+ '("J" "K" "L"))
+ (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C"))
+ (mapc #'(lambda (name)
+ (push (intern name pkg) bag0)
+ (export (intern name pkg) pkg)) '("X" "Y" "Z"))
+ (loop as sym being each symbol in pkg do (push sym bag))
+ (null (set-exclusive-or bag0 bag))))
+
+
+
+(progn
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE")
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE")))
+ bag0 bag)
+ (mapc #'(lambda (name)
+ (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE"))
+ '("J" "K" "L"))
+ (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C"))
+ (mapc #'(lambda (name)
+ (push (intern name pkg) bag0)
+ (export (intern name pkg) pkg)) '("X" "Y" "Z"))
+ (loop as sym being the present-symbols of pkg do (push sym bag))
+ (null (set-exclusive-or bag0 bag))))
+(progn
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE")
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE")))
+ bag0 bag)
+ (mapc #'(lambda (name)
+ (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE"))
+ '("J" "K" "L"))
+ (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C"))
+ (mapc #'(lambda (name)
+ (push (intern name pkg) bag0)
+ (export (intern name pkg) pkg)) '("X" "Y" "Z"))
+ (loop as sym being each present-symbols of pkg do (push sym bag))
+ (null (set-exclusive-or bag0 bag))))
+
+
+(progn
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE")
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE")))
+ bag0 bag)
+ (mapc #'(lambda (name)
+ (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE"))
+ '("J" "K" "L"))
+ (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C"))
+ (mapc #'(lambda (name)
+ (push (intern name pkg) bag0)
+ (export (intern name pkg) pkg)) '("X" "Y" "Z"))
+ (loop as sym being the present-symbol of pkg do (push sym bag))
+ (null (set-exclusive-or bag0 bag))))
+(progn
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE")
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE")))
+ bag0 bag)
+ (mapc #'(lambda (name)
+ (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE"))
+ '("J" "K" "L"))
+ (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C"))
+ (mapc #'(lambda (name)
+ (push (intern name pkg) bag0)
+ (export (intern name pkg) pkg)) '("X" "Y" "Z"))
+ (loop as sym being each present-symbol of pkg do (push sym bag))
+ (null (set-exclusive-or bag0 bag))))
+
+
+(progn
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE")
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE")))
+ bag0 bag)
+ (mapc #'(lambda (name)
+ (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE"))
+ '("J" "K" "L"))
+ (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C"))
+ (mapc #'(lambda (name)
+ (push (intern name pkg) bag0)
+ (export (intern name pkg) pkg)) '("X" "Y" "Z"))
+ (loop as sym being the present-symbols in pkg do (push sym bag))
+ (null (set-exclusive-or bag0 bag))))
+(progn
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE")
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE")))
+ bag0 bag)
+ (mapc #'(lambda (name)
+ (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE"))
+ '("J" "K" "L"))
+ (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C"))
+ (mapc #'(lambda (name)
+ (push (intern name pkg) bag0)
+ (export (intern name pkg) pkg)) '("X" "Y" "Z"))
+ (loop as sym being each present-symbols in pkg do (push sym bag))
+ (null (set-exclusive-or bag0 bag))))
+
+
+(progn
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE")
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE")))
+ bag0 bag)
+ (mapc #'(lambda (name)
+ (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE"))
+ '("J" "K" "L"))
+ (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C"))
+ (mapc #'(lambda (name)
+ (push (intern name pkg) bag0)
+ (export (intern name pkg) pkg)) '("X" "Y" "Z"))
+ (loop as sym being the present-symbol in pkg do (push sym bag))
+ (null (set-exclusive-or bag0 bag))))
+(progn
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE")
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE")))
+ bag0 bag)
+ (mapc #'(lambda (name)
+ (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE"))
+ '("J" "K" "L"))
+ (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C"))
+ (mapc #'(lambda (name)
+ (push (intern name pkg) bag0)
+ (export (intern name pkg) pkg)) '("X" "Y" "Z"))
+ (loop as sym being each present-symbol in pkg do (push sym bag))
+ (null (set-exclusive-or bag0 bag))))
+
+
+
+(progn
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE")
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE")))
+ bag0 bag)
+ (mapc #'(lambda (name)
+ (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE"))
+ '("J" "K" "L"))
+ (mapc #'(lambda (name) (intern name pkg)) '("A" "B" "C"))
+ (mapc #'(lambda (name)
+ (push (intern name pkg) bag0)
+ (export (intern name pkg) pkg)) '("X" "Y" "Z"))
+ (loop as sym being the external-symbols of pkg do (push sym bag))
+ (null (set-exclusive-or bag0 bag))))
+(progn
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE")
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE")))
+ bag0 bag)
+ (mapc #'(lambda (name)
+ (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE"))
+ '("J" "K" "L"))
+ (mapc #'(lambda (name) (intern name pkg)) '("A" "B" "C"))
+ (mapc #'(lambda (name)
+ (push (intern name pkg) bag0)
+ (export (intern name pkg) pkg)) '("X" "Y" "Z"))
+ (loop as sym being each external-symbols of pkg do (push sym bag))
+ (null (set-exclusive-or bag0 bag))))
+(progn
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE")
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE")))
+ bag0 bag)
+ (mapc #'(lambda (name)
+ (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE"))
+ '("J" "K" "L"))
+ (mapc #'(lambda (name) (intern name pkg)) '("A" "B" "C"))
+ (mapc #'(lambda (name)
+ (push (intern name pkg) bag0)
+ (export (intern name pkg) pkg)) '("X" "Y" "Z"))
+ (loop as sym being the external-symbol of pkg do (push sym bag))
+ (null (set-exclusive-or bag0 bag))))
+(progn
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE")
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE")))
+ bag0 bag)
+ (mapc #'(lambda (name)
+ (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE"))
+ '("J" "K" "L"))
+ (mapc #'(lambda (name) (intern name pkg)) '("A" "B" "C"))
+ (mapc #'(lambda (name)
+ (push (intern name pkg) bag0)
+ (export (intern name pkg) pkg)) '("X" "Y" "Z"))
+ (loop as sym being each external-symbol of pkg do (push sym bag))
+ (null (set-exclusive-or bag0 bag))))
+(progn
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE")
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE")))
+ bag0 bag)
+ (mapc #'(lambda (name)
+ (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE"))
+ '("J" "K" "L"))
+ (mapc #'(lambda (name) (intern name pkg)) '("A" "B" "C"))
+ (mapc #'(lambda (name)
+ (push (intern name pkg) bag0)
+ (export (intern name pkg) pkg)) '("X" "Y" "Z"))
+ (loop as sym being the external-symbols in pkg do (push sym bag))
+ (null (set-exclusive-or bag0 bag))))
+(progn
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE")
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE")))
+ bag0 bag)
+ (mapc #'(lambda (name)
+ (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE"))
+ '("J" "K" "L"))
+ (mapc #'(lambda (name) (intern name pkg)) '("A" "B" "C"))
+ (mapc #'(lambda (name)
+ (push (intern name pkg) bag0)
+ (export (intern name pkg) pkg)) '("X" "Y" "Z"))
+ (loop as sym being each external-symbols in pkg do (push sym bag))
+ (null (set-exclusive-or bag0 bag))))
+(progn
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE")
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE")))
+ bag0 bag)
+ (mapc #'(lambda (name)
+ (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE"))
+ '("J" "K" "L"))
+ (mapc #'(lambda (name) (intern name pkg)) '("A" "B" "C"))
+ (mapc #'(lambda (name)
+ (push (intern name pkg) bag0)
+ (export (intern name pkg) pkg)) '("X" "Y" "Z"))
+ (loop as sym being the external-symbol in pkg do (push sym bag))
+ (null (set-exclusive-or bag0 bag))))
+(progn
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE")
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE")))
+ bag0 bag)
+ (mapc #'(lambda (name)
+ (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE"))
+ '("J" "K" "L"))
+ (mapc #'(lambda (name) (intern name pkg)) '("A" "B" "C"))
+ (mapc #'(lambda (name)
+ (push (intern name pkg) bag0)
+ (export (intern name pkg) pkg)) '("X" "Y" "Z"))
+ (loop as sym being each external-symbol in pkg do (push sym bag))
+ (null (set-exclusive-or bag0 bag))))
+(eq t (loop for symbol being the symbols of 'cl finally (return t)))
+(progn
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE")
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE")))
+ bag0 bag)
+ (mapc #'(lambda (name)
+ (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE"))
+ '("J" "K" "L"))
+ (mapc #'(lambda (name) (intern name pkg)) '("A" "B" "C"))
+ (mapc #'(lambda (name)
+ (push (intern name pkg) bag0)
+ (export (intern name pkg) pkg)) '("X" "Y" "Z"))
+ (loop as sym of-type symbol being the external-symbols of pkg
+ do (push sym bag))
+ (null (set-exclusive-or bag0 bag))))
+(progn
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE")
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE")))
+ bag0 bag)
+ (mapc #'(lambda (name)
+ (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE"))
+ '("J" "K" "L"))
+ (mapc #'(lambda (name) (intern name pkg)) '("A" "B" "C"))
+ (mapc #'(lambda (name)
+ (push (intern name pkg) bag0)
+ (export (intern name pkg) pkg)) '("X" "Y" "Z"))
+ (loop as sym t being the external-symbols of pkg
+ do (push sym bag))
+ (null (set-exclusive-or bag0 bag))))
+(progn
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE")
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE")))
+ bag0 bag)
+ (mapc #'(lambda (name)
+ (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE"))
+ '("J" "K" "L"))
+ (mapc #'(lambda (name) (intern name pkg)) '("A" "B" "C"))
+ (mapc #'(lambda (name)
+ (push (intern name pkg) bag0)
+ (export (intern name pkg) pkg)) '("X" "Y" "Z"))
+ (loop as sym of-type t being the external-symbols of pkg
+ do (push sym bag))
+ (null (set-exclusive-or bag0 bag))))
+
+(eq t (loop for c in '(#\A #\S #\Z #\a)
+ always (eq t (loop for s in
+ (loop for s being the external-symbols of 'cl
+ when (char= c (char (symbol-name s) 0))
+ collect s)
+ always (char= c (char (symbol-name s) 0))))))
+
diff --git a/Sacla/tests/must-loop.patch b/Sacla/tests/must-loop.patch
new file mode 100644
index 0000000..51b53b8
--- /dev/null
+++ b/Sacla/tests/must-loop.patch
@@ -0,0 +1,13 @@
+*** sacla/lisp/test/must-loop.lisp 2004-08-03 08:34:55.000000000 +0200
+--- CLISP/clisp-20040712/sacla-tests/must-loop.lisp 2004-08-06 02:49:13.000000000 +0200
+***************
+*** 1195,1200 ****
+--- 1195,1202 ----
+ do (incf x)
+ initially (incf x) (incf x) finally (incf x) (return (incf x)))
+ 7)
++ #-CLISP ; unfounded expectations about the value of for-as iteration variables
++ ; in INITIALLY and FINALLY clauses
+ (equal (let (val) (loop for a downto 3 from 100
+ for b in '(x y z) and c = 50 then (1+ c)
+ initially (setq val (list a b c))
diff --git a/Sacla/tests/must-package.lisp b/Sacla/tests/must-package.lisp
new file mode 100644
index 0000000..192c570
--- /dev/null
+++ b/Sacla/tests/must-package.lisp
@@ -0,0 +1,2266 @@
+;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
+;; ALL RIGHTS RESERVED.
+;;
+;; $Id: must-package.lisp,v 1.12 2004/08/09 02:49:54 yuji Exp $
+;;
+;; 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.
+;;
+;; 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.
+
+
+;; list-all-packages
+(listp (list-all-packages))
+(find "COMMON-LISP" (mapcar #'package-name (list-all-packages)) :test #'string=)
+(find "COMMON-LISP-USER" (mapcar #'package-name (list-all-packages)) :test #'string=)
+(find "KEYWORD" (mapcar #'package-name (list-all-packages)) :test #'string=)
+(every #'packagep (list-all-packages))
+
+
+;; find-package
+(packagep (find-package "COMMON-LISP"))
+(packagep (find-package "CL"))
+(packagep (find-package "COMMON-LISP-USER"))
+(packagep (find-package "CL-USER"))
+(packagep (find-package "KEYWORD"))
+(let ((cl (find-package "COMMON-LISP")))
+ (eq cl (find-package cl)))
+(eq (find-package "CL") (find-package "COMMON-LISP"))
+(eq (find-package 'cl) (find-package "COMMON-LISP"))
+(eq (find-package 'cl) (find-package 'common-lisp))
+(let ((name "NO-SUCH-PACKAGE"))
+ (when (find-package name)
+ (delete-package name))
+ (not (find-package name)))
+(= (length (multiple-value-list (find-package "CL"))) 1)
+(= (length (multiple-value-list (find-package "NO-SUCH-PACKAGE"))) 1)
+(packagep (find-package (find-package (find-package "KEYWORD"))))
+
+
+;; packagep
+(every (complement #'packagep) '(nil a b "CL" "KEYWORD" (a) cl common-lisp-user))
+
+;; make-package
+(progn (when (find-package "a") (delete-package "a"))
+ (and (packagep (make-package #\a)) (delete-package "a")))
+(progn (when (find-package "a") (delete-package "a"))
+ (and (packagep (make-package '|a|)) (delete-package "a")))
+(progn (when (find-package "a") (delete-package "a"))
+ (and (packagep (make-package "a")) (delete-package "a")))
+(progn (when (find-package "a") (delete-package "a"))
+ (and (packagep (make-package "a" :use nil)) (delete-package "a")))
+(progn (when (find-package "a") (delete-package "a"))
+ (and (packagep (make-package "a" :use '(cl))) (delete-package "a")))
+(progn (when (find-package "a") (delete-package "a"))
+ (and (packagep (make-package "a" :use '(cl) :nicknames '("b")))
+ (delete-package "b")))
+(progn (when (find-package "a") (delete-package "a"))
+ (and (packagep (make-package "a" :use '(cl) :nicknames '("b" "c")))
+ (delete-package "c")))
+(progn (when (find-package "a") (delete-package "a"))
+ (and (packagep (make-package "a" :use '(cl) :nicknames '(#\b "c")))
+ (delete-package "b")))
+(progn (when (find-package "a") (delete-package "a"))
+ (and (packagep (make-package "a" :use '(cl) :nicknames '(|b| "c")))
+ (delete-package "b")))
+(HANDLER-CASE
+ (PROGN
+ (WHEN (FIND-PACKAGE "a") (DELETE-PACKAGE "a"))
+ (WHEN (FIND-PACKAGE "b") (DELETE-PACKAGE "b"))
+ (AND (PACKAGEP (MAKE-PACKAGE "b" :USE '(CL)))
+ (PACKAGEP (MAKE-PACKAGE "a" :USE '(CL) :NICKNAMES '(|b| "c")))))
+ (ERROR NIL T)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE
+ (PROGN
+ (WHEN (FIND-PACKAGE "a") (DELETE-PACKAGE "a"))
+ (WHEN (FIND-PACKAGE "b") (DELETE-PACKAGE "b"))
+ (AND (PACKAGEP (MAKE-PACKAGE "a" :USE '(CL)))
+ (PACKAGEP (MAKE-PACKAGE "a" :USE '(CL) :NICKNAMES '(|b| "c")))))
+ (ERROR NIL T)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE
+ (PROGN
+ (WHEN (FIND-PACKAGE "a") (DELETE-PACKAGE "a"))
+ (WHEN (FIND-PACKAGE "d") (DELETE-PACKAGE "b"))
+ (AND (PACKAGEP (MAKE-PACKAGE "a" :USE '(CL) :NICKNAMES '("b" "c")))
+ (PACKAGEP (MAKE-PACKAGE "d" :USE '(CL) :NICKNAMES '("c")))))
+ (ERROR NIL T)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE
+ (PROGN
+ (WHEN (FIND-PACKAGE "TB-FOO") (DELETE-PACKAGE "TB-FOO"))
+ (WHEN (FIND-PACKAGE "TB-BAR-TO-USE")
+ (MAPCAN #'DELETE-PACKAGE (PACKAGE-USED-BY-LIST "TB-BAR-TO-USE"))
+ (DELETE-PACKAGE "TB-BAR-TO-USE"))
+ (AND (PACKAGEP (MAKE-PACKAGE "TB-BAR-TO-USE" :USE NIL))
+ (EXPORT (INTERN "CAR" 'TB-BAR-TO-USE) 'TB-BAR-TO-USE)
+ (MAKE-PACKAGE "TB-FOO" :USE '(CL "TB-BAR-TO-USE"))))
+ (ERROR NIL T)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+
+
+;; package-name
+(string= (package-name "COMMON-LISP") "COMMON-LISP")
+(string= (package-name 'common-lisp) "COMMON-LISP")
+(string= (package-name (find-package 'common-lisp)) "COMMON-LISP")
+(string= (package-name "CL") "COMMON-LISP")
+(string= (package-name 'cl) "COMMON-LISP")
+(string= (package-name (find-package 'cl)) "COMMON-LISP")
+(let ((designator-list
+ (list 'cl 'common-lisp "CL" "COMMON-LISP" (find-package 'cl)
+ 'cl-user 'common-lisp-user "CL-USER" "COMMON-LISP-USER"
+ (find-package 'cl-user)
+ 'keyword "KEYWORD" (find-package 'keyword))))
+ (every #'stringp (mapcar #'package-name designator-list)))
+(every #'stringp (mapcar #'package-name (list-all-packages)))
+(let* ((name "TB-FOO")
+ (package (or (find-package name) (make-package name :use nil))))
+ (and (delete-package name)
+ (not (find-package name))
+ (null (package-name package))))
+
+
+;; package-nicknames
+(member "CL" (package-nicknames "COMMON-LISP") :test #'string=)
+(member "CL" (package-nicknames 'common-lisp) :test #'string=)
+(member "CL" (package-nicknames (find-package 'common-lisp)) :test #'string=)
+(member "CL" (package-nicknames "CL") :test #'string=)
+(member "CL" (package-nicknames 'cl) :test #'string=)
+(member "CL" (package-nicknames (find-package 'cl)) :test #'string=)
+(let ((name 'test-foo)
+ (nicknames '(test-foo-nickname1 test-foo-nickname2 test-foo-nickname3)))
+ (dolist (name (cons name nicknames))
+ (when (find-package name) (delete-package name)))
+ (every #'stringp (package-nicknames (make-package name :nicknames nicknames))))
+(every #'stringp (mapcan #'(lambda (package)
+ (copy-list (package-nicknames package)))
+ (list-all-packages)))
+(progn
+ (when (find-package 'test-foo) (delete-package 'test-foo))
+ (null (set-difference
+ (package-nicknames (make-package 'test-foo
+ :nicknames '("TB-FOO" "test-foo")))
+ '("TB-FOO" "test-foo")
+ :test #'string=)))
+(let ((designator-list
+ (list 'cl 'common-lisp "CL" "COMMON-LISP" (find-package 'cl)
+ 'cl-user 'common-lisp-user "CL-USER" "COMMON-LISP-USER"
+ (find-package 'cl-user)
+ 'keyword "KEYWORD" (find-package 'keyword))))
+ (every #'stringp (mapcan #'(lambda (designator)
+ (copy-list (package-nicknames designator)))
+ designator-list)))
+
+
+;; package-shadowing-symbols
+(every #'listp (mapcar #'package-shadowing-symbols (list-all-packages)))
+(every #'symbolp (mapcan #'(lambda (package)
+ (copy-list (package-shadowing-symbols package)))
+ (list-all-packages)))
+(listp (package-shadowing-symbols 'cl))
+(listp (package-shadowing-symbols "CL-USER"))
+(listp (package-shadowing-symbols "COMMON-LISP"))
+(listp (package-shadowing-symbols (find-package 'keyword)))
+(let ((designator-list
+ (list 'cl 'common-lisp "CL" "COMMON-LISP" (find-package 'cl)
+ 'cl-user 'common-lisp-user "CL-USER" "COMMON-LISP-USER"
+ (find-package 'cl-user)
+ 'keyword "KEYWORD" (find-package 'keyword))))
+ (every #'symbolp (mapcan #'(lambda (designator)
+ (copy-list (package-shadowing-symbols designator)))
+ designator-list)))
+
+
+;; package-use-list
+(every #'listp (mapcar #'package-use-list (list-all-packages)))
+(every #'packagep (mapcan #'(lambda (package)
+ (copy-list (package-use-list package)))
+ (list-all-packages)))
+(listp (package-use-list 'cl))
+(listp (package-use-list "CL-USER"))
+(listp (package-use-list "COMMON-LISP"))
+(listp (package-use-list (find-package 'keyword)))
+(let ((designator-list
+ (list 'cl 'common-lisp "CL" "COMMON-LISP" (find-package 'cl)
+ 'cl-user 'common-lisp-user "CL-USER" "COMMON-LISP-USER"
+ (find-package 'cl-user)
+ 'keyword "KEYWORD" (find-package 'keyword))))
+ (every #'packagep (mapcan #'(lambda (designator)
+ (copy-list (package-use-list designator)))
+ designator-list)))
+
+
+;; package-used-by-list
+(every #'listp (mapcar #'package-used-by-list (list-all-packages)))
+(every #'packagep (mapcan #'(lambda (package)
+ (copy-list (package-used-by-list package)))
+ (list-all-packages)))
+(listp (package-used-by-list 'cl))
+(listp (package-used-by-list "CL-USER"))
+(listp (package-used-by-list "COMMON-LISP"))
+(listp (package-used-by-list (find-package 'keyword)))
+(let ((designator-list
+ (list 'cl 'common-lisp "CL" "COMMON-LISP" (find-package 'cl)
+ 'cl-user 'common-lisp-user "CL-USER" "COMMON-LISP-USER"
+ (find-package 'cl-user)
+ 'keyword "KEYWORD" (find-package 'keyword))))
+ (every #'packagep (mapcan #'(lambda (designator)
+ (copy-list (package-used-by-list designator)))
+ designator-list)))
+
+
+;; rename-package
+(progn
+ (mapcar #'(lambda (package)
+ (when (find-package package) (delete-package package)))
+ '("TB-FOO" "TB-FOO-RENAMED"))
+ (let* ((package (make-package "TB-FOO" :use nil)))
+ (and (eq (rename-package "TB-FOO" "TB-FOO-RENAMED") package)
+ (eq (find-package "TB-FOO-RENAMED") package))))
+(progn
+ (mapcar #'(lambda (package)
+ (when (find-package package) (delete-package package)))
+ '("TB-FOO-0" "TB-FOO-1" "TB-FOO-2" "TB-FOO-3" "TB-FOO-4"))
+ (let* ((package (make-package "TB-FOO-0" :use nil)))
+ (and (eq (rename-package "TB-FOO-0" "TB-FOO-1") package)
+ (eq (rename-package "TB-FOO-1" "TB-FOO-2") package)
+ (eq (rename-package "TB-FOO-2" "TB-FOO-3") package)
+ (eq (rename-package "TB-FOO-3" "TB-FOO-4") package)
+ (eq (find-package "TB-FOO-4") package))))
+(progn
+ (mapcar #'(lambda (package)
+ (when (find-package package) (delete-package package)))
+ '("TB-FOO-0" "TB-FOO-1" "TB-FOO-2" "TB-FOO-3" "TB-FOO-4"))
+ (let* ((package (make-package "TB-FOO-0" :use nil)))
+ (and (eq (rename-package (find-package "TB-FOO-0") "TB-FOO-1") package)
+ (eq (rename-package (find-package "TB-FOO-1") "TB-FOO-2") package)
+ (eq (rename-package (find-package "TB-FOO-2") "TB-FOO-3") package)
+ (eq (rename-package (find-package "TB-FOO-3") "TB-FOO-4") package)
+ (eq (find-package "TB-FOO-4") package))))
+(progn
+ (mapcar #'(lambda (package)
+ (when (find-package package) (delete-package package)))
+ '(#\a #\b))
+ (let ((package (make-package #\a :use nil)))
+ (and (eq (rename-package #\a #\b) package)
+ (eq (find-package #\b) package)
+ (string= (package-name package) #\b))))
+(let ((name-list (list #\a 'b "TB-FOO-0" "TB-FOO-1" 'test-foo-2)))
+ (mapcar #'(lambda (package)
+ (when (find-package package) (delete-package package)))
+ name-list)
+ (let* ((old (pop name-list))
+ (package (make-package old :use nil)))
+ (dolist (new name-list t)
+ (unless (eq (rename-package old new) package)
+ (return nil))
+ (setq old new))))
+(progn
+ (mapcar #'(lambda (package)
+ (when (find-package package) (delete-package package)))
+ '("TB-FOO" "TB-FOO-RENAMED"
+ "TB-FOO-NICKNAME-0" "TB-FOO-NICKNAME-1"))
+ (let* ((package (make-package "TB-FOO"
+ :use nil
+ :nicknames '("TB-FOO-NICKNAME-0"
+ "TB-FOO-NICKNAME-1"))))
+ (and (eq (rename-package "TB-FOO" "TB-FOO-RENAMED") package)
+ (eq (find-package "TB-FOO-RENAMED") package)
+ (null (set-difference (package-nicknames "TB-FOO-RENAMED")
+ '("TB-FOO-NICKNAME-0" "TB-FOO-NICKNAME-1")
+ :test #'string=)))))
+(progn
+ (mapcar #'(lambda (package)
+ (when (find-package package) (delete-package package)))
+ '("TB-FOO-0" "TB-FOO-1" "TB-FOO-2"
+ "TB-FOO-3" "TB-FOO-4" "TB-FOO-5"))
+ (let* ((package (make-package "TB-FOO-0"
+ :use nil
+ :nicknames '("TB-FOO-1" "TB-FOO-2"))))
+ (and (eq (rename-package package "TB-FOO-3" '("TB-FOO-4" "TB-FOO-5"))
+ package)
+ (eq (find-package "TB-FOO-3") package)
+ (eq (find-package "TB-FOO-4") package)
+ (eq (find-package "TB-FOO-5") package)
+ (not (every #'find-package
+ '("TB-FOO-0" "TB-FOO-1" "TB-FOO-2"))))))
+(progn
+ (mapcar #'(lambda (package)
+ (when (find-package package) (delete-package package)))
+ '("TB-FOO-0" "TB-FOO-1" "TB-FOO-2"))
+ (let* ((package (make-package "TB-FOO-0" :use nil :nicknames '("TB-FOO-1"))))
+ (eq (rename-package package "TB-FOO-1" '("TB-FOO-2")) package)))
+(progn
+ (mapcar #'(lambda (package)
+ (when (find-package package) (delete-package package)))
+ '("TB-FOO-0" "TB-FOO-1" "TB-FOO-2"
+ "TB-FOO-3" "TB-FOO-4" "TB-FOO-5"))
+ (let* ((package (make-package "TB-FOO-0" :use nil :nicknames '("TB-FOO-1"))))
+ (and (eq (rename-package package "TB-FOO-1" '("TB-FOO-2")) package)
+ (eq (rename-package package "TB-FOO-2" '("TB-FOO-3")) package)
+ (eq (rename-package package "TB-FOO-3" '("TB-FOO-4")) package)
+ (eq (rename-package package "TB-FOO-4" '("TB-FOO-5")) package)
+ (eq (rename-package package "TB-FOO-5" '("TB-FOO-0")) package)
+ (eq (find-package 'test-foo-5) (find-package 'test-foo-0)))))
+(progn
+ (mapcar #'(lambda (package)
+ (when (find-package package) (delete-package package)))
+ '("TB-FOO-0" "TB-FOO-1" "TB-FOO-2"))
+ (let* ((package (make-package "TB-FOO-0" :use nil
+ :nicknames '("TB-FOO-1" "TB-FOO-2"))))
+ (and (eq (rename-package package "TB-FOO-2" '("TB-FOO-3" "TB-FOO-1"))
+ package)
+ (string= (package-name package) "TB-FOO-2")
+ (null (set-difference (package-nicknames package)
+ '("TB-FOO-3" "TB-FOO-1")
+ :test #'string=)))))
+(progn
+ (mapcar #'(lambda (package)
+ (when (find-package package) (delete-package package)))
+ '("TB-FOO-0" "TB-FOO-1" "TB-FOO-2"))
+ (let* ((package (make-package "TB-FOO-0" :use nil
+ :nicknames '("TB-FOO-1" "TB-FOO-2"))))
+ (and (eq (rename-package package "TB-FOO-3") package)
+ (string= (package-name package) "TB-FOO-3")
+ (null (package-nicknames package)))))
+
+
+;; find-symbol
+(equal (multiple-value-list (find-symbol "CAR" "CL")) '(cl:car :EXTERNAL))
+(equal (multiple-value-list (find-symbol "CDR" "CL")) '(cl:cdr :EXTERNAL))
+(equal (multiple-value-list (find-symbol "CDR" 'cl)) '(cl:cdr :EXTERNAL))
+(equal (multiple-value-list (find-symbol "CDR" (find-package 'cl)))
+ '(cl:cdr :EXTERNAL))
+(equal (multiple-value-list (find-symbol "NIL" "CL")) '(nil :EXTERNAL))
+(let ((*package* (find-package 'cl)))
+ (equal (multiple-value-list (find-symbol "CDR")) '(cl:cdr :EXTERNAL)))
+(progn
+ (when (find-package "A") (delete-package "A"))
+ (make-package "A" :use nil)
+ (equal (multiple-value-list (find-symbol "A" #\A)) '(nil nil)))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (make-package "TB-FOO" :use nil)
+ (equal (multiple-value-list (find-symbol "A" "TB-FOO")) '(nil nil)))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (make-package "TB-FOO" :use nil)
+ (multiple-value-bind (symbol0 status0) (intern "A" "TB-FOO")
+ (multiple-value-bind (symbol1 status1) (find-symbol "A" "TB-FOO")
+ (and (eq symbol0 symbol1)
+ (null status0)
+ (eq status1 :internal)))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (make-package "TB-FOO" :use '("CL"))
+ (equal (multiple-value-list (find-symbol "CAR" "TB-FOO"))
+ '(cl:car :inherited)))
+(do-external-symbols (symbol "CL" t)
+ (multiple-value-bind (symbol-found status)
+ (find-symbol (symbol-name symbol) "COMMON-LISP-USER")
+ (unless (and (eq symbol symbol-found) (eq status :inherited))
+ (error "Symbol ~S is ~S" symbol-found status))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((*package* (make-package "TB-FOO" :use '("COMMON-LISP"))))
+ (and (equal (multiple-value-list (find-symbol "APPEND"))
+ '(cl:append :inherited))
+ (equal (multiple-value-list (find-symbol "FIND"))
+ '(cl:find :inherited))
+ (equal (multiple-value-list (find-symbol "CAR"))
+ '(cl:car :inherited)))))
+(equal (multiple-value-list (find-symbol "NIL" 'cl)) '(nil :external))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let* ((*package* (make-package "TB-FOO" :use (list 'cl)))
+ (symbol (intern "car" *package*)))
+ (and (equal (multiple-value-list (find-symbol "car"))
+ (list symbol :internal))
+ (equal (multiple-value-list (find-symbol "CAR"))
+ (list 'cl:car :inherited)))))
+
+
+;; find-all-symbols
+(member 'cl:car (find-all-symbols 'car))
+(member 'cl:cdr (find-all-symbols "CDR"))
+(every #'symbolp (find-all-symbols "LOOP"))
+(every #'(lambda (name) (string= name "FIND"))
+ (mapcar #'symbol-name (find-all-symbols "FIND")))
+(dolist (name (list "CAR" "CDR" #\a #\A 'common-lisp 'join "" "XXX" "aA"
+ "LONGLONGLONGLONGLONGLONGLONGLONGLONGLONG"
+ 'long-long-long-long-long-long-name) t)
+ (unless (every #'(lambda (symbol-name) (string= symbol-name name))
+ (mapcar #'symbol-name (find-all-symbols name)))
+ (return nil)))
+
+
+;; intern
+(symbolp (intern "SYMBOL"))
+(symbolp (intern "long-long-name-in-lower-case"))
+(equal (multiple-value-list (intern "NIL" 'cl)) '(nil :external))
+(multiple-value-bind (boo status) (intern "BOO")
+ (and (symbolp boo)
+ (member status '(nil :internal :external :inherited))
+ (string= (symbol-name boo) "BOO")))
+(let ((*package* (find-package "CL")))
+ (equal (multiple-value-list (intern "CAR")) '(cl:car :external)))
+(let ((*package* (find-package "KEYWORD")))
+ (equal (multiple-value-list (intern "TEST")) '(:test :external)))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (make-package "TB-FOO" :use nil)
+ (and (multiple-value-list (intern "BOO" 'tb-foo))
+ (list (find-symbol "BOO" 'tb-foo) nil)
+ (eq (symbol-package (find-symbol "BOO" 'tb-foo)) (find-package 'tb-foo))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((*package* (make-package "TB-FOO" :use '(cl))))
+ (and (eq (intern "CAR") 'cl:car)
+ (equal (multiple-value-list (intern "ZZZ"))
+ (list (find-symbol "ZZZ") nil))
+ (equal (multiple-value-list (intern "ZZZ"))
+ (list (find-symbol "ZZZ") :internal))
+ (export (find-symbol "ZZZ"))
+ (equal (multiple-value-list (intern "ZZZ"))
+ (list (find-symbol "ZZZ") :external)))))
+
+;; export
+(eq (export ()) t)
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((*package* (make-package "TB-FOO" :use nil))
+ buz)
+ (and (setq buz (intern "BUZ"))
+ (equal (multiple-value-list (find-symbol "BUZ")) (list buz :internal))
+ (eq (export buz) t)
+ (equal (multiple-value-list (find-symbol "BUZ"))
+ (list buz :external)))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((*package* (make-package "TB-FOO" :use '(cl))))
+ (and (equal (multiple-value-list (find-symbol "CAR")) '(cl:car :inherited))
+ (eq (export 'cl:car) t)
+ (equal (multiple-value-list (find-symbol "CAR")) '(cl:car :external)))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((*package* (make-package "TB-FOO" :use '(cl))))
+ (and (equal (multiple-value-list (find-symbol "CAR")) '(cl:car :inherited))
+ (eq (export '(cl:car)) t)
+ (equal (multiple-value-list (find-symbol "CAR")) '(cl:car :external)))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((*package* (make-package "TB-FOO" :use '(cl))))
+ (and (equal (multiple-value-list (find-symbol "CAR")) '(cl:car :inherited))
+ (equal (multiple-value-list (find-symbol "CDR")) '(cl:cdr :inherited))
+ (eq (export '(cl:car cl:cdr)) t)
+ (equal (multiple-value-list (find-symbol "CAR")) '(cl:car :external))
+ (equal (multiple-value-list (find-symbol "CDR")) '(cl:cdr :external)))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((*package* (make-package "TB-FOO" :use '(cl)))
+ (buz (make-symbol "BUZ")))
+ (import buz)
+ (and (equal (multiple-value-list (find-symbol "CAR")) '(cl:car :inherited))
+ (equal (multiple-value-list (find-symbol "CDR")) '(cl:cdr :inherited))
+ (equal (multiple-value-list (find-symbol "BUZ")) (list buz :internal))
+ (eq (export (list 'cl:car buz 'cl:cdr)) t)
+ (equal (multiple-value-list (find-symbol "CAR")) '(cl:car :external))
+ (equal (multiple-value-list (find-symbol "CDR")) '(cl:cdr :external))
+ (equal (multiple-value-list (find-symbol "BUZ"))
+ (list buz :external)))))
+(progn
+ (when (find-package "A") (delete-package "A"))
+ (make-package "A" :use nil)
+ (import 'cl:car "A")
+ (and (eq (export 'cl:car "A") t)
+ (equal (multiple-value-list (find-symbol "CAR" "A"))
+ '(cl:car :external))))
+(progn
+ (when (find-package "A") (delete-package "A"))
+ (make-package "A" :use nil)
+ (import 'cl:car "A")
+ (and (eq (export 'cl:car #\A) t)
+ (equal (multiple-value-list (find-symbol "CAR" "A"))
+ '(cl:car :external))))
+(progn
+ (when (find-package "A") (delete-package "A"))
+ (make-package "A" :use nil)
+ (import 'cl:car "A")
+ (and (eq (export 'cl:car 'a) t)
+ (equal (multiple-value-list (find-symbol "CAR" "A"))
+ '(cl:car :external))))
+(progn
+ (when (find-package "A") (delete-package "A"))
+ (make-package "A" :use nil)
+ (import 'cl:car "A")
+ (and (eq (export 'cl:car (find-package 'a)) t)
+ (equal (multiple-value-list (find-symbol "CAR" "A"))
+ '(cl:car :external))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((*package* (make-package "TB-FOO" :use '(cl))))
+ (and (equal (multiple-value-list (find-symbol "CAR")) '(cl:car :inherited))
+ (eq (export 'cl:car) t)
+ (equal (multiple-value-list (find-symbol "CAR")) '(cl:car :external))
+ (unuse-package 'cl)
+ (equal (multiple-value-list (find-symbol "CAR")) '(cl:car :external)))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE" :use nil)
+ (make-package "TB-FOO" :use '("TB-BAR-TO-USE"))
+ (let ((buz (intern "BUZ" 'tb-bar-to-use)))
+ (and (equal (multiple-value-list (find-symbol "BUZ" 'tb-foo)) '(nil nil))
+ (export buz 'tb-bar-to-use)
+ (equal (multiple-value-list (find-symbol "BUZ" 'tb-foo))
+ (list buz :inherited)))))
+(HANDLER-CASE
+ (PROGN
+ (WHEN (FIND-PACKAGE "TB-FOO") (DELETE-PACKAGE "TB-FOO"))
+ (MAKE-PACKAGE "TB-FOO" :USE NIL)
+ (EXPORT 'CAR "TB-FOO"))
+ (PACKAGE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE
+ (PROGN
+ (WHEN (FIND-PACKAGE "TB-FOO") (DELETE-PACKAGE "TB-FOO"))
+ (WHEN (FIND-PACKAGE "TB-BAR-TO-USE")
+ (MAPCAN #'DELETE-PACKAGE (PACKAGE-USED-BY-LIST "TB-BAR-TO-USE"))
+ (DELETE-PACKAGE "TB-BAR-TO-USE"))
+ (MAKE-PACKAGE "TB-BAR-TO-USE" :USE NIL)
+ (MAKE-PACKAGE "TB-FOO" :USE '("TB-BAR-TO-USE"))
+ (INTERN "BUZ" 'TB-FOO)
+ (LET ((BUZ (INTERN "BUZ" 'TB-BAR-TO-USE)))
+ (EXPORT BUZ 'TB-BAR-TO-USE)))
+ (PACKAGE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+
+;; unexport
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((*package* (make-package "TB-FOO" :use nil))
+ buz)
+ (and (export (setq buz (intern "BUZ")))
+ (equal (multiple-value-list (find-symbol "BUZ")) (list buz :external))
+ (eq (unexport buz) t)
+ (equal (multiple-value-list (find-symbol "BUZ"))
+ (list buz :internal)))))
+(progn
+ (when (find-package "A") (delete-package "A"))
+ (make-package "A" :use nil)
+ (let (buz)
+ (and (export (setq buz (intern "BUZ" 'a)) 'a)
+ (equal (multiple-value-list (find-symbol "BUZ" 'a))
+ (list buz :external))
+ (eq (unexport buz 'a) t)
+ (equal (multiple-value-list (find-symbol "BUZ" 'a))
+ (list buz :internal)))))
+(progn
+ (when (find-package "A") (delete-package "A"))
+ (make-package "A" :use nil)
+ (let (buz)
+ (and (export (setq buz (intern "BUZ" 'a)) 'a)
+ (equal (multiple-value-list (find-symbol "BUZ" 'a))
+ (list buz :external))
+ (eq (unexport buz #\A) t)
+ (equal (multiple-value-list (find-symbol "BUZ" 'a))
+ (list buz :internal)))))
+(progn
+ (when (find-package "A") (delete-package "A"))
+ (make-package "A" :use nil)
+ (let (buz)
+ (and (export (setq buz (intern "BUZ" 'a)) 'a)
+ (equal (multiple-value-list (find-symbol "BUZ" 'a))
+ (list buz :external))
+ (eq (unexport buz "A") t)
+ (equal (multiple-value-list (find-symbol "BUZ" 'a))
+ (list buz :internal)))))
+(progn
+ (when (find-package "A") (delete-package "A"))
+ (make-package "A" :use nil)
+ (let (buz)
+ (and (export (setq buz (intern "BUZ" 'a)) 'a)
+ (equal (multiple-value-list (find-symbol "BUZ" 'a))
+ (list buz :external))
+ (eq (unexport buz (find-package "A")) t)
+ (equal (multiple-value-list (find-symbol "BUZ" 'a))
+ (list buz :internal)))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (make-package "TB-FOO" :use nil)
+ (let (buz)
+ (and (export (setq buz (intern "BUZ" 'tb-foo)) 'tb-foo)
+ (equal (multiple-value-list (find-symbol "BUZ" 'tb-foo))
+ (list buz :external))
+ (eq (unexport buz 'tb-foo) t)
+ (equal (multiple-value-list (find-symbol "BUZ" 'tb-foo))
+ (list buz :internal)))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let* ((*package* (make-package "TB-FOO" :use nil))
+ (names '("A" "BC" "DEF" "GHIJ"))
+ (symbols (mapcar #'intern names)))
+ (and (export symbols)
+ (eq (unexport symbols) t)
+ (every #'(lambda (status) (eq status :internal))
+ (mapcar #'(lambda (name)
+ (cadr (multiple-value-list (find-symbol name))))
+ names)))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let* ((*package* (make-package "TB-FOO" :use nil)))
+ (import '(cl:nil))
+ (export '(cl:nil))
+ (and (eq (unexport 'cl:nil) t)
+ (equal (multiple-value-list (find-symbol "NIL")) '(cl:nil :external)))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let* ((*package* (make-package "TB-FOO" :use nil)))
+ (import '(cl:nil))
+ (export '(cl:nil))
+ (and (eq (unexport '(cl:nil)) t)
+ (equal (multiple-value-list (find-symbol "NIL")) '(nil :internal)))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let* ((*package* (make-package "TB-FOO" :use nil))
+ (baz (intern "BAZ" *package*)))
+ (and
+ (equal (multiple-value-list (find-symbol "BAZ")) (list baz :internal))
+ (eq (unexport (list baz) *package*) t)
+ (equal (multiple-value-list (find-symbol "BAZ")) (list baz :internal)))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let* ((*package* (make-package "TB-FOO" :use nil))
+ (baz (intern "BAZ" *package*))
+ (woo (intern "WOO" *package*)))
+ (export woo)
+ (and
+ (equal (multiple-value-list (find-symbol "BAZ")) (list baz :internal))
+ (equal (multiple-value-list (find-symbol "WOO")) (list woo :external))
+ (eq (unexport (list baz woo) *package*) t)
+ (equal (multiple-value-list (find-symbol "BAZ")) (list baz :internal))
+ (equal (multiple-value-list (find-symbol "WOO")) (list woo :internal)))))
+(HANDLER-CASE
+ (PROGN
+ (WHEN (FIND-PACKAGE "TB-FOO") (DELETE-PACKAGE "TB-FOO"))
+ (LET* ((*PACKAGE* (MAKE-PACKAGE "TB-FOO" :USE NIL)))
+ (UNEXPORT 'CAR)))
+ (PACKAGE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE
+ (PROGN
+ (WHEN (FIND-PACKAGE "TB-FOO") (DELETE-PACKAGE "TB-FOO"))
+ (LET* ((*PACKAGE* (MAKE-PACKAGE "TB-FOO" :USE NIL))
+ (BAZ (INTERN "BAZ" *PACKAGE*))
+ (WOO (INTERN "WOO" *PACKAGE*)))
+ (EXPORT WOO)
+ (UNEXPORT (LIST BAZ 'NIL WOO) *PACKAGE*)))
+ (PACKAGE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+
+
+
+;; shadow
+(eq (shadow '()) t)
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (make-package "TB-FOO" :use nil)
+ (and (eq (shadow "A" 'tb-foo) t)
+ (eq (cadr (multiple-value-list (find-symbol "A" 'tb-foo))) :internal)
+ (equal (package-shadowing-symbols 'tb-foo)
+ (list (find-symbol "A" 'tb-foo)))))
+(eq (shadow '()) t)
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (make-package "TB-FOO" :use nil)
+ (and (eq (shadow #\A 'tb-foo) t)
+ (eq (cadr (multiple-value-list (find-symbol "A" 'tb-foo))) :internal)
+ (equal (package-shadowing-symbols 'tb-foo)
+ (list (find-symbol "A" 'tb-foo)))))
+(eq (shadow '()) t)
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (make-package "TB-FOO" :use nil)
+ (and (eq (shadow 'a 'tb-foo) t)
+ (eq (cadr (multiple-value-list (find-symbol "A" 'tb-foo))) :internal)
+ (equal (package-shadowing-symbols 'tb-foo)
+ (list (find-symbol "A" 'tb-foo)))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (make-package "TB-FOO" :use nil)
+ (and (eq (shadow '(a) 'tb-foo) t)
+ (eq (cadr (multiple-value-list (find-symbol "A" 'tb-foo))) :internal)
+ (equal (package-shadowing-symbols 'tb-foo)
+ (list (find-symbol "A" 'tb-foo)))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (make-package "TB-FOO" :use nil)
+ (and (eq (shadow '("A") 'tb-foo) t)
+ (eq (cadr (multiple-value-list (find-symbol "A" 'tb-foo))) :internal)
+ (equal (package-shadowing-symbols 'tb-foo)
+ (list (find-symbol "A" 'tb-foo)))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (make-package "TB-FOO" :use nil)
+ (and (eq (shadow '(#\A) 'tb-foo) t)
+ (eq (cadr (multiple-value-list (find-symbol "A" 'tb-foo))) :internal)
+ (equal (package-shadowing-symbols 'tb-foo)
+ (list (find-symbol "A" 'tb-foo)))))
+(progn
+ (when (find-package "A") (delete-package "A"))
+ (make-package "A" :use nil)
+ (and (eq (shadow "BUZ" #\A) t)
+ (eq (cadr (multiple-value-list (find-symbol "BUZ" 'a))) :internal)
+ (equal (package-shadowing-symbols 'a)
+ (list (find-symbol "BUZ" 'a)))))
+(progn
+ (when (find-package "A") (delete-package "A"))
+ (make-package "A" :use nil)
+ (and (eq (shadow "BUZ" "A") t)
+ (eq (cadr (multiple-value-list (find-symbol "BUZ" 'a))) :internal)
+ (equal (package-shadowing-symbols 'a)
+ (list (find-symbol "BUZ" 'a)))))
+(progn
+ (when (find-package "A") (delete-package "A"))
+ (make-package "A" :use nil)
+ (and (eq (shadow "BUZ" 'a) t)
+ (eq (cadr (multiple-value-list (find-symbol "BUZ" 'a))) :internal)
+ (equal (package-shadowing-symbols 'a)
+ (list (find-symbol "BUZ" 'a)))))
+(progn
+ (when (find-package "A") (delete-package "A"))
+ (make-package "A" :use nil)
+ (and (eq (shadow "BUZ" (find-package 'a)) t)
+ (eq (cadr (multiple-value-list (find-symbol "BUZ" 'a))) :internal)
+ (equal (package-shadowing-symbols 'a)
+ (list (find-symbol "BUZ" 'a)))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((*package* (make-package "TB-FOO" :use nil))
+ (names '(a #\B "C" "BUZ")))
+ (and (eq (shadow names) t)
+ (every #'(lambda (name)
+ (eq (cadr (multiple-value-list (find-symbol name)))
+ :internal))
+ names)
+ (null (set-difference (mapcar #'find-symbol (mapcar #'string names))
+ (package-shadowing-symbols *package*))))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((*package* (make-package "TB-FOO" :use '(cl)))
+ (names '(a #\B "C" "BUZ" "CAR"))
+ a b c)
+ (setq a (intern "A"))
+ (export (setq b (intern "B")))
+ (shadowing-import (setq c (intern "C")))
+ (and (eq (shadow names) t)
+ (equal (multiple-value-list (find-symbol "A")) (list a :internal))
+ (equal (multiple-value-list (find-symbol "B")) (list b :external))
+ (equal (multiple-value-list (find-symbol "C")) (list c :internal))
+ (eq (cadr (multiple-value-list (find-symbol "BUZ"))) :internal)
+ (eq (cadr (multiple-value-list (find-symbol "CAR"))) :internal)
+ (not (eq (car (multiple-value-list (find-symbol "CAR"))) 'cl:car))
+ (null (set-difference (mapcar #'find-symbol (mapcar #'string names))
+ (package-shadowing-symbols *package*))))))
+
+
+
+
+;; shadowing-import
+(eq (shadowing-import '()) t)
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (shadowing-import '() (make-package "TB-FOO" :use nil))
+ (let ((list nil))
+ (null (do-symbols (symbol "TB-FOO" list) (push symbol list)))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((*package* (make-package "TB-FOO" :use nil)))
+ (and (not (find-symbol "CAR"))
+ (not (find-symbol "CDR"))
+ (not (find-symbol "LIST"))
+ (eq (shadowing-import '(cl:car cl:cdr cl:list)) t)
+ (eq (find-symbol "CAR") 'cl:car)
+ (eq (find-symbol "CDR") 'cl:cdr)
+ (eq (find-symbol "LIST") 'cl:list))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let* ((*package* (make-package "TB-FOO" :use (list 'cl)))
+ (names '("CAR" "CDR" "LIST" "APPEND"))
+ (symbols (mapcar #'make-symbol names)))
+ (and (eq (shadowing-import symbols) t)
+ (every #'eq symbols (mapcar #'find-symbol names))
+ (every #'(lambda (symbol)
+ (member symbol (package-shadowing-symbols *package*)))
+ symbols))))
+(progn
+ (when (find-package "A") (delete-package "A"))
+ (make-package "A" :use nil)
+ (let ((symbol (make-symbol "CAR")))
+ (and (eq (shadowing-import symbol "A") t)
+ (equal (multiple-value-list (find-symbol "CAR" "A"))
+ (list symbol :internal)))))
+(progn
+ (when (find-package "A") (delete-package "A"))
+ (make-package "A" :use nil)
+ (let ((symbol (make-symbol "CAR")))
+ (and (eq (shadowing-import symbol #\A) t)
+ (equal (multiple-value-list (find-symbol "CAR" "A"))
+ (list symbol :internal)))))
+(progn
+ (when (find-package "A") (delete-package "A"))
+ (make-package "A" :use nil)
+ (let ((symbol (make-symbol "CAR")))
+ (and (eq (shadowing-import symbol 'a) t)
+ (equal (multiple-value-list (find-symbol "CAR" "A"))
+ (list symbol :internal)))))
+(progn
+ (when (find-package "A") (delete-package "A"))
+ (make-package "A" :use nil)
+ (let ((symbol (make-symbol "CAR")))
+ (and (eq (shadowing-import symbol (find-package 'a)) t)
+ (equal (multiple-value-list (find-symbol "CAR" "A"))
+ (list symbol :internal)))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (make-package "TB-FOO" :use nil)
+ (let ((buz0 (intern "BUZ" 'tb-foo))
+ (buz1 (make-symbol "BUZ")))
+ (and (equal (multiple-value-list (find-symbol "BUZ" 'tb-foo))
+ (list buz0 :internal))
+ (eq (shadowing-import buz1 'tb-foo) t)
+
+ (equal (multiple-value-list (find-symbol "BUZ" 'tb-foo))
+ (list buz1 :internal))
+ (equal (list buz1) (package-shadowing-symbols 'tb-foo))
+ (unintern buz1 'tb-foo)
+ (equal (multiple-value-list (find-symbol "BUZ" 'tb-foo)) '(nil nil))
+ (null (package-shadowing-symbols 'tb-foo)))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (make-package "TB-FOO" :use nil)
+ (let ((buz0 (intern "BUZ" 'tb-foo))
+ (buz1 (make-symbol "BUZ")))
+ (shadow buz0 'tb-foo)
+ (and (equal (multiple-value-list (find-symbol "BUZ" 'tb-foo))
+ (list buz0 :internal))
+ (eq (shadowing-import buz1 'tb-foo) t)
+
+ (equal (multiple-value-list (find-symbol "BUZ" 'tb-foo))
+ (list buz1 :internal))
+ (equal (list buz1) (package-shadowing-symbols 'tb-foo))
+ (unintern buz1 'tb-foo)
+ (equal (multiple-value-list (find-symbol "BUZ" 'tb-foo)) '(nil nil))
+ (null (package-shadowing-symbols 'tb-foo)))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (make-package "TB-FOO" :use nil)
+ (let ((buz0 (intern "BUZ" 'tb-foo))
+ (buz1 (make-symbol "BUZ")))
+ (export buz0 'tb-foo)
+ (and (equal (multiple-value-list (find-symbol "BUZ" 'tb-foo))
+ (list buz0 :external))
+ (eq (shadowing-import buz1 'tb-foo) t)
+
+ (equal (multiple-value-list (find-symbol "BUZ" 'tb-foo))
+ (list buz1 :internal))
+ (equal (list buz1) (package-shadowing-symbols 'tb-foo))
+ (unintern buz1 'tb-foo)
+ (equal (multiple-value-list (find-symbol "BUZ" 'tb-foo)) '(nil nil))
+ (null (package-shadowing-symbols 'tb-foo)))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (make-package "TB-FOO" :use nil)
+ (let ((buz0 (intern "BUZ" 'tb-foo))
+ (buz1 (make-symbol "BUZ")))
+ (export buz0 'tb-foo)
+ (shadow buz0 'tb-foo)
+ (and (equal (multiple-value-list (find-symbol "BUZ" 'tb-foo))
+ (list buz0 :external))
+ (eq (shadowing-import buz1 'tb-foo) t)
+ (equal (multiple-value-list (find-symbol "BUZ" 'tb-foo))
+ (list buz1 :internal))
+ (equal (list buz1) (package-shadowing-symbols 'tb-foo))
+ (unintern buz1 'tb-foo)
+ (equal (multiple-value-list (find-symbol "BUZ" 'tb-foo)) '(nil nil))
+ (null (package-shadowing-symbols 'tb-foo)))))
+
+
+
+;; import
+(eq (import '()) t)
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (make-package "TB-FOO" :use nil)
+ (let ((list nil))
+ (and (eq (import '() "TB-FOO") t)
+ (null (do-symbols (symbol "TB-FOO" list) (push symbol list))))))
+(progn
+ (when (find-package "A") (delete-package "A"))
+ (make-package "A" :use nil)
+ (and (not (find-symbol "CAR" 'a))
+ (eq (import 'cl:car 'a) t)
+ (equal (multiple-value-list (find-symbol "CAR" 'a)) '(cl:car :internal))))
+(progn
+ (when (find-package "A") (delete-package "A"))
+ (make-package "A" :use nil)
+ (and (not (find-symbol "CAR" 'a))
+ (eq (import 'cl:car #\A) t)
+ (equal (multiple-value-list (find-symbol "CAR" 'a)) '(cl:car :internal))))
+(progn
+ (when (find-package "A") (delete-package "A"))
+ (make-package "A" :use nil)
+ (and (not (find-symbol "CAR" 'a))
+ (eq (import 'cl:car "A") t)
+ (equal (multiple-value-list (find-symbol "CAR" 'a)) '(cl:car :internal))))
+(progn
+ (when (find-package "A") (delete-package "A"))
+ (make-package "A" :use nil)
+ (and (not (find-symbol "CAR" 'a))
+ (eq (import 'cl:car (find-package "A")) t)
+ (equal (multiple-value-list (find-symbol "CAR" 'a)) '(cl:car :internal))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (make-package "TB-FOO" :use nil)
+ (and (not (find-symbol "CAR" 'tb-foo))
+ (eq (import 'cl:car 'tb-foo) t)
+ (equal (multiple-value-list (find-symbol "CAR" 'tb-foo))
+ '(cl:car :internal))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (make-package "TB-FOO" :use nil)
+ (and (not (find-symbol "CAR" 'tb-foo))
+ (eq (import (list 'cl:car 'cl:cdr 'cl:list :test) 'tb-foo) t)
+ (equal (multiple-value-list (find-symbol "CAR" 'tb-foo))
+ '(cl:car :internal))
+ (equal (multiple-value-list (find-symbol "CDR" 'tb-foo))
+ '(cl:cdr :internal))
+ (equal (multiple-value-list (find-symbol "TEST" 'tb-foo))
+ '(:test :internal))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((*package* (make-package "TB-FOO" :use nil)))
+ (and (not (find-symbol "CAR" 'tb-foo))
+ (eq (import (list 'cl:car 'cl:cdr 'cl:list :test)) t)
+ (equal (multiple-value-list (find-symbol "CAR" 'tb-foo))
+ '(cl:car :internal))
+ (equal (multiple-value-list (find-symbol "CDR" 'tb-foo))
+ '(cl:cdr :internal))
+ (equal (multiple-value-list (find-symbol "TEST" 'tb-foo))
+ '(:test :internal)))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let (buz)
+ (make-package "TB-FOO" :use nil)
+ (and (export (setq buz (intern "BUZ" "TB-FOO")) "TB-FOO")
+ (equal (multiple-value-list (find-symbol "BUZ" "TB-FOO"))
+ (list buz :external))
+ (eq (import buz "TB-FOO") t)
+ (equal (multiple-value-list (find-symbol "BUZ" "TB-FOO"))
+ (list buz :external)))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let (buz)
+ (make-package "TB-FOO" :use nil)
+ (and (setq buz (intern "BUZ" "TB-FOO"))
+ (equal (multiple-value-list (find-symbol "BUZ" "TB-FOO"))
+ (list buz :internal))
+ (eq (import buz "TB-FOO") t)
+ (equal (multiple-value-list (find-symbol "BUZ" "TB-FOO"))
+ (list buz :internal)))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((*package* (make-package "TB-FOO" :use '(cl))))
+ (and (equal (multiple-value-list (find-symbol "CAR")) '(cl:car :inherited))
+ (eq (import 'cl:car) t)
+ (equal (multiple-value-list (find-symbol "CAR")) '(cl:car :internal)))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (make-package "TB-FOO" :use nil)
+ (let ((buz (make-symbol "BUZ")))
+ (and (null (symbol-package buz))
+ (eq (import buz 'tb-foo) t)
+ (eq (symbol-package buz) (find-package 'tb-foo)))))
+(HANDLER-CASE
+ (PROGN
+ (WHEN (FIND-PACKAGE "TB-FOO") (DELETE-PACKAGE "TB-FOO"))
+ (LET ((*PACKAGE* (MAKE-PACKAGE "TB-FOO" :USE '(CL))))
+ (IMPORT (MAKE-SYMBOL "CAR"))))
+ (PACKAGE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE
+ (PROGN
+ (WHEN (FIND-PACKAGE "TB-FOO") (DELETE-PACKAGE "TB-FOO"))
+ (LET ((*PACKAGE* (MAKE-PACKAGE "TB-FOO" :USE NIL)))
+ (INTERN "BUZ")
+ (IMPORT (MAKE-SYMBOL "BUZ"))))
+ (PACKAGE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE
+ (PROGN
+ (WHEN (FIND-PACKAGE "TB-FOO") (DELETE-PACKAGE "TB-FOO"))
+ (LET ((*PACKAGE* (MAKE-PACKAGE "TB-FOO" :USE NIL)))
+ (EXPORT (INTERN "BUZ"))
+ (IMPORT (MAKE-SYMBOL "BUZ"))))
+ (PACKAGE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE
+ (PROGN
+ (WHEN (FIND-PACKAGE "TB-FOO") (DELETE-PACKAGE "TB-FOO"))
+ (LET ((*PACKAGE* (MAKE-PACKAGE "TB-FOO" :USE NIL)))
+ (SHADOWING-IMPORT (MAKE-SYMBOL "BUZ"))
+ (IMPORT (MAKE-SYMBOL "BUZ"))))
+ (PACKAGE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+
+
+;; unintern
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (make-package "TB-FOO" :use nil)
+ (not (unintern 'cl:car "TB-FOO")))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (make-package "TB-FOO" :use nil)
+ (and (unintern (intern "BUZ" "TB-FOO") "TB-FOO")
+ (not (find-symbol "BUZ" "TB-FOO"))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((*package* (make-package "TB-FOO" :use nil)))
+ (not (unintern 'cl:car))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((*package* (make-package "TB-FOO" :use nil)))
+ (and (unintern (intern "BUZ"))
+ (not (find-symbol "BUZ")))))
+(progn
+ (when (find-package "A") (delete-package "A"))
+ (make-package "A" :use nil)
+ (and (unintern (intern "BUZ" "A") #\A)
+ (not (find-symbol "BUZ" "A"))))
+(progn
+ (when (find-package "A") (delete-package "A"))
+ (make-package "A" :use nil)
+ (and (unintern (intern "BUZ" "A") "A")
+ (not (find-symbol "BUZ" "A"))))
+(progn
+ (when (find-package "A") (delete-package "A"))
+ (make-package "A" :use nil)
+ (and (unintern (intern "BUZ" "A") 'a)
+ (not (find-symbol "BUZ" "A"))))
+(progn
+ (when (find-package "A") (delete-package "A"))
+ (make-package "A" :use nil)
+ (and (unintern (intern "BUZ" "A") (find-package 'a))
+ (not (find-symbol "BUZ" "A"))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((*package* (make-package "TB-FOO" :use '(cl))))
+ (and (equal (multiple-value-list (find-symbol "CAR")) '(cl:car :inherited))
+ (not (unintern 'cl:car)))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((*package* (make-package "TB-FOO" :use nil)))
+ (and (import 'cl:car)
+ (equal (multiple-value-list (find-symbol "CAR")) '(cl:car :internal))
+ (unintern 'cl:car)
+ (not (find-symbol "CAR")))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((*package* (make-package "TB-FOO" :use '(cl))))
+ (and (equal (multiple-value-list (find-symbol "CAR")) '(cl:car :inherited))
+ (import 'cl:car)
+ (equal (multiple-value-list (find-symbol "CAR")) '(cl:car :internal))
+ (unintern 'cl:car)
+ (equal (multiple-value-list (find-symbol "CAR"))
+ '(cl:car :inherited)))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((*package* (make-package "TB-FOO" :use nil))
+ (buz (make-symbol "BUZ")))
+ (and (null (symbol-package buz))
+ (import buz)
+ (shadow buz)
+ (eq (symbol-package buz) *package*)
+ (member buz (package-shadowing-symbols *package*))
+ (unintern buz)
+ (not (find-symbol "BUZ"))
+ (not (member buz (package-shadowing-symbols *package*)))
+ (null (symbol-package buz)))))
+(HANDLER-CASE
+ (PROGN
+ (WHEN (FIND-PACKAGE "TB-FOO") (DELETE-PACKAGE "TB-FOO"))
+ (WHEN (FIND-PACKAGE "TB-BAR-TO-USE")
+ (MAPCAN #'DELETE-PACKAGE (PACKAGE-USED-BY-LIST "TB-BAR-TO-USE"))
+ (DELETE-PACKAGE "TB-BAR-TO-USE"))
+ (LET ((*PACKAGE* (MAKE-PACKAGE "TB-FOO" :USE NIL)) SYMBOL)
+ (AND (SETQ SYMBOL (INTERN "CAR"))
+ (SHADOW "CAR")
+ (MAKE-PACKAGE "TB-BAR-TO-USE" :USE NIL)
+ (EXPORT (INTERN "CAR" "TB-BAR-TO-USE") "TB-BAR-TO-USE")
+ (USE-PACKAGE (LIST "TB-BAR-TO-USE" "CL"))
+ (EQUAL (MULTIPLE-VALUE-LIST (FIND-SYMBOL "CAR"))
+ (LIST SYMBOL :INTERNAL))
+ (UNINTERN SYMBOL))))
+ (PACKAGE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (let ((*package* (make-package "TB-FOO" :use nil))
+ symbol)
+ (and (setq symbol (intern "CAR"))
+ (shadow "CAR")
+ (make-package "TB-BAR-TO-USE" :use nil)
+ (import 'cl:car "TB-BAR-TO-USE")
+ (export 'cl:car "TB-BAR-TO-USE")
+ (use-package (list "TB-BAR-TO-USE" "CL"))
+ (equal (multiple-value-list (find-symbol "CAR"))
+ (list symbol :internal))
+ (unintern symbol))))
+
+
+
+;; use-package
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((*package* (make-package "TB-FOO" :use nil)))
+ (and (not (find-symbol "CAR"))
+ (eq (use-package 'cl) t)
+ (find-symbol "CAR"))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((*package* (make-package "TB-FOO" :use nil)))
+ (and (not (find-symbol "CAR"))
+ (eq (use-package "COMMON-LISP") t)
+ (find-symbol "CAR"))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((*package* (make-package "TB-FOO" :use nil)))
+ (and (not (find-symbol "CAR"))
+ (eq (use-package (find-package "COMMON-LISP")) t)
+ (find-symbol "CAR"))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((*package* (make-package "TB-FOO" :use nil)))
+ (and (not (find-symbol "CAR"))
+ (eq (use-package '(cl)) t)
+ (find-symbol "CAR"))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((*package* (make-package "TB-FOO" :use nil)))
+ (and (not (find-symbol "CAR"))
+ (eq (use-package '("COMMON-LISP")) t)
+ (find-symbol "CAR"))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((*package* (make-package "TB-FOO" :use nil)))
+ (and (not (find-symbol "CAR"))
+ (eq (use-package (list (find-package "COMMON-LISP"))) t)
+ (find-symbol "CAR"))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((package (make-package "TB-FOO" :use nil))
+ (*package* (find-package 'cl-user)))
+ (and (not (find-symbol "CAR" package))
+ (eq (use-package (list (find-package "COMMON-LISP")) package) t)
+ (find-symbol "CAR" package))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((package (make-package "TB-FOO" :use nil))
+ (*package* (find-package 'cl-user)))
+ (and (not (find-symbol "CAR" package))
+ (eq (use-package (list (find-package "COMMON-LISP")) "TB-FOO") t)
+ (find-symbol "CAR" package))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((package (make-package "TB-FOO" :use nil))
+ (*package* (find-package 'cl-user)))
+ (and (not (find-symbol "CAR" package))
+ (eq (use-package (list (find-package "COMMON-LISP")) 'tb-foo) t)
+ (find-symbol "CAR" package))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((package (make-package "TB-FOO" :use nil))
+ (*package* (find-package 'cl-user)))
+ (and (not (find-symbol "CAR" package))
+ (eq (use-package (list (find-package "COMMON-LISP"))
+ (find-package 'tb-foo))
+ t)
+ (find-symbol "CAR" package))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((*package* (make-package "TB-FOO" :use nil)))
+ (and (use-package 'cl)
+ (member (find-package 'cl) (package-use-list *package*)))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (let* ((*package* (make-package "TB-FOO" :use nil))
+ boo woo buz)
+ (and (make-package "TB-BAR-TO-USE" :use nil)
+ (export (list (setq boo (intern "BOO" 'tb-bar-to-use))) 'tb-bar-to-use)
+ (setq woo (intern "WOO"))
+ (export (list (setq buz (intern "BUZ"))))
+ (use-package (list 'tb-bar-to-use 'cl))
+ (equal (multiple-value-list (find-symbol "BOO")) (list boo :inherited))
+ (equal (multiple-value-list (find-symbol "WOO")) (list woo :internal))
+ (equal (multiple-value-list (find-symbol "BUZ")) (list buz :external))
+ (equal (multiple-value-list (find-symbol "CAR"))
+ (list 'cl:car :inherited))
+ (equal (multiple-value-list (find-symbol "LIST"))
+ (list 'cl:list :inherited)))))
+(HANDLER-CASE
+ (PROGN
+ (WHEN (FIND-PACKAGE "TB-FOO") (DELETE-PACKAGE "TB-FOO"))
+ (MAKE-PACKAGE "TB-FOO" :USE NIL)
+ (INTERN "CAR" 'TB-FOO)
+ (USE-PACKAGE 'CL 'TB-FOO))
+ (PACKAGE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE
+ (PROGN
+ (WHEN (FIND-PACKAGE "TB-FOO") (DELETE-PACKAGE "TB-FOO"))
+ (MAKE-PACKAGE "TB-FOO" :USE NIL)
+ (EXPORT (INTERN "CAR" 'TB-FOO) 'TB-FOO)
+ (USE-PACKAGE 'CL 'TB-FOO))
+ (PACKAGE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE
+ (PROGN
+ (WHEN (FIND-PACKAGE "TB-FOO") (DELETE-PACKAGE "TB-FOO"))
+ (WHEN (FIND-PACKAGE "TB-BAR-TO-USE")
+ (MAPCAN #'DELETE-PACKAGE (PACKAGE-USED-BY-LIST "TB-BAR-TO-USE"))
+ (DELETE-PACKAGE "TB-BAR-TO-USE"))
+ (MAKE-PACKAGE "TB-FOO" :USE '(CL))
+ (MAKE-PACKAGE "TB-BAR-TO-USE" :USE NIL)
+ (EXPORT (INTERN "CAR" 'TB-BAR-TO-USE) 'TB-BAR-TO-USE)
+ (USE-PACKAGE 'TB-BAR-TO-USE 'TB-FOO))
+ (PACKAGE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+
+
+;; unuse-package
+(progn
+ (when (find-package "TB-FOO-TO-USE")
+ (unuse-package (package-use-list "TB-FOO-TO-USE") "TB-FOO-TO-USE"))
+ (when (find-package "TB-BAR-TO-USE")
+ (unuse-package (package-use-list "TB-BAR-TO-USE") "TB-BAR-TO-USE"))
+ (when (find-package "TB-FOO-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-FOO-TO-USE"))
+ (delete-package "TB-FOO-TO-USE"))
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (and (make-package "TB-FOO-TO-USE" :use nil)
+ (make-package "TB-BAR-TO-USE" :use '("TB-FOO-TO-USE"))
+ (use-package "TB-BAR-TO-USE" "TB-FOO-TO-USE")
+ (export (intern "FOO" "TB-FOO-TO-USE") "TB-FOO-TO-USE")
+ (export (intern "BAR" "TB-BAR-TO-USE") "TB-BAR-TO-USE")
+ (eq (cadr (multiple-value-list (find-symbol "FOO" "TB-FOO-TO-USE")))
+ :external)
+ (eq (cadr (multiple-value-list (find-symbol "BAR" "TB-FOO-TO-USE")))
+ :inherited)
+ (eq (cadr (multiple-value-list (find-symbol "FOO" "TB-BAR-TO-USE")))
+ :inherited)
+ (eq (cadr (multiple-value-list (find-symbol "BAR" "TB-BAR-TO-USE")))
+ :external)
+ (unuse-package (package-use-list "TB-FOO-TO-USE") "TB-FOO-TO-USE")
+ (unuse-package (package-use-list "TB-BAR-TO-USE") "TB-BAR-TO-USE")))
+
+
+;; delete-package
+(progn
+ (when (find-package "a") (delete-package "a"))
+ (and (make-package "a" :use nil)
+ (delete-package "a")
+ (not (find-package "a"))))
+(progn
+ (when (find-package "a") (delete-package "a"))
+ (and (make-package "a" :use nil)
+ (delete-package #\a)
+ (not (find-package "a"))))
+(progn
+ (when (find-package "a") (delete-package "a"))
+ (and (make-package "a" :use nil)
+ (delete-package '|a|)
+ (not (find-package "a"))))
+(progn
+ (when (find-package "a") (delete-package "a"))
+ (and (make-package "a" :use nil)
+ (delete-package (find-package '|a|))
+ (not (find-package "a"))))
+(progn
+ (mapc #'(lambda (name) (when (find-package name) (delete-package name)))
+ '("a" "b" "c" "d" "e"))
+ (and (make-package "a" :nicknames '("b" "c" "d" "e") :use nil)
+ (delete-package "a")
+ (not (find-package "a"))
+ (not (find-package "b"))
+ (not (find-package "c"))
+ (not (find-package "d"))
+ (not (find-package "e"))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((package (make-package "TB-FOO" :use nil)))
+ (and (delete-package "TB-FOO")
+ (not (find-package "TB-FOO"))
+ (packagep package)
+ (null (package-name package)))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((package (make-package "TB-FOO" :use nil)))
+ (and (delete-package "TB-FOO")
+ (not (member package (list-all-packages))))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((package (make-package "TB-FOO" :use nil)))
+ (and (delete-package "TB-FOO")
+ (null (delete-package package)))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((car-home-package (symbol-package 'cl:car)))
+ (and (make-package "TB-FOO" :use nil)
+ (import 'cl:car "TB-FOO")
+ (delete-package 'tb-foo)
+ (eq 'cl:car (find-symbol "CAR" 'cl))
+ (eq (symbol-package 'cl:car) car-home-package)
+ (eq (intern "CAR" 'cl) 'cl:car))))
+(HANDLER-CASE
+ (PROGN
+ (WHEN (FIND-PACKAGE "TB-FOO") (DELETE-PACKAGE "TB-FOO"))
+ (WHEN (FIND-PACKAGE "TB-BAR-TO-USE")
+ (MAPCAN #'DELETE-PACKAGE (PACKAGE-USED-BY-LIST "TB-BAR-TO-USE"))
+ (DELETE-PACKAGE "TB-BAR-TO-USE"))
+ (AND (MAKE-PACKAGE "TB-BAR-TO-USE" :USE NIL)
+ (MAKE-PACKAGE "TB-FOO" :USE '("TB-BAR-TO-USE"))
+ (DELETE-PACKAGE "TB-BAR-TO-USE")))
+ (PACKAGE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+
+;; in-package
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((*package* (make-package "TB-FOO" :use nil)))
+ (in-package cl-user)
+ (eq *package* (find-package 'cl-user))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((*package* (make-package "TB-FOO" :use nil)))
+ (in-package "CL-USER")
+ (eq *package* (find-package 'cl-user))))
+(progn
+ (when (find-package "A") (delete-package "A"))
+ (make-package "A" :use nil)
+ (let ((*package* *package*))
+ (in-package "A")
+ (eq *package* (find-package 'a))))
+(progn
+ (when (find-package "A") (delete-package "A"))
+ (make-package "A" :use nil)
+ (let ((*package* *package*))
+ (in-package #\A)
+ (eq *package* (find-package 'a))))
+(progn
+ (when (find-package "A") (delete-package "A"))
+ (make-package "A" :use nil)
+ (let ((*package* *package*))
+ (in-package a)
+ (eq *package* (find-package 'a))))
+(progn
+ (when (find-package "A") (delete-package "A"))
+ (HANDLER-CASE (PROGN (IN-PACKAGE "A"))
+ (PACKAGE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)))
+
+
+;; defpackage
+(progn
+ (when (find-package "A") (delete-package "A"))
+ (packagep (defpackage #\A)))
+(progn
+ (when (find-package "A") (delete-package "A"))
+ (packagep (defpackage a)))
+(progn
+ (when (find-package "A") (delete-package "A"))
+ (packagep (defpackage "A")))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (and (packagep (defpackage "TB-FOO"))
+ (null (package-nicknames 'tb-foo))
+ (null (package-shadowing-symbols 'tb-foo))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (and (packagep (defpackage "TB-FOO" (:nicknames)))
+ (null (package-nicknames 'tb-foo))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (and (packagep (defpackage "TB-FOO" (:nicknames) (:shadow)))
+ (null (package-nicknames 'tb-foo))
+ (null (package-shadowing-symbols 'tb-foo))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (and (packagep (defpackage "TB-FOO"
+ (:nicknames)
+ (:shadow)
+ (:shadowing-import-from common-lisp)))
+ (null (package-nicknames 'tb-foo))
+ (null (package-shadowing-symbols 'tb-foo))))
+(progn
+ (mapc #'(lambda (name) (when (find-package name) (delete-package name)))
+ '("TB-FOO" "TB-FOO-NICKNAME-1" "TB-FOO-NICKNAME-2" "TB-FOO-NICKNAME-3"))
+ (and (packagep (defpackage "TB-FOO" (:nicknames tb-foo-nickname-1)))
+ (equal (package-nicknames 'tb-foo) '("TB-FOO-NICKNAME-1"))))
+#-CLISP
+;; Bruno: unfounded assumptions about the order of the package-nicknames list
+(progn
+ (mapc #'(lambda (name) (when (find-package name) (delete-package name)))
+ '("TB-FOO" "TB-FOO-NICKNAME-1" "TB-FOO-NICKNAME-2" "TB-FOO-NICKNAME-3"))
+ (and (packagep (defpackage "TB-FOO"
+ (:nicknames tb-foo-nickname-1 tb-foo-nickname-2
+ tb-foo-nickname-3)))
+ (equal (package-nicknames 'tb-foo)
+ '("TB-FOO-NICKNAME-1" "TB-FOO-NICKNAME-2" "TB-FOO-NICKNAME-3"))))
+(progn
+ (mapc #'(lambda (name) (when (find-package name) (delete-package name)))
+ '("A" "B" "C" "D"))
+ (and (packagep (defpackage "A" (:nicknames #\B c "D")))
+ (null (set-difference (package-nicknames 'a) '("B" "C" "D")
+ :test #'string=))))
+(progn
+ (mapc #'(lambda (name) (when (find-package name) (delete-package name)))
+ '("A" "B" "C" "D"))
+ (and (packagep (defpackage "A"
+ (:nicknames) (:nicknames #\B) (:nicknames c "D")))
+ (null (set-difference (package-nicknames 'a) '("B" "C" "D")
+ :test #'string=))))
+;(progn
+; (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+; (and (packagep (defpackage "TB-FOO"
+; (:nicknames) (:documentation "doc for tb-foo package")))
+; (packagep (find-package 'tb-foo))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (and (packagep (defpackage "TB-FOO" (:use)))
+ (null (package-use-list 'tb-foo))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (and (packagep (defpackage "TB-FOO" (:use cl)))
+ (equal (package-use-list 'tb-foo) (list (find-package 'cl)))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE" :use nil)
+ (and (packagep (defpackage "TB-FOO" (:use cl tb-bar-to-use)))
+ (null (set-difference (package-use-list 'tb-foo)
+ (mapcar #'find-package '(cl tb-bar-to-use))))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE" :use nil)
+ (and (packagep (defpackage "TB-FOO" (:use cl) (:use) (:use tb-bar-to-use)))
+ (null (set-difference (package-use-list 'tb-foo)
+ (mapcar #'find-package '(cl tb-bar-to-use))))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE" :use nil)
+ (and (packagep (defpackage "TB-FOO" (:use cl) (:use) (:use "TB-BAR-TO-USE")))
+ (null (set-difference (package-use-list 'tb-foo)
+ (mapcar #'find-package '(cl tb-bar-to-use))))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (when (find-package "B")
+ (mapcan #'delete-package (package-used-by-list "B"))
+ (delete-package "B"))
+ (make-package "B" :use nil)
+ (and (packagep (defpackage "TB-FOO" (:use cl) (:use) (:use "B")))
+ (null (set-difference (package-use-list 'tb-foo)
+ (mapcar #'find-package '(cl b))))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (when (find-package "B")
+ (mapcan #'delete-package (package-used-by-list "B"))
+ (delete-package "B"))
+ (make-package "B" :use nil)
+ (and (packagep (defpackage "TB-FOO" (:use cl) (:use) (:use #\B)))
+ (null (set-difference (package-use-list 'tb-foo)
+ (mapcar #'find-package '(cl b))))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (when (find-package "B")
+ (mapcan #'delete-package (package-used-by-list "B"))
+ (delete-package "B"))
+ (make-package "B" :use nil)
+ (and (packagep (eval `(defpackage "TB-FOO"
+ (:use cl) (:use) (:use ,(find-package #\B)))))
+ (null (set-difference (package-use-list 'tb-foo)
+ (mapcar #'find-package '(cl b))))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (and (packagep (defpackage "TB-FOO" (:shadow)))
+ (null (package-shadowing-symbols 'tb-foo))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (and (packagep (defpackage "TB-FOO" (:shadow "A")))
+ (equal (package-shadowing-symbols 'tb-foo)
+ (list (find-symbol "A" 'tb-foo)))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (and (packagep (defpackage "TB-FOO" (:shadow a #\b "c" "D")))
+ (null (set-difference (package-shadowing-symbols 'tb-foo)
+ (mapcar #'(lambda (name) (find-symbol name 'tb-foo))
+ '("A" "b" "c" "D"))))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (and (packagep (defpackage "TB-FOO" (:shadow a) (:shadow )
+ (:shadow #\b "c" "D"))))
+ (null (set-difference (package-shadowing-symbols 'tb-foo)
+ (mapcar #'(lambda (name) (find-symbol name 'tb-foo))
+ '("A" "b" "c" "D")))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (and (packagep (defpackage "TB-FOO" (:shadowing-import-from cl)))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (and (packagep (defpackage "TB-FOO" (:shadowing-import-from "COMMON-LISP")))
+ (null (package-shadowing-symbols 'tb-foo))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (and (packagep (defpackage "TB-FOO"
+ (:shadowing-import-from "COMMON-LISP" car cdr list)))
+ (every #'(lambda (name) (find-symbol name 'tb-foo)) '("CAR" "CDR" "LIST"))
+ (null (set-difference (package-shadowing-symbols 'tb-foo)
+ '(cl:car cl:cdr cl:list)))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (and (packagep (defpackage "TB-FOO"
+ (:shadowing-import-from "COMMON-LISP" car cdr)
+ (:shadowing-import-from "COMMON-LISP")
+ (:shadowing-import-from "COMMON-LISP" list)))
+ (every #'(lambda (name) (find-symbol name 'tb-foo)) '("CAR" "CDR" "LIST"))
+ (null (set-difference (package-shadowing-symbols 'tb-foo)
+ '(cl:car cl:cdr cl:list)))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE" :use nil)
+ (let ((buz (intern "BUZ" 'tb-bar-to-use)))
+ (and (packagep (defpackage "TB-FOO"
+ (:shadowing-import-from "COMMON-LISP" car cdr)
+ (:shadowing-import-from tb-bar-to-use "BUZ")))
+ (every #'(lambda (name) (find-symbol name 'tb-foo)) '("CAR" "CDR"))
+ (null (set-difference (package-shadowing-symbols 'tb-foo)
+ (list 'cl:car 'cl:cdr buz))))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE" :use nil)
+ (let ((buz (intern "BUZ" 'tb-bar-to-use))
+ (baz (intern "BAZ" 'tb-bar-to-use)))
+ (and (packagep (defpackage "TB-FOO"
+ (:shadowing-import-from "COMMON-LISP" car cdr)
+ (:shadowing-import-from tb-bar-to-use "BUZ" "BAZ")))
+ (every #'(lambda (name) (find-symbol name 'tb-foo))
+ '("CAR" "CDR" "BUZ" "BAZ"))
+ (null (set-difference (package-shadowing-symbols 'tb-foo)
+ (list 'cl:car 'cl:cdr buz baz))))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE" :use nil)
+ (let ((buz (intern "BUZ" 'tb-bar-to-use))
+ (baz (intern "BAZ" 'tb-bar-to-use)))
+ (and (packagep (defpackage "TB-FOO"
+ (:shadow "BOO")
+ (:shadowing-import-from "COMMON-LISP" car cdr)
+ (:shadowing-import-from tb-bar-to-use "BUZ" "BAZ")))
+ (every #'(lambda (name) (find-symbol name 'tb-foo))
+ '("CAR" "CDR" "BUZ" "BAZ" "BOO"))
+ (null (set-difference (package-shadowing-symbols 'tb-foo)
+ (list 'cl:car 'cl:cdr buz baz
+ (find-symbol "BOO" 'tb-foo)))))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (and (packagep (eval `(defpackage "TB-FOO"
+ (:shadowing-import-from ,(find-package 'cl)
+ "CAR" "CDR"))))
+ (every #'(lambda (name) (find-symbol name 'tb-foo)) '("CAR" "CDR"))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (and (packagep (eval `(defpackage "TB-FOO"
+ (:import-from ,(find-package 'cl)
+ "CAR" "CDR"))))
+ (every #'(lambda (name) (find-symbol name 'tb-foo)) '("CAR" "CDR"))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (packagep (defpackage "TB-FOO" (:import-from cl))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (and (packagep (defpackage "TB-FOO" (:import-from cl "CAR" "CDR")))
+ (every #'(lambda (name) (find-symbol name 'tb-foo)) '("CAR" "CDR"))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (and (packagep (defpackage "TB-FOO"
+ (:import-from "COMMON-LISP" car cdr list)))
+ (every #'(lambda (name) (find-symbol name 'tb-foo))
+ '("CAR" "CDR" "LIST"))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (and (packagep (defpackage "TB-FOO"
+ (:import-from "COMMON-LISP" car cdr)
+ (:import-from "COMMON-LISP")
+ (:import-from "COMMON-LISP" list)))
+ (every #'(lambda (name) (find-symbol name 'tb-foo))
+ '("CAR" "CDR" "LIST"))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE" :use nil)
+ (let ((buz (intern "BUZ" 'tb-bar-to-use)))
+ (and (packagep (defpackage "TB-FOO"
+ (:import-from "COMMON-LISP" car cdr)
+ (:import-from tb-bar-to-use "BUZ")))
+ (every #'(lambda (name) (find-symbol name 'tb-foo)) '("CAR" "CDR"))
+ (eq (find-symbol "BUZ" 'tb-foo) buz))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE" :use nil)
+ (let ((buz (intern "BUZ" 'tb-bar-to-use))
+ (baz (intern "BAZ" 'tb-bar-to-use)))
+ (and (packagep (defpackage "TB-FOO"
+ (:import-from "COMMON-LISP" car cdr)
+ (:import-from tb-bar-to-use "BUZ" "BAZ")))
+ (every #'(lambda (name) (find-symbol name 'tb-foo))
+ '("CAR" "CDR" "BUZ" "BAZ"))
+ (eq (find-symbol "BUZ" 'tb-foo) buz)
+ (eq (find-symbol "BAZ" 'tb-foo) baz))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (packagep (defpackage "TB-FOO" (:export))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (packagep (defpackage "TB-FOO" (:export) (:export))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (and (packagep (defpackage "TB-FOO" (:export "A")))
+ (eq (cadr (multiple-value-list (find-symbol "A" 'tb-foo))) :external)))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (and (packagep (defpackage "TB-FOO" (:export "A" "B" "C")))
+ (every #'(lambda (name)
+ (eq (cadr (multiple-value-list (find-symbol name 'tb-foo)))
+ :external))
+ '("A" "B" "C"))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (and (packagep (defpackage "TB-FOO" (:export "A" "B" "C")))
+ (every #'(lambda (name)
+ (eq (cadr (multiple-value-list (find-symbol name 'tb-foo)))
+ :external))
+ '("A" "B" "C"))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (and (packagep (defpackage "TB-FOO"
+ (:export "A") (:export "B") (:export "C")))
+ (every #'(lambda (name)
+ (eq (cadr (multiple-value-list (find-symbol name 'tb-foo)))
+ :external))
+ '("A" "B" "C"))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (and (packagep (defpackage "TB-FOO"
+ (:export "A" "B" "C" "CAR")
+ (:use cl)))
+ (every #'(lambda (name)
+ (eq (cadr (multiple-value-list (find-symbol name 'tb-foo)))
+ :external))
+ '("A" "B" "C" "CAR"))
+ (eq (find-symbol "CAR" 'tb-foo) 'cl:car)))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (and (packagep (defpackage "TB-FOO"
+ (:export "A" "B" "C" "CAR")
+ (:import-from cl "CAR")))
+ (every #'(lambda (name)
+ (eq (cadr (multiple-value-list (find-symbol name 'tb-foo)))
+ :external))
+ '("A" "B" "C" "CAR"))
+ (eq (find-symbol "CAR" 'tb-foo) 'cl:car)))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (and (packagep (defpackage "TB-FOO"
+ (:export "A" "B" "C" "CAR")
+ (:shadowing-import-from cl "CAR")))
+ (every #'(lambda (name)
+ (eq (cadr (multiple-value-list (find-symbol name 'tb-foo)))
+ :external))
+ '("A" "B" "C" "CAR"))
+ (eq (find-symbol "CAR" 'tb-foo) 'cl:car)))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE" :use nil)
+ (let ((buz (intern "BUZ" 'tb-bar-to-use)))
+ (and (packagep (defpackage "TB-FOO"
+ (:export "A" "B" "C" "CAR" "CDR" "BUZ")
+ (:use tb-bar-to-use)
+ (:import-from cl "CDR")
+ (:shadowing-import-from cl "CAR")))
+ (every #'(lambda (name)
+ (eq (cadr (multiple-value-list (find-symbol name 'tb-foo)))
+ :external))
+ '("A" "B" "C" "CAR" "CDR" "BUZ"))
+ (eq (find-symbol "CAR" 'tb-foo) 'cl:car)
+ (eq (find-symbol "CDR" 'tb-foo) 'cl:cdr)
+ (eq (find-symbol "BUZ" 'tb-bar-to-use) buz))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (packagep (defpackage "TB-FOO" (:intern))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (packagep (defpackage "TB-FOO" (:intern) (:intern))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (and (packagep (defpackage "TB-FOO" (:intern "A")))
+ (eq (cadr (multiple-value-list (find-symbol "A" 'tb-foo))) :internal)))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (and (packagep (defpackage "TB-FOO" (:intern "A" "B" "C")))
+ (every #'(lambda (name)
+ (eq (cadr (multiple-value-list (find-symbol name 'tb-foo)))
+ :internal))
+ '("A" "B" "C"))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (and (packagep (defpackage "TB-FOO" (:intern "A" "B" "C")))
+ (every #'(lambda (name)
+ (eq (cadr (multiple-value-list (find-symbol name 'tb-foo)))
+ :internal))
+ '("A" "B" "C"))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (and (packagep (defpackage "TB-FOO"
+ (:intern "A") (:intern "B") (:intern "C")))
+ (every #'(lambda (name)
+ (eq (cadr (multiple-value-list (find-symbol name 'tb-foo)))
+ :internal))
+ '("A" "B" "C"))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (and (packagep (defpackage "TB-FOO"
+ (:intern "A" "B" "C" "CAR")
+ (:use cl)))
+ (every #'(lambda (name)
+ (eq (cadr (multiple-value-list (find-symbol name 'tb-foo)))
+ :internal))
+ '("A" "B" "C"))
+ (equal (multiple-value-list (find-symbol "CAR" 'tb-foo))
+ '(cl:car :inherited))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (and (packagep (defpackage "TB-FOO" (:size 10)))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (and (packagep (defpackage "TB-FOO" (:size 0)))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (and (packagep (defpackage "TB-FOO" (:size 1000)))))
+
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE" :use nil)
+ (let ((buz (intern "BUZ" 'tb-bar-to-use)))
+ (export buz 'tb-bar-to-use)
+ (and
+ (packagep
+ (defpackage "TB-FOO"
+ (:size 10)
+ (:shadow "SHADOW1" "SHADOW2")
+ (:shadowing-import-from cl "CAR" "CDR")
+ (:use tb-bar-to-use)
+ (:import-from keyword "TEST")
+ (:intern "S0" "S1")
+ ;;(:documentation "doc")
+ (:nicknames "TB-FOO-NICKNAME-0" "TB-FOO-NICKNAME-1" "TB-FOO-NICKNAME-2")
+ (:export "SHADOW1" "CAR")))
+ (equal (multiple-value-list (find-symbol "BUZ" 'tb-foo-nickname-0))
+ (list buz :inherited))
+ (eq (cadr (multiple-value-list (find-symbol "SHADOW1" 'tb-foo-nickname-2)))
+ :external)
+ (eq (cadr (multiple-value-list (find-symbol "SHADOW2" 'tb-foo-nickname-2)))
+ :internal)
+ (equal (multiple-value-list (find-symbol "CAR" 'tb-foo-nickname-2))
+ (list 'cl:car :external))
+ (equal (multiple-value-list (find-symbol "CDR" 'tb-foo-nickname-2))
+ (list 'cl:cdr :internal))
+ (equal (multiple-value-list (find-symbol "TEST" 'tb-foo-nickname-2))
+ (list :test :internal))
+ (eq (cadr (multiple-value-list (find-symbol "S0" 'tb-foo-nickname-2)))
+ :internal)
+ (eq (cadr (multiple-value-list (find-symbol "S1" 'tb-foo-nickname-2)))
+ :internal)
+ )))
+
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (make-package "TB-BAR-TO-USE" :use nil)
+ (let ((buz (intern "BUZ" 'tb-bar-to-use)))
+ (export buz 'tb-bar-to-use)
+ (and
+ (packagep
+ (defpackage "TB-FOO"
+ (:export "SHADOW1")
+ (:size 10)
+ (:nicknames "TB-FOO-NICKNAME-1" "TB-FOO-NICKNAME-2")
+ (:shadow "SHADOW1")
+ (:shadowing-import-from cl "CAR")
+ (:intern "S1")
+ (:shadowing-import-from cl)
+ (:use tb-bar-to-use)
+ (:nicknames "TB-FOO-NICKNAME-0")
+ (:shadowing-import-from cl "CDR")
+ (:shadow "SHADOW2")
+ (:import-from keyword "TEST")
+ (:intern "S0")
+ ;;(:documentation "doc")
+ (:nicknames)
+ (:export "CAR")))
+ (equal (multiple-value-list (find-symbol "BUZ" 'tb-foo-nickname-0))
+ (list buz :inherited))
+ (eq (cadr (multiple-value-list (find-symbol "SHADOW1" 'tb-foo-nickname-2)))
+ :external)
+ (eq (cadr (multiple-value-list (find-symbol "SHADOW2" 'tb-foo-nickname-2)))
+ :internal)
+ (equal (multiple-value-list (find-symbol "CAR" 'tb-foo-nickname-2))
+ (list 'cl:car :external))
+ (equal (multiple-value-list (find-symbol "CDR" 'tb-foo-nickname-2))
+ (list 'cl:cdr :internal))
+ (equal (multiple-value-list (find-symbol "TEST" 'tb-foo-nickname-2))
+ (list :test :internal))
+ (eq (cadr (multiple-value-list (find-symbol "S0" 'tb-foo-nickname-2)))
+ :internal)
+ (eq (cadr (multiple-value-list (find-symbol "S1" 'tb-foo-nickname-2)))
+ :internal)
+ )))
+
+
+
+
+
+;; with-package-iterator
+(with-package-iterator (get "CL" :external)
+ (multiple-value-bind (more symbol status pkg) (get) (declare (ignore more))
+ (and (symbolp symbol) (eq status :external) (eq pkg (find-package 'cl)))))
+
+(with-package-iterator (get 'cl :external)
+ (multiple-value-bind (more symbol status pkg) (get) (declare (ignore more))
+ (and (symbolp symbol) (eq status :external) (eq pkg (find-package 'cl)))))
+
+(with-package-iterator (get (find-package 'cl) :external)
+ (multiple-value-bind (more symbol status pkg) (get) (declare (ignore more))
+ (and (symbolp symbol) (eq status :external) (eq pkg (find-package 'cl)))))
+
+(with-package-iterator (get '(cl) :external)
+ (multiple-value-bind (more symbol status pkg) (get) (declare (ignore more))
+ (and (symbolp symbol) (eq status :external) (eq pkg (find-package 'cl)))))
+
+(with-package-iterator (get (list "CL") :external)
+ (multiple-value-bind (more symbol status pkg) (get) (declare (ignore more))
+ (and (symbolp symbol) (eq status :external) (eq pkg (find-package 'cl)))))
+
+(with-package-iterator (get (list (find-package "COMMON-LISP")) :external)
+ (multiple-value-bind (more symbol status pkg) (get) (declare (ignore more))
+ (and (symbolp symbol) (eq status :external) (eq pkg (find-package 'cl)))))
+
+(with-package-iterator (get 'cl :external :internal :inherited)
+ (multiple-value-bind (more symbol status pkg) (get)
+ (declare (ignore more))
+ (and (symbolp symbol)
+ (member status '(:external :internal :inherited))
+ (eq pkg (find-package 'cl)))))
+
+(with-package-iterator (get (list 'cl) :internal)
+ (multiple-value-bind (more symbol status pkg) (get)
+ (or (not more)
+ (and (symbolp symbol)
+ (eq status :internal)
+ (eq pkg (find-package 'cl))))))
+
+(with-package-iterator (get (list 'cl) :inherited)
+ (multiple-value-bind (more symbol status pkg) (get)
+ (or (not more)
+ (and (symbolp symbol)
+ (eq status :inherited)
+ (eq pkg (find-package 'cl))))))
+
+;;; cmucl barfs on (macrolet () (declare))
+(progn
+ #-cmu
+ (with-package-iterator (get "CL" :external)
+ (declare (optimize (safety 3)))
+ (multiple-value-bind (more symbol status pkg) (get)
+ (declare (ignore more))
+ (and (symbolp symbol) (eq status :external) (eq pkg (find-package 'cl)))))
+ #+cmu 'skipped)
+(progn
+ (when (find-package "TB-FOO")
+ (delete-package "TB-FOO"))
+ (let ((package (make-package "TB-FOO" :use nil))
+ list)
+ (with-package-iterator (get package :internal)
+ (and (loop
+ (multiple-value-bind (more symbol status pkg) (get)
+ (declare (ignore status pkg))
+ (unless more (return t))
+ (push symbol list)))
+ (null list)))))
+(progn
+ (when (find-package "TB-FOO")
+ (delete-package "TB-FOO"))
+ (let ((package (make-package "TB-FOO" :use nil)))
+ (dolist (name '(a b c d e f g "S1" "S2" "ss"))
+ (intern name package))
+ (with-package-iterator (get package :internal)
+ (loop
+ (multiple-value-bind (more symbol status pkg) (get)
+ (unless more (return t))
+ (unless (and (eq status :internal)
+ (eq pkg package)
+ (eq symbol (find-symbol (string symbol) pkg)))
+ (return nil)))))))
+(progn
+ (when (find-package #\a)
+ (delete-package #\a))
+ (let ((package (make-package #\a :use nil)))
+ (dolist (name '(a b c d e f g "S1" "S2" "ss"))
+ (intern name package))
+ (with-package-iterator (get #\a :internal)
+ (loop
+ (multiple-value-bind (more symbol status pkg) (get)
+ (unless more (return t))
+ (unless (and (eq status :internal)
+ (eq pkg package)
+ (eq symbol (find-symbol (string symbol) pkg)))
+ (return nil)))))))
+(progn
+ (when (find-package #\a)
+ (delete-package #\a))
+ (let ((package (make-package #\a :use nil)))
+ (dolist (name '(a b c d e f g "S1" "S2" "ss"))
+ (intern name package))
+ (with-package-iterator (get (list #\a) :internal)
+ (loop
+ (multiple-value-bind (more symbol status pkg) (get)
+ (unless more (return t))
+ (unless (and (eq status :internal)
+ (eq pkg package)
+ (eq symbol (find-symbol (string symbol) pkg)))
+ (return nil)))))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (when (find-package "TB-BAR-TO-USE")
+ (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE"))
+ (delete-package "TB-BAR-TO-USE"))
+ (let* ((package (make-package "TB-BAR-TO-USE" :use nil))
+ (package-1 (make-package "TB-FOO" :use (list package)))
+ (symbol-list nil))
+ (export (intern "S" package) package)
+ (shadow '("S") package-1)
+ (with-package-iterator (get package-1 :internal :external :inherited)
+ (loop
+ (multiple-value-bind (more symbol status pkg) (get)
+ (declare (ignore status pkg))
+ (unless more (return t))
+ (push symbol symbol-list))))
+ (not (member (intern "S" package) symbol-list))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let* ((package (make-package "TB-FOO" :use nil))
+ (symbol-list nil))
+ (with-package-iterator (get package :internal :external)
+ (loop
+ (multiple-value-bind (more symbol status pkg) (get)
+ (declare (ignore status pkg))
+ (unless more (return t))
+ (push symbol symbol-list))))
+ (null symbol-list)))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let* ((package (make-package "TB-FOO" :use nil))
+ (symbol-list '(a b c d car cdr i lisp))
+ (list nil))
+ (dolist (symbol symbol-list)
+ (shadowing-import symbol package))
+ (with-package-iterator (get package :internal)
+ (loop
+ (multiple-value-bind (more symbol status pkg) (get)
+ (declare (ignore status pkg))
+ (unless more (return t))
+ (push symbol list))))
+ (null (set-difference symbol-list list))))
+(with-package-iterator (get 'cl :external)
+ (loop
+ (multiple-value-bind (more symbol status package) (get)
+ (unless more (return t))
+ (unless (and (eq status :external)
+ (eq package (find-package 'cl))
+ (eq symbol (find-symbol (symbol-name symbol) 'cl-user)))
+ (return nil)))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let* ((package (make-package "TB-FOO" :use 'cl)))
+ (shadow '("CAR") package)
+ (with-package-iterator (get package :external :inherited :internal)
+ (loop
+ (multiple-value-bind (more symbol status pkg) (get)
+ (declare (ignore pkg status))
+ (unless more (return t))
+ (when (eq symbol 'cl:car) (return nil)))))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let* ((*package* (make-package "TB-FOO" :use nil))
+ (names '("BLACK" "RED" "WHITE" "YELLOW" "VIOLET" "BROWN" "BLUE"))
+ list)
+ (mapc #'intern names)
+ (export (mapcar #'find-symbol
+ (mapcan #'(lambda (name)
+ (when (= (length name) 5) (list name))) names)))
+ (with-package-iterator (get *package* :external :inherited :internal)
+ (loop
+ (multiple-value-bind (more symbol status pkg) (get)
+ (declare (ignore pkg))
+ (unless more (return))
+ (push (symbol-name symbol) (getf list status)))))
+ (and (null (set-difference (getf list :external) '("BLACK" "WHITE" "BROWN")
+ :test #'string=))
+ (null (set-difference (getf list :internal)
+ '("RED" "YELLOW" "VIOLET" "BLUE")
+ :test #'string=))
+ (null (getf list :inherited)))))
+
+
+(flet ((test-package-iterator (package)
+ (unless (packagep package)
+ (setq package (find-package package)))
+ (let ((all-entries '())
+ (generated-entries '()))
+ (do-symbols (x package)
+ (multiple-value-bind (symbol accessibility)
+ (find-symbol (symbol-name x) package)
+ (push (list symbol accessibility) all-entries)))
+ (with-package-iterator (generator-fn package
+ :internal :external :inherited)
+ (loop
+ (multiple-value-bind (more? symbol accessibility pkg)
+ (generator-fn)
+ (declare (ignore pkg))
+ (unless more? (return))
+ (let ((l (multiple-value-list (find-symbol (symbol-name symbol)
+ package))))
+ (unless (equal l (list symbol accessibility))
+ (error "Symbol ~S not found as ~S in package ~A [~S]"
+ symbol accessibility (package-name package) l))
+ (push l generated-entries)))))
+ (unless (and (subsetp all-entries generated-entries :test #'equal)
+ (subsetp generated-entries all-entries :test #'equal))
+ (error "Generated entries and Do-Symbols entries don't correspond"))
+ t)))
+ (every #'test-package-iterator '("CL" "CL-USER" "KEYWORD")))
+
+
+;; do-symbols
+(null (do-symbols (symbol) (declare (ignore symbol))))
+(null (do-symbols (symbol *package*) (declare (ignore symbol))))
+(null (do-external-symbols (symbol) (declare (ignore symbol))))
+(null (do-external-symbols (symbol *package*) (declare (ignore symbol))))
+(null (do-all-symbols (symbol) (declare (ignore symbol))))
+(do-symbols (symbol *package* (null symbol)))
+(do-external-symbols (symbol *package* (null symbol)))
+(do-all-symbols (symbol (null symbol)))
+(do-symbols (symbol 'CL nil) (declare (ignore symbol)) (return t))
+(do-external-symbols (symbol 'CL nil) (declare (ignore symbol)) (return t))
+(do-all-symbols (symbol nil) (declare (ignore symbol)) (return t))
+(do-symbols (symbol 'cl nil)
+ (go start)
+ found
+ (return t)
+ start
+ (when (eq symbol 'cl:car)
+ (go found)))
+(do-external-symbols (symbol 'cl nil)
+ (go start)
+ found
+ (return t)
+ start
+ (when (eq symbol 'cl:car)
+ (go found)))
+(do-all-symbols (symbol nil)
+ (go start)
+ found
+ (return t)
+ start
+ (when (eq symbol 'cl:car)
+ (go found)))
+(let ((i 0)
+ (list nil)
+ (*package* (find-package "COMMON-LISP-USER")))
+ (do-symbols (symbol)
+ (push symbol list)
+ (incf i)
+ (when (= i 10) (return)))
+ (every #'symbolp list))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((*package* (make-package "TB-FOO" :use nil))
+ (name-list '("A" "B" "DOG" "CAT" "giraffe" "hippo" "wolf"))
+ (list))
+ (export (mapcar #'intern name-list))
+ (null (set-difference (do-symbols (symbol *package* list)
+ (pushnew symbol list))
+ (mapcar #'find-symbol name-list)))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((*package* (make-package "TB-FOO" :use nil))
+ list)
+ (do-symbols (symbol *package*) (push symbol list))
+ (null list)))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((*package* (make-package "TB-FOO" :use nil))
+ list)
+ (do-symbols (symbol) (push symbol list))
+ (null list)))
+(do-symbols (symbol 'cl t)
+ (unless (eq symbol (find-symbol (symbol-name symbol) 'cl))
+ (return nil)))
+(do-symbols (symbol 'keyword t)
+ (unless (equal
+ (multiple-value-list (find-symbol (symbol-name symbol) 'keyword))
+ (list symbol :external))
+ (return nil)))
+
+
+;; do-external-symbols
+(let (list1 list2)
+ (and (do-external-symbols (symbol 'keyword t) (push symbol list1))
+ (do-symbols (symbol 'keyword t) (push symbol list2))
+ (null (set-difference list1 list2))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((*package* (make-package "TB-FOO" :use nil))
+ list)
+ (do-external-symbols (symbol *package*) (push symbol list))
+ (null list)))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((*package* (make-package "TB-FOO" :use nil))
+ list)
+ (do-external-symbols (symbol) (push symbol list))
+ (null list)))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((*package* (make-package "TB-FOO" :use nil))
+ (name-list '("A" "B" "DOG" "CAT" "giraffe" "hippo" "wolf"))
+ (list))
+ (export (mapcar #'intern name-list))
+ (null (set-difference (do-external-symbols (symbol *package* list)
+ (pushnew symbol list))
+ (mapcar #'find-symbol name-list)))))
+(progn
+ (when (find-package "TB-FOO") (delete-package "TB-FOO"))
+ (let ((*package* (make-package "TB-FOO" :use nil))
+ (name-list '("A" "B" "DOG" "CAT" "giraffe" "hippo" "wolf"))
+ (list))
+ (mapcar #'intern name-list)
+ (null (do-external-symbols (symbol *package* list)
+ (pushnew symbol list)))))
+
+
+;; do-all-symbols
+(let ((i 0)
+ (list nil))
+ (do-all-symbols (symbol)
+ (push symbol list)
+ (incf i)
+ (when (= i 10) (return)))
+ (every #'symbolp list))
+(let ((list nil))
+ (do-all-symbols (symbol) (push symbol list))
+ (with-package-iterator (get (list-all-packages) :external :internal)
+ (loop
+ (multiple-value-bind (more symbol status package) (get)
+ (declare (ignore status package))
+ (unless more (return t))
+ (unless (member symbol list) (return nil))))))
+
diff --git a/Sacla/tests/must-package.patch b/Sacla/tests/must-package.patch
new file mode 100644
index 0000000..0bc747e
--- /dev/null
+++ b/Sacla/tests/must-package.patch
@@ -0,0 +1,12 @@
+*** sacla/lisp/test/must-package.lisp 2004-08-03 08:34:55.000000000 +0200
+--- CLISP/clisp-20040712/sacla-tests/must-package.lisp 2004-08-06 03:13:08.000000000 +0200
+***************
+*** 1459,1464 ****
+--- 1459,1465 ----
+ '("TB-FOO" "TB-FOO-NICKNAME-1" "TB-FOO-NICKNAME-2" "TB-FOO-NICKNAME-3"))
+ (and (packagep (defpackage "TB-FOO" (:nicknames tb-foo-nickname-1)))
+ (equal (package-nicknames 'tb-foo) '("TB-FOO-NICKNAME-1"))))
++ #-CLISP ; unfounded assumptions about the order of the package-nicknames list
+ (progn
+ (mapc #'(lambda (name) (when (find-package name) (delete-package name)))
+ '("TB-FOO" "TB-FOO-NICKNAME-1" "TB-FOO-NICKNAME-2" "TB-FOO-NICKNAME-3"))
diff --git a/Sacla/tests/must-printer.lisp b/Sacla/tests/must-printer.lisp
new file mode 100644
index 0000000..33a43ee
--- /dev/null
+++ b/Sacla/tests/must-printer.lisp
@@ -0,0 +1,1610 @@
+;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
+;; ALL RIGHTS RESERVED.
+;;
+;; $Id: must-printer.lisp,v 1.16 2004/08/09 02:49:54 yuji Exp $
+;;
+;; 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.
+;;
+;; 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.
+
+;; printer control variables
+(eql *print-base* 10)
+(null *print-radix*)
+(eq *print-case* :upcase)
+*print-gensym*
+(null *print-level*)
+(null *print-length*)
+(null *print-circle*)
+*print-escape*
+(null *print-readably*)
+*print-pprint-dispatch*
+(null *print-lines*)
+(null *print-right-margin*)
+
+
+;; string
+(string= "abc" (write-to-string "abc" :escape nil))
+(string= "\"abc\"" (write-to-string "abc" :readably t))
+(string= "\"abc\"" (write-to-string "abc" :escape nil :readably t))
+
+(string= "ABC" (write-to-string "ABC" :escape nil))
+(string= "\"ABC\"" (write-to-string "ABC" :readably t))
+(string= "\"ABC\"" (write-to-string "ABC" :escape nil :readably t))
+
+(string= "\"A\\\\B\\\"C\"" (write-to-string "A\\B\"C" :escape nil :readably t))
+(string= "\"A\\\\B\\\"C\"" (write-to-string "A\\B\"C"))
+(string= "A\\B\"C" (write-to-string "A\\B\"C" :escape nil))
+(let ((str "a\\b\""))
+ (and (= 4 (length str))
+ (string= str (read-from-string (write-to-string str)))))
+(let ((str "a\\b\""))
+ (and (= 4 (length str))
+ (string= str (read-from-string
+ (write-to-string str :escape nil :readably t)))))
+
+(string= "\"\\\"\"" (write-to-string "\""))
+(string= "\"\\\"\"" (write-to-string "\"" :escape nil :readably t))
+(string= "\"" (read-from-string (write-to-string "\"")))
+(string= "\"" (read-from-string (write-to-string "\"" :escape nil :readably t)))
+
+(string= "\"\"" (write-to-string ""))
+(string= "\"\"" (write-to-string "" :escape nil :readably t))
+(string= "" (write-to-string "" :escape nil))
+
+(string= "\" \"" (write-to-string " "))
+(string= "\" \"" (write-to-string " " :escape nil :readably t))
+(string= " " (write-to-string " " :escape nil))
+
+(string= "\" \"" (write-to-string " "))
+(string= "\" \"" (write-to-string " " :escape nil :readably t))
+(string= " " (write-to-string " " :escape nil))
+
+(string= "\"
+\"" (write-to-string "
+" :escape nil :readably t))
+(string= "
+" (write-to-string "
+" :escape nil))
+
+
+(string= "\"\\\"\\\"\\\"\\\"\\\"\\\"\""
+ (write-to-string "\"\"\"\"\"\"" :readably t))
+(string= "\"\"\"\"\"\""
+ (read-from-string (write-to-string "\"\"\"\"\"\"" :readably t)))
+(string= "\"\"\"\"\"\""
+ (write-to-string "\"\"\"\"\"\"" :readably nil :escape nil))
+(string= "\" \""
+ (write-to-string " " :readably t))
+
+(string= "\"\\\"Hi\\\" \\\"Oh, hi!\\\"\""
+ (write-to-string "\"Hi\" \"Oh, hi!\"" :readably t))
+(string= "\"Hi\" \"Oh, hi!\""
+ (write-to-string "\"Hi\" \"Oh, hi!\""
+ :pretty nil :readably nil :escape nil))
+
+(string= "abc"
+ (write-to-string "abc" :array nil :escape nil)
+ ;; 22.1.3.4 Printing Strings
+ ;; http://www.lispworks.com/reference/HyperSpec/Body/22_acd.htm
+ ;; The printing of strings is not affected by *print-array*.
+ )
+
+
+
+(string= "abc"
+ (write-to-string (make-array 10
+ :element-type 'character
+ :initial-contents "abcdefghij"
+ :fill-pointer 3)
+ :escape nil))
+
+
+
+;; integer, *print-base*, *print-radix*
+(string= (write-to-string 0) "0")
+(string= (write-to-string -0) "0")
+(string= (write-to-string 9) "9")
+(string= (write-to-string -10) "-10")
+(string= (write-to-string 1234567890987654321234567890987654321)
+ "1234567890987654321234567890987654321")
+(let ((*print-radix* t)) (string= (write-to-string 0) "0."))
+(let ((*print-radix* t)) (string= (write-to-string -52) "-52."))
+(let ((*print-radix* t))
+ (string= (write-to-string -1234567890987654321234567890987654321)
+ "-1234567890987654321234567890987654321."))
+
+(let ((*print-base* 2)) (string= (write-to-string 0) "0"))
+(let ((*print-base* 2)) (string= (write-to-string 10) "1010"))
+(let ((*print-base* 2))
+ (string= (write-to-string -1234567890987654321234567890987654321)
+ "-111011011100010011100101100000010011000101110111101001110100010101110010000101001111011010110110001011000001110010110001"))
+(let ((*print-base* 2) (*print-radix* t))
+ (string= (write-to-string 11) "#b1011"))
+(let ((*print-base* 2) (*print-radix* t))
+ (string= (write-to-string -15) "#b-1111"))
+(let ((*print-base* 2) (*print-radix* t))
+ (string= (write-to-string 1234567890987654321234567890987654321)
+ "#b111011011100010011100101100000010011000101110111101001110100010101110010000101001111011010110110001011000001110010110001"))
+
+
+(let ((*print-base* 8)) (string= (write-to-string 10) "12"))
+(let ((*print-base* 8)) (string= (write-to-string -21) "-25"))
+(let ((*print-base* 8) (*print-radix* t))
+ (string= (write-to-string 11) "#o13"))
+(let ((*print-base* 8) (*print-radix* t))
+ (string= (write-to-string -13) "#o-15"))
+(let ((*print-base* 8))
+ (string= (write-to-string 1234567890987654321234567890987654321)
+ "7334234540230567516425620517326613016261"))
+(let ((*print-base* 8) (*print-radix* t))
+ (string= (write-to-string -1234567890987654321234567890987654321)
+ "#o-7334234540230567516425620517326613016261"))
+
+
+(let ((*print-base* 16)) (string= (write-to-string 20) "14"))
+(let ((*print-base* 16)) (string= (write-to-string -22) "-16"))
+(let ((*print-base* 16)) (string= (string-upcase (write-to-string -30)) "-1E"))
+(let ((*print-base* 16) (*print-radix* t))
+ (string= (write-to-string 21) "#x15"))
+(let ((*print-base* 16) (*print-radix* t))
+ (string= (write-to-string -23) "#x-17"))
+(let ((*print-base* 16))
+ (string= (string-upcase (write-to-string 1234567890987654321234567890987654321))
+ "EDC4E5813177A7457214F6B62C1CB1"))
+(let ((*print-base* 16) (*print-radix* t))
+ (string= (string-upcase (write-to-string -1234567890987654321234567890987654321))
+ "#X-EDC4E5813177A7457214F6B62C1CB1"))
+
+(let ((*print-base* 24.)) (string= (write-to-string 9) "9"))
+(let ((*print-base* 24.))
+ (string= (string-upcase (write-to-string 17)) "H"))
+(let ((*print-base* 24.))
+ (string= (string-upcase (write-to-string -17)) "-H"))
+(let ((*print-base* 24.) (*print-radix* t))
+ (string= (write-to-string 9.) "#24r9"))
+(let ((*print-base* 24.) (*print-radix* t))
+ (string-equal (write-to-string 23.) "#24rN"))
+(let ((*print-base* 24.) (*print-radix* t))
+ (string-equal (write-to-string -23.) "#24r-N"))
+(let ((*print-base* 24))
+ (string= (string-upcase (write-to-string 1234567890987654321234567890987654321))
+ "1EDFC9EAF544D8D12FI44J4FMCH"))
+
+(loop for *print-base* from 2 upto 36
+ always (string= (write-to-string 0) "0"))
+(loop for *print-base* from 2 upto 36
+ always (string= (write-to-string -1) "-1"))
+(loop for *print-base* from 2 upto 36
+ always (string= (string-upcase (write-to-string (1- *print-base*)))
+ (string (char "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"
+ (1- *print-base*)))))
+(loop for *print-base* from 2 upto 36
+ always (string= (write-to-string *print-base*) "10"))
+(let ((list nil))
+ (equal (dotimes (i 35 (reverse list))
+ (let ((*print-base* (+ i 2)))
+ ;;collect the decimal number 40 in each base from 2 to 36
+ (push (string-upcase (write-to-string 40)) list)))
+ '("101000" "1111" "220" "130" "104" "55" "50" "44" "40" "37" "34"
+ "31" "2C" "2A" "28" "26" "24" "22" "20" "1J" "1I" "1H" "1G" "1F"
+ "1E" "1D" "1C" "1B" "1A" "19" "18" "17" "16" "15" "14")))
+(let ((list nil))
+ (equal (dotimes (i 35 (reverse list))
+ (let ((*print-base* (+ i 2))
+ (*print-radix* t))
+ ;;collect the decimal number 40 in each base from 2 to 36
+ (push (string-upcase (write-to-string 40)) list)))
+ '("#B101000" "#3R1111" "#4R220" "#5R130" "#6R104" "#7R55" "#O50"
+ "#9R44" "40." "#11R37" "#12R34" "#13R31" "#14R2C" "#15R2A"
+ "#X28" "#17R26" "#18R24" "#19R22" "#20R20" "#21R1J" "#22R1I"
+ "#23R1H" "#24R1G" "#25R1F" "#26R1E" "#27R1D" "#28R1C" "#29R1B"
+ "#30R1A" "#31R19" "#32R18" "#33R17" "#34R16" "#35R15" "#36R14")))
+
+
+;; ratio, *print-base*, *print-radix*
+(string= (write-to-string 1/3) "1/3")
+(string= (write-to-string -1/2) "-1/2")
+(string= (write-to-string -3/5) "-3/5")
+(let ((*print-radix* t))
+ ;; Variable *PRINT-BASE*, *PRINT-RADIX*
+ ;; http://www.lispworks.com/reference/HyperSpec/Body/v_pr_bas.htm
+ ;; For integers, base ten is indicated by a trailing decimal point instead
+ ;; of a leading radix specifier; for ratios, #10r is used.
+ (string= (write-to-string 1/15) "#10r1/15"))
+(let ((*print-radix* t))
+ (string= (write-to-string -4/15) "#10r-4/15"))
+(string= (write-to-string 2/1234567890987654321234567890987654321)
+ "2/1234567890987654321234567890987654321")
+(string= (write-to-string 1234567890987654321234567890987654321/4)
+ "1234567890987654321234567890987654321/4")
+(let ((*print-radix* t))
+ (string= (write-to-string 2/1234567890987654321234567890987654321)
+ "#10r2/1234567890987654321234567890987654321"))
+
+(let ((*print-base* 2)) (string= (write-to-string 1/3) "1/11"))
+(let ((*print-base* 2)) (string= (write-to-string -1/2) "-1/10"))
+(let ((*print-base* 2)) (string= (write-to-string -3/5) "-11/101"))
+(let ((*print-base* 2) (*print-radix* t))
+ (string= (write-to-string 1/15) "#b1/1111"))
+(let ((*print-base* 2) (*print-radix* t))
+ (string= (write-to-string -3/16) "#b-11/10000"))
+(let ((*print-base* 2))
+ (string= (write-to-string 2/1234567890987654321234567890987654321)
+ "10/111011011100010011100101100000010011000101110111101001110100010101110010000101001111011010110110001011000001110010110001"))
+(let ((*print-base* 2))
+ (string= (write-to-string -1234567890987654321234567890987654321/2)
+ "-111011011100010011100101100000010011000101110111101001110100010101110010000101001111011010110110001011000001110010110001/10"))
+(let ((*print-base* 2) (*print-radix* t))
+ (string= (write-to-string 2/1234567890987654321234567890987654321)
+ "#b10/111011011100010011100101100000010011000101110111101001110100010101110010000101001111011010110110001011000001110010110001"))
+
+(let ((*print-base* 8)) (string= (write-to-string 1/3) "1/3"))
+(let ((*print-base* 8)) (string= (write-to-string -1/4) "-1/4"))
+(let ((*print-base* 8)) (string= (write-to-string -3/7) "-3/7"))
+(let ((*print-base* 8)
+ (*print-radix* t))
+ (string= (write-to-string 1/3) "#o1/3"))
+(let ((*print-base* 8)
+ (*print-radix* t))
+ (string= (write-to-string -3/7) "#o-3/7"))
+(let ((*print-base* 8)
+ (*print-radix* t))
+ (string= (write-to-string -15/11) "#o-17/13"))
+(let ((*print-base* 8))
+ (string= (write-to-string 2/1234567890987654321234567890987654321)
+ "2/7334234540230567516425620517326613016261"))
+(let ((*print-base* 8)
+ (*print-radix* t))
+ (string= (write-to-string -1234567890987654321234567890987654321/4)
+ "#o-7334234540230567516425620517326613016261/4"))
+
+(let ((*print-base* 16)) (string= (write-to-string 1/8) "1/8"))
+(let ((*print-base* 16)) (string= (write-to-string -1/9) "-1/9"))
+(let ((*print-base* 16)) (string-equal (write-to-string -9/10) "-9/A"))
+(let ((*print-base* 16)
+ (*print-radix* t))
+ (string= (write-to-string 1/3) "#x1/3"))
+(let ((*print-base* 16)
+ (*print-radix* t))
+ (string= (write-to-string 3/8) "#x3/8"))
+(let ((*print-base* 16)
+ (*print-radix* t))
+ (string= (write-to-string -4/9) "#x-4/9"))
+(let ((*print-base* 16))
+ (string= (write-to-string 2/1234567890987654321234567890987654321)
+ "2/EDC4E5813177A7457214F6B62C1CB1"))
+(let ((*print-base* 16)
+ (*print-radix* t))
+ (string-equal (write-to-string 1234567890987654321234567890987654321/4)
+ "#xEDC4E5813177A7457214F6B62C1CB1/4"))
+(let ((*print-base* 16)
+ (*print-radix* t))
+ (string-equal (write-to-string 1234567890987654321234567890987654321/1234)
+ "#xEDC4E5813177A7457214F6B62C1CB1/4D2"))
+
+(let ((*print-base* 21)) (string= (write-to-string 1/8) "1/8"))
+(let ((*print-base* 21)) (string= (write-to-string -1/9) "-1/9"))
+(let ((*print-base* 21)) (string-equal (write-to-string -9/10) "-9/A"))
+(let ((*print-base* 21)
+ (*print-radix* t))
+ (string= (write-to-string 1/4) "#21r1/4"))
+(let ((*print-base* 21)
+ (*print-radix* t))
+ (string-equal (write-to-string -1/20) "#21r-1/K"))
+(let ((*print-base* 21))
+ (string= (write-to-string 2/1234567890987654321234567890987654321)
+ "2/29FADE40CGDJK4D0654KEAD5K6EK"))
+(let ((*print-base* 21)
+ (*print-radix* t))
+ (string-equal (write-to-string 1234567890987654321234567890987654321/1234)
+ "#21r29FADE40CGDJK4D0654KEAD5K6EK/2GG"))
+
+(loop for *print-base* from 3 upto 36
+ always (string= (write-to-string 1/2) "1/2"))
+(loop for *print-base* from 4 upto 36
+ always (string= (write-to-string -1/3) "-1/3"))
+(loop for *print-base* from 3 upto 36
+ always (string=
+ (string-upcase (write-to-string (/ 1 (1- *print-base*))))
+ (concatenate 'string
+ "1/"
+ (string (char "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"
+ (1- *print-base*))))))
+(loop for *print-base* from 2 upto 36
+ always (string= (write-to-string (/ 1 *print-base*)) "1/10"))
+(let ((list nil))
+ (equal (dotimes (i 35 (reverse list))
+ (let ((*print-base* (+ i 2)))
+ ;;collect the decimal number 40 in each base from 2 to 36
+ (push (string-upcase (write-to-string 41/40)) list)))
+ '("101001/101000" "1112/1111" "221/220" "131/130" "105/104"
+ "56/55" "51/50" "45/44" "41/40" "38/37" "35/34"
+ "32/31" "2D/2C" "2B/2A" "29/28" "27/26" "25/24" "23/22" "21/20"
+ "1K/1J" "1J/1I" "1I/1H" "1H/1G" "1G/1F"
+ "1F/1E" "1E/1D" "1D/1C" "1C/1B" "1B/1A" "1A/19" "19/18" "18/17"
+ "17/16" "16/15" "15/14")))
+(let ((list nil))
+ (equal (dotimes (i 35 (reverse list))
+ (let ((*print-base* (+ i 2))
+ (*print-radix* t))
+ ;;collect the decimal number 40 in each base from 2 to 36
+ (push (string-upcase (write-to-string 41/40)) list)))
+ '("#B101001/101000" "#3R1112/1111" "#4R221/220" "#5R131/130"
+ "#6R105/104" "#7R56/55" "#O51/50" "#9R45/44" "#10R41/40"
+ "#11R38/37" "#12R35/34" "#13R32/31" "#14R2D/2C" "#15R2B/2A"
+ "#X29/28" "#17R27/26" "#18R25/24" "#19R23/22" "#20R21/20"
+ "#21R1K/1J" "#22R1J/1I" "#23R1I/1H" "#24R1H/1G" "#25R1G/1F"
+ "#26R1F/1E" "#27R1E/1D" "#28R1D/1C" "#29R1C/1B" "#30R1B/1A"
+ "#31R1A/19" "#32R19/18" "#33R18/17" "#34R17/16" "#35R16/15"
+ "#36R15/14")))
+
+;; character
+(let ((*print-escape* nil))
+ (string= (write-to-string #\a) "a"))
+(let ((*print-escape* nil)
+ (*print-readably* nil))
+ (string= (write-to-string #\d) "d"))
+(let ((*print-escape* nil))
+ (string= (write-to-string #\m) "m"))
+(let ((*print-escape* nil))
+ (string= (write-to-string #\z) "z"))
+(let ((*print-escape* nil)
+ (*print-readably* nil))
+ (loop for c across " !\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_'abcdefghijklmnopqrstuvwxyz{|}~"
+ always (string= (write-to-string c) (string c))))
+(let ((*print-escape* nil))
+ (loop for c across " !\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_'abcdefghijklmnopqrstuvwxyz{|}~"
+ always (string= (write-to-string c) (string c))))
+
+(string= (write-to-string #\b) "#\\b")
+(string= (write-to-string #\n) "#\\n")
+(string= (write-to-string #\x) "#\\x")
+(let ((*print-escape* nil)
+ (*print-readably* t))
+ (string= (write-to-string #\c) "#\\c"))
+(loop for c across "!#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[]^_'abcdefghijklmnopqrstuvwxyz{|}~"
+ always (string= (write-to-string c) (concatenate 'string "#\\" (string c))))
+(string= (write-to-string #\\) "#\\\\")
+(string= (write-to-string #\") "#\\\"")
+(let ((*print-readably* t)
+ (*print-escape* nil))
+ (loop for c across "!#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[]^_'abcdefghijklmnopqrstuvwxyz{|}~"
+ always (string= (write-to-string c) (concatenate 'string "#\\" (string c)))))
+(let ((*print-readably* t)
+ (*print-escape* t))
+ (loop for c across "!#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[]^_'abcdefghijklmnopqrstuvwxyz{|}~"
+ always (string= (write-to-string c) (concatenate 'string "#\\" (string c)))))
+(let ((*print-readably* nil)
+ (*print-escape* t))
+ (loop for c across "!#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[]^_'abcdefghijklmnopqrstuvwxyz{|}~"
+ always (string= (write-to-string c) (concatenate 'string "#\\" (string c)))))
+
+(progn
+ (let ((*print-readably* t))
+ ;; 22.1.3.2 Printing Characters
+ ;; http://www.lispworks.com/reference/HyperSpec/Body/22_acb.htm
+ ;; For the graphic standard characters, the character itself is always used
+ ;; for printing in #\ notation---even if the character also has a name[5].
+ ;;
+ ;; http://www.lispworks.com/reference/HyperSpec/Body/26_glo_g.htm#graphic
+ ;; graphic adj. -snip- Space is defined to be graphic.
+ (string= (write-to-string #\Space) "#\\ "))
+ 'skipped)
+
+
+;;; symbol
+;; accessible symbol, escaping off, *print-case* :capitalize
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :upcase)
+ (string= "abc" (write-to-string '|abc| :escape nil :case :capitalize)))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :downcase)
+ (string= "Abc" (write-to-string '|abc| :escape nil :case :capitalize)))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :preserve)
+ (string= "abc" (write-to-string '|abc| :escape nil :case :capitalize)))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :invert)
+ (string= "ABC" (write-to-string '|abc| :escape nil :case :capitalize)))
+
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :upcase)
+ (string= "Abc" (write-to-string '|ABC| :escape nil :case :capitalize)))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :downcase)
+ (string= "ABC" (write-to-string '|ABC| :escape nil :case :capitalize)))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :preserve)
+ (string= "ABC" (write-to-string '|ABC| :escape nil :case :capitalize)))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :invert)
+ (string= "abc" (write-to-string '|ABC| :escape nil :case :capitalize)))
+
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :upcase)
+ (string= "Abc-abc"
+ (write-to-string '|ABC-abc| :escape nil :case :capitalize)))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :downcase)
+ (string= "ABC-Abc"
+ (write-to-string '|ABC-abc| :escape nil :case :capitalize)))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :preserve)
+ (string= "ABC-abc"
+ (write-to-string '|ABC-abc| :escape nil :case :capitalize)))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :invert)
+ (string= "ABC-abc"
+ (write-to-string '|ABC-abc| :escape nil :case :capitalize)))
+
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :upcase)
+ (string= "abc-Abc"
+ (write-to-string '|abc-ABC| :escape nil :case :capitalize)))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :downcase)
+ (string= "Abc-ABC"
+ (write-to-string '|abc-ABC| :escape nil :case :capitalize)))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :preserve)
+ (string= "abc-ABC"
+ (write-to-string '|abc-ABC| :escape nil :case :capitalize)))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :invert)
+ (string= "abc-ABC"
+ (write-to-string '|abc-ABC| :escape nil :case :capitalize)))
+
+
+;; accessible symbol, escaping off, *print-case* :upcase
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :upcase)
+ (string= "abc" (write-to-string '|abc| :escape nil :case :upcase)))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :downcase)
+ (string= "ABC" (write-to-string '|abc| :escape nil :case :upcase)))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :preserve)
+ (string= "abc" (write-to-string '|abc| :escape nil :case :upcase)))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :invert)
+ (string= "ABC" (write-to-string '|abc| :escape nil :case :upcase)))
+
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :upcase)
+ (string= "ABC" (write-to-string '|ABC| :escape nil :case :upcase)))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :downcase)
+ (string= "ABC" (write-to-string '|ABC| :escape nil :case :upcase)))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :preserve)
+ (string= "ABC" (write-to-string '|ABC| :escape nil :case :upcase)))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :invert)
+ (string= "abc" (write-to-string '|ABC| :escape nil :case :upcase)))
+
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :upcase)
+ (string= "ABC-abc" (write-to-string '|ABC-abc| :escape nil :case :upcase)))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :downcase)
+ (string= "ABC-ABC" (write-to-string '|ABC-abc| :escape nil :case :upcase)))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :preserve)
+ (string= "ABC-abc" (write-to-string '|ABC-abc| :escape nil :case :upcase)))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :invert)
+ (string= "ABC-abc" (write-to-string '|ABC-abc| :escape nil :case :upcase)))
+
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :upcase)
+ (string= "abc-ABC" (write-to-string '|abc-ABC| :escape nil :case :upcase)))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :downcase)
+ (string= "ABC-ABC" (write-to-string '|abc-ABC| :escape nil :case :upcase)))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :preserve)
+ (string= "abc-ABC" (write-to-string '|abc-ABC| :escape nil :case :upcase)))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :invert)
+ (string= "abc-ABC" (write-to-string '|abc-ABC| :escape nil :case :upcase)))
+
+
+;; accessible symbol, escaping off, *print-case* :downcase
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :upcase)
+ (string= "abc" (write-to-string '|abc| :escape nil :case :downcase)))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :downcase)
+ (string= "abc" (write-to-string '|abc| :escape nil :case :downcase)))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :preserve)
+ (string= "abc" (write-to-string '|abc| :escape nil :case :downcase)))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :invert)
+ (string= "ABC" (write-to-string '|abc| :escape nil :case :downcase)))
+
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :upcase)
+ (string= "abc" (write-to-string '|ABC| :escape nil :case :downcase)))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :downcase)
+ (string= "ABC" (write-to-string '|ABC| :escape nil :case :downcase)))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :preserve)
+ (string= "ABC" (write-to-string '|ABC| :escape nil :case :downcase)))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :invert)
+ (string= "abc" (write-to-string '|ABC| :escape nil :case :downcase)))
+
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :upcase)
+ (string= "abc-abc" (write-to-string '|ABC-abc| :escape nil :case :downcase)))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :downcase)
+ (string= "ABC-abc" (write-to-string '|ABC-abc| :escape nil :case :downcase)))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :preserve)
+ (string= "ABC-abc" (write-to-string '|ABC-abc| :escape nil :case :downcase)))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :invert)
+ (string= "ABC-abc" (write-to-string '|ABC-abc| :escape nil :case :downcase)))
+
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :upcase)
+ (string= "abc-abc" (write-to-string '|abc-ABC| :escape nil :case :downcase)))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :downcase)
+ (string= "abc-ABC" (write-to-string '|abc-ABC| :escape nil :case :downcase)))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :preserve)
+ (string= "abc-ABC" (write-to-string '|abc-ABC| :escape nil :case :downcase)))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :invert)
+ (string= "abc-ABC" (write-to-string '|abc-ABC| :escape nil :case :downcase)))
+
+
+
+;; keyword symbol, escaping off
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :upcase)
+ (string= "abc-Abc"
+ (write-to-string ':|abc-ABC| :escape nil :case :capitalize)))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :upcase)
+ (string= "abc-ABC" (write-to-string ':|abc-ABC| :escape nil :case :upcase)))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :upcase)
+ (string= "abc-abc" (write-to-string ':|abc-ABC| :escape nil :case :downcase)))
+
+
+;; non accessible symbol, escaping off
+(let ((*readtable* (copy-readtable nil)))
+ (when (find-package "TEST-PKG0") (delete-package "TEST-PKG0"))
+ (make-package "TEST-PKG0" :use ())
+ (setf (readtable-case *readtable*) :upcase)
+ (string= "abc" (write-to-string (intern "abc" "TEST-PKG0")
+ :escape nil :case :capitalize)))
+
+(let ((*readtable* (copy-readtable nil)))
+ (when (find-package "TEST-PKG0") (delete-package "TEST-PKG0"))
+ (make-package "TEST-PKG0" :use ())
+ (setf (readtable-case *readtable*) :upcase)
+ (string= "abc" (write-to-string (intern "abc" "TEST-PKG0")
+ :escape nil :case :upcase)))
+
+(let ((*readtable* (copy-readtable nil)))
+ (when (find-package "TEST-PKG0") (delete-package "TEST-PKG0"))
+ (make-package "TEST-PKG0" :use ())
+ (setf (readtable-case *readtable*) :upcase)
+ (string= "abc" (write-to-string (intern "abc" "TEST-PKG0")
+ :escape nil :case :downcase)))
+
+
+
+;; accessible symbol, *print-readably* t
+(loop
+ named loop0
+ with printed-name
+ with *readtable* = (copy-readtable nil)
+ for readtable-case in '(:upcase :downcase :preserve :invert)
+ do (loop
+ for *print-case* in '(:upcase :downcase :capitalize)
+ do (loop
+ for symbol in '(|ZEBRA| |Zebra| |zebra|)
+ do (setf (readtable-case *readtable*) readtable-case)
+ (setq printed-name (write-to-string symbol :readably t))
+ unless (eq symbol (read-from-string printed-name))
+ do (format t "~&Symbol = ~S~%Erroneous printed representation = ~S~%readtable-case = ~S~%*print-case* = ~S~%"
+ symbol printed-name readtable-case *print-case*)
+ (return-from loop0 nil)))
+ finally (return-from loop0 t))
+
+;; keyword symbol, *print-readably* t
+(loop
+ named loop0
+ with printed-name
+ with *readtable* = (copy-readtable nil)
+ for readtable-case in '(:upcase :downcase :preserve :invert)
+ do (loop
+ for *print-case* in '(:upcase :downcase :capitalize)
+ do (loop
+ for symbol in '(:|ZEBRA| :|Zebra| :|zebra|)
+ do (setf (readtable-case *readtable*) readtable-case)
+ (setq printed-name (write-to-string symbol :readably t))
+ unless (eq symbol (read-from-string printed-name))
+ do (format t "~&Symbol = ~S~%Erroneous printed representation = ~S~%readtable-case = ~S~%*print-case* = ~S~%"
+ symbol printed-name readtable-case *print-case*)
+ (return-from loop0 nil)))
+ finally (return-from loop0 t))
+
+;; non accessible symbol, *print-readably* t
+(progn
+ (when (find-package "TEST-PKG0") (delete-package "TEST-PKG0"))
+ (make-package "TEST-PKG0" :use ())
+ (loop
+ named loop0
+ with printed-name
+ with *readtable* = (copy-readtable nil)
+ for readtable-case in '(:upcase :downcase :preserve :invert)
+ do (loop
+ for *print-case* in '(:upcase :downcase :capitalize)
+ do (loop
+ for symbol in (mapcar #'(lambda (name) (intern name "TEST-PKG0"))
+ '("ZEBRA" "Zebra" "zebra"))
+ do (setf (readtable-case *readtable*) readtable-case)
+ (setq printed-name (write-to-string symbol :readably t))
+ unless (eq symbol (read-from-string printed-name))
+ do (format t "~&Symbol = ~S~%Erroneous printed representation = ~S~%readtable-case = ~S~%*print-case* = ~S~%"
+ symbol printed-name readtable-case *print-case*)
+ (return-from loop0 nil)))
+ finally (return-from loop0 t)))
+
+
+;; symbols having nongraphic characters in their name
+(eq '| | (read-from-string (write-to-string '| | :readably t)))
+(eq '|
+| (read-from-string (write-to-string '|
+| :readably t)))
+
+;; symbols having nonalphabetic characters in their name
+(eq '| | (read-from-string (write-to-string '| | :readably t)))
+(eq '|"| (read-from-string (write-to-string '|"| :readably t)))
+(eq '|#| (read-from-string (write-to-string '|#| :readably t)))
+(eq '|'| (read-from-string (write-to-string '|'| :readably t)))
+(eq '|(| (read-from-string (write-to-string '|(| :readably t)))
+(eq '|)| (read-from-string (write-to-string '|)| :readably t)))
+(eq '|,| (read-from-string (write-to-string '|,| :readably t)))
+(eq '|;| (read-from-string (write-to-string '|;| :readably t)))
+(eq '|\\| (read-from-string (write-to-string '|\\| :readably t)))
+(= 1 (length (symbol-name (read-from-string (write-to-string '|\\|
+ :readably t)))))
+(eq '|`| (read-from-string (write-to-string '|`| :readably t)))
+(eq '|\|| (read-from-string (write-to-string '|\|| :readably t)))
+(= 1 (length (symbol-name (read-from-string (write-to-string '|\||
+ :readably t)))))
+(loop
+ for symbol in '(|-!-| |/*/| |$$$| |^^^^^^^^^^^^^|)
+ always (loop
+ with *readtable* = (copy-readtable nil)
+ for table-case in '(:upcase :downcase :preserve :invert)
+ do (setf (readtable-case *readtable*) table-case)
+ always (loop for *print-case in '(:upcase :downcase :capitalize)
+ always (string= (symbol-name symbol)
+ (write-to-string symbol :escape nil)))))
+
+;; uninterned symbols
+(string= "ABC"
+ (symbol-name (read-from-string (write-to-string (make-symbol "ABC")
+ :readably t
+ :case :upcase))))
+(string= "ABC"
+ (symbol-name (read-from-string (write-to-string (make-symbol "ABC")
+ :readably t
+ :case :downcase))))
+(string= "ABC"
+ (symbol-name (read-from-string (write-to-string (make-symbol "ABC")
+ :readably t
+ :case :capitalize))))
+(string= "G01" (write-to-string (make-symbol "G01") :escape t :gensym nil))
+(string= "G01" (write-to-string (make-symbol "G01") :escape nil :gensym nil))
+(string= "#:G01" (write-to-string (make-symbol "G01") :escape t :gensym t))
+#-CLISP ;Bruno: CLISP prints symbols readably with vertical bars: "#:|G01|"
+(string= "#:G01"
+ ;; Variable *PRINT-READABLY*
+ ;; http://www.lispworks.com/reference/HyperSpec/Body/v_pr_rda.htm
+ ;; If the value of some other printer control variable is such
+ ;; that these requirements would be violated, the value of that
+ ;; other variable is ignored.
+ ;; Specifically, if *print-readably* is true, printing proceeds
+ ;; as if *print-escape*, *print-array*, and *print-gensym* were
+ ;; also true, and as if *print-length*, *print-level*, and
+ ;; *print-lines* were false.
+ (write-to-string (make-symbol "G01")
+ :escape nil :gensym nil :readably t))
+
+
+;; "FACE" as a symbol when *read-base* is 16
+(let ((face (let ((*print-base* 16)) (write-to-string 'face :readably t)))
+ (*read-base* 16))
+ ;; 22.1.3.3 Printing Symbols
+ ;; http://www.lispworks.com/reference/HyperSpec/Body/22_acc.htm
+ ;; When printing a symbol, the printer inserts enough single escape
+ ;; and/or multiple escape characters (backslashes and/or vertical-bars)
+ ;; so that if read were called with the same *readtable* and with
+ ;; *read-base* bound to the current output base, it would return the same
+ ;; symbol (if it is not apparently uninterned) or an uninterned symbol
+ ;; with the same print name (otherwise).
+ ;; For example, if the value of *print-base* were 16 when printing the
+ ;; symbol face, it would have to be printed as \FACE or \Face or |FACE|,
+ ;; because the token face would be read as a hexadecimal number (decimal
+ ;; value 64206) if the value of *read-base* were 16.
+ (eq 'face (read-from-string face)))
+
+
+(eq '|01| (read-from-string (write-to-string '|01| :readably t)))
+(eq '|1| (read-from-string (write-to-string '|1| :readably t)))
+(eq '|0123456789| (read-from-string (write-to-string '|0123456789|
+ :readably t)))
+
+;; symbols in a package with a mixed case name, *print-readably* t
+(progn
+ (when (find-package "Test-Pkg0") (delete-package "Test-Pkg0"))
+ (make-package "Test-Pkg0" :use ())
+ (loop
+ named loop0
+ with printed-name
+ with *readtable* = (copy-readtable nil)
+ for readtable-case in '(:upcase :downcase :preserve :invert)
+ do (loop
+ for *print-case* in '(:upcase :downcase :capitalize)
+ do (loop
+ for symbol in (mapcar #'(lambda (name) (intern name "Test-Pkg0"))
+ '("ZEBRA" "Zebra" "zebra"))
+ do (setf (readtable-case *readtable*) readtable-case)
+ (setq printed-name (write-to-string symbol :readably t))
+ unless (eq symbol (read-from-string printed-name))
+ do (format t "~&Symbol = ~S~%Erroneous printed representation = ~S~%readtable-case = ~S~%*print-case* = ~S~%"
+ symbol printed-name readtable-case *print-case*)
+ (return-from loop0 nil)))
+ finally (return-from loop0 t)))
+
+;; symbols in a package with weird chars in the name, *print-readably* t
+(progn
+ (when (find-package "Test\|Pkg 0\;") (delete-package "Test\|Pkg 0\;"))
+ (make-package "Test\|Pkg 0\;" :use ())
+ (loop
+ named loop0
+ with *readtable* = (copy-readtable nil)
+ for readtable-case in '(:upcase :downcase :preserve :invert)
+ do (loop
+ for *print-case* in '(:upcase :downcase :capitalize)
+ do (loop
+ for symbol in (mapcar #'(lambda (name) (intern name "Test\|Pkg 0\;"))
+ '("ZEBRA" "Zebra" "zebra"))
+ do (setf (readtable-case *readtable*) readtable-case)
+ unless (eq symbol (read-from-string (write-to-string symbol
+ :readably t)))
+ do (format t "~&Symbol = ~S~%Erroneous printed representation = ~S~%readtable-case = ~S~%*print-case* = ~S~%"
+ symbol printed-name readtable-case *print-case*)
+ (return-from loop0 nil)))
+ finally (return-from loop0 t)))
+
+
+;; weird symbols in a weird package, *print-readably* t
+(progn
+ (when (find-package "Test\|Pkg 0\;") (delete-package "Test\|Pkg 0\;"))
+ (make-package "Test\|Pkg 0\;" :use ())
+ (loop
+ named loop0
+ with *readtable* = (copy-readtable nil)
+ for readtable-case in '(:upcase :downcase :preserve :invert)
+ do (loop
+ for *print-case* in '(:upcase :downcase :capitalize)
+ do (loop
+ for symbol in (mapcar #'(lambda (name) (intern name "Test\|Pkg 0\;"))
+ '("Z\\E\"BRA" "Z\;e\|bra" "z\:e bra"))
+ do (setf (readtable-case *readtable*) readtable-case)
+ unless (eq symbol (read-from-string (write-to-string symbol
+ :readably t)))
+ do (format t "~&Symbol = ~S~%Erroneous printed representation = ~S~%readtable-case = ~S~%*print-case* = ~S~%"
+ symbol printed-name readtable-case *print-case*)
+ (return-from loop0 nil)))
+ finally (return-from loop0 t)))
+
+
+
+;; bit-vector
+(string= "#*0101" (write-to-string #*0101 :readably t :array t))
+(string= "#*01" (write-to-string #*01 :readably t :array t))
+(string= "#*0" (write-to-string #*0 :readably t :array t))
+(string= "#*1" (write-to-string #*1 :readably t :array t))
+(string= "#*" (write-to-string #* :readably t :array t))
+(string= "#*10101111000" (write-to-string #*10101111000
+ :readably t :array t))
+
+(string= "#*0101" (write-to-string #*0101 :readably t :array nil))
+(string= "#*01" (write-to-string #*01 :readably t :array nil))
+(string= "#*0" (write-to-string #*0 :readably t :array nil))
+(string= "#*1" (write-to-string #*1 :readably t :array nil))
+(string= "#*" (write-to-string #* :readably t :array nil))
+(string= "#*10101111000" (write-to-string #*10101111000
+ :readably t :array nil))
+
+(string= "#*0101" (write-to-string #*0101 :array t))
+(string= "#*01" (write-to-string #*01 :array t))
+(string= "#*0" (write-to-string #*0 :array t))
+(string= "#*1" (write-to-string #*1 :array t))
+(string= "#*" (write-to-string #* :array t))
+(string= "#*10101111000" (write-to-string #*10101111000 :array t))
+
+(zerop (search "#<" (write-to-string #*0101 :array nil)))
+(zerop (search "#<" (write-to-string #*01 :array nil)))
+(zerop (search "#<" (write-to-string #*0 :array nil)))
+(zerop (search "#<" (write-to-string #*1 :array nil)))
+(zerop (search "#<" (write-to-string #* :array nil)))
+(zerop (search "#<" (write-to-string #*10101111000 :array nil)))
+(string= "#*01"
+ (write-to-string (make-array 10
+ :element-type 'bit
+ :initial-contents '(0 1 0 1 0 1 0 1 0 1)
+ :fill-pointer 2)
+ :readably t :array t))
+
+
+;; list
+(null (read-from-string (write-to-string '())))
+(string= (write-to-string '(1) :pretty nil) "(1)")
+(string= (write-to-string '(1 2) :pretty nil) "(1 2)")
+(string= (write-to-string '(1 2 3) :pretty nil) "(1 2 3)")
+(string= (write-to-string '(1 2 3 4) :pretty nil) "(1 2 3 4)")
+(string= (write-to-string '(1 . 2) :pretty nil) "(1 . 2)")
+(string= (write-to-string '(1 2 . 3) :pretty nil) "(1 2 . 3)")
+(string= (write-to-string '(1 2 3 . 4) :pretty nil) "(1 2 3 . 4)")
+(let ((list (loop for i from 0 upto 100 collect i)))
+ (equal (read-from-string (write-to-string list)) list))
+
+;; list *print-level* *print-length*
+(string= (write-to-string '(1 (2 (3 (4 (5 (6)))))) :pretty nil :level 0) "#")
+(string= (write-to-string '(1 (2 (3 (4 (5 (6)))))) :pretty nil :level 1)
+ "(1 #)")
+(string= (write-to-string '(1 (2 (3 (4 (5 (6)))))) :pretty nil :level 2)
+ "(1 (2 #))")
+(string= (write-to-string '(1 (2 (3 (4 (5 (6)))))) :pretty nil :level 3)
+ "(1 (2 (3 #)))")
+(string= (write-to-string '(1 (2 (3 (4 (5 (6)))))) :pretty nil :level 4)
+ "(1 (2 (3 (4 #))))")
+(string= (write-to-string '(1 (2 (3 (4 (5 (6)))))) :pretty nil :level 4)
+ "(1 (2 (3 (4 #))))")
+(string= (write-to-string '(1 (2 (3 (4 (5 (6)))))) :pretty nil :level 5)
+ "(1 (2 (3 (4 (5 #)))))")
+(string= (write-to-string '(1 (2 (3 (4 (5 (6)))))) :pretty nil :level 6)
+ "(1 (2 (3 (4 (5 (6))))))")
+(string= (write-to-string '(1 (2 (3 (4 (5 (6)))))) :pretty nil :level 7)
+ "(1 (2 (3 (4 (5 (6))))))")
+(string= (write-to-string '(1 (2 (3 (4 (5 (6)))))) :pretty nil :level 100)
+ "(1 (2 (3 (4 (5 (6))))))")
+
+(string= (write-to-string '(1 2 3 4 5 6) :pretty nil :length 0) "(...)")
+(string= (write-to-string '(1 2 3 4 5 6) :pretty nil :length 1) "(1 ...)")
+(string= (write-to-string '(1 2 3 4 5 6) :pretty nil :length 2) "(1 2 ...)")
+(string= (write-to-string '(1 2 3 4 5 6) :pretty nil :length 3) "(1 2 3 ...)")
+(string= (write-to-string '(1 2 3 4 5 6) :pretty nil :length 4) "(1 2 3 4 ...)")
+(string= (write-to-string '(1 2 3 4 5 6) :pretty nil :length 5)
+ "(1 2 3 4 5 ...)")
+(string= (write-to-string '(1 2 3 4 5 6) :pretty nil :length 6)
+ "(1 2 3 4 5 6)")
+(string= (write-to-string '(1 2 3 4 5 6) :pretty nil :length 7)
+ "(1 2 3 4 5 6)")
+(string= (write-to-string '(1 2 3 4 5 6) :pretty nil :length 100)
+ "(1 2 3 4 5 6)")
+
+(string= (write-to-string '(1 2 . 3) :pretty nil :length 0) "(...)")
+(string= (write-to-string '(1 2 . 3) :pretty nil :length 1) "(1 ...)")
+(string= (write-to-string '(1 2 . 3) :pretty nil :length 2) "(1 2 . 3)")
+(string= (write-to-string '(1 2 . 3) :pretty nil :length 3) "(1 2 . 3)")
+
+(string= (write-to-string '(1 (2 (3 (4 (5 (6))))))
+ :pretty nil :level 0 :length 0)
+ "#")
+(string= (write-to-string '(1 (2 (3 (4 (5 (6))))))
+ :pretty nil :level 1 :length 0)
+ "(...)")
+(string= (write-to-string '(1 (2 (3 (4 (5 (6))))))
+ :pretty nil :level 0 :length 1)
+ "#")
+(string= (write-to-string '(1 (2 (3 (4 (5 (6))))))
+ :pretty nil :level 1 :length 1)
+ "(1 ...)")
+(string= (write-to-string '(1 (2 (3 (4 (5 (6))))))
+ :pretty nil :level 2 :length 1)
+ "(1 ...)")
+(string= (write-to-string '(1 (2 (3 (4 (5 (6))))))
+ :pretty nil :level 2 :length 2)
+ "(1 (2 #))")
+
+(string= (write-to-string '((((1))) ((2)) (3) 4)
+ :pretty nil :level 0 :length 0)
+ "#")
+(string= (write-to-string '((((1))) ((2)) (3) 4)
+ :pretty nil :level 1 :length 0)
+ "(...)")
+(string= (write-to-string '((((1))) ((2)) (3) 4)
+ :pretty nil :level 1 :length 4)
+ "(# # # 4)")
+(string= (write-to-string '((((1))) ((2)) (3) 4)
+ :pretty nil :level 2 :length 3)
+ "((#) (#) (3) ...)")
+(string= (write-to-string '((((1))) ((2)) (3) 4)
+ :pretty nil :level 3 :length 3)
+ "(((#)) ((2)) (3) ...)")
+(string= (write-to-string '((((1))) ((2)) (3) 4)
+ :pretty nil :level 4 :length 3)
+ "((((1))) ((2)) (3) ...)")
+(string= (write-to-string '((((1))) ((2)) (3) 4)
+ :pretty nil :level 2 :length 4)
+ "((#) (#) (3) 4)")
+(string= (write-to-string '((((1))) ((2)) (3) 4)
+ :pretty nil :level 4 :length 4)
+ "((((1))) ((2)) (3) 4)")
+
+(string= (write-to-string '((((1))) ((2)) (3) 4 (5) ((6)) (((7))))
+ :pretty nil :level 3 :length 6)
+ "(((#)) ((2)) (3) 4 (5) ((6)) ...)")
+
+(string= (write-to-string '((((1 ((2)) (3)))) ((2 (3) 4 5 6)) (3 (4 (5 6))))
+ :pretty nil :level 6 :length 3)
+ "((((1 ((2)) (3)))) ((2 (3) 4 ...)) (3 (4 (5 6))))")
+(string= (write-to-string '((((1 ((2)) (3)))) ((2 (3) 4 5 6)) (3 (4 (5 6))))
+ :pretty nil :level 2 :length 2)
+ "((#) (#) ...)")
+(string= (write-to-string '((((1 ((2)) (3)))) ((2 (3) 4 5 6)) (3 (4 (5 6))))
+ :pretty nil :level 3 :length 2)
+ "(((#)) ((2 # ...)) ...)")
+(string= (write-to-string '(((1)) ((1) 2 ((3)) (((4)))) 3 (4))
+ :pretty nil :level 2 :length 3)
+ "((#) (# 2 # ...) 3 ...)")
+
+
+
+;; vector
+;; 22.1.3.7 Printing Other Vectors
+;; http://www.lispworks.com/reference/HyperSpec/Body/22_acg.htm
+;; If *print-array* is true and *print-readably* is false, any vector
+;; other than a string or bit vector is printed using general-vector
+;; syntax; this means that information about specialized vector
+;; representations does not appear. The printed representation of a
+;; zero-length vector is #(). The printed representation of a
+;; non-zero-length vector begins with #(. Following that, the first
+;; element of the vector is printed. If there are any other elements,
+;; they are printed in turn, with each such additional element preceded
+;; by a space if *print-pretty* is false, or whitespace[1] if
+;; *print-pretty* is true. A right-parenthesis after the last element
+;; terminates the printed representation of the vector.
+(string= (write-to-string '#() :pretty nil :array t) "#()")
+(string= (write-to-string '#(1) :pretty nil :array t) "#(1)")
+(string= (write-to-string '#(1 2 3) :pretty nil :array t) "#(1 2 3)")
+(string= (write-to-string (make-array 10
+ :initial-contents '(0 1 2 3 4 5 6 7 8 9)
+ :fill-pointer 3)
+ :pretty nil :array t)
+ "#(0 1 2)")
+
+;; vector *print-level* *print-length*
+(string= (write-to-string '#(1 (2 (3 (4 (5 (6))))))
+ :pretty nil :array t :level 0) "#")
+(string= (write-to-string '#(1 (2 (3 (4 (5 (6))))))
+ :pretty nil :array t :level 1)
+ "#(1 #)")
+(string= (write-to-string '#(1 (2 (3 (4 (5 (6))))))
+ :pretty nil :array t :level 2)
+ "#(1 (2 #))")
+(string= (write-to-string '#(1 (2 (3 (4 (5 (6))))))
+ :pretty nil :array t :level 3)
+ "#(1 (2 (3 #)))")
+(string= (write-to-string '#(1 (2 (3 (4 (5 (6))))))
+ :pretty nil :array t :level 4)
+ "#(1 (2 (3 (4 #))))")
+(string= (write-to-string '#(1 (2 (3 (4 (5 (6))))))
+ :pretty nil :array t :level 4)
+ "#(1 (2 (3 (4 #))))")
+(string= (write-to-string '#(1 (2 (3 (4 (5 (6))))))
+ :pretty nil :array t :level 5)
+ "#(1 (2 (3 (4 (5 #)))))")
+(string= (write-to-string '#(1 (2 (3 (4 (5 (6))))))
+ :pretty nil :array t :level 6)
+ "#(1 (2 (3 (4 (5 (6))))))")
+(string= (write-to-string '#(1 (2 (3 (4 (5 (6))))))
+ :pretty nil :array t :level 7)
+ "#(1 (2 (3 (4 (5 (6))))))")
+(string= (write-to-string '#(1 (2 (3 (4 (5 (6))))))
+ :pretty nil :array t :level 100)
+ "#(1 (2 (3 (4 (5 (6))))))")
+
+(string= (write-to-string '#(1 2 3 4 5 6) :pretty nil :array t :length 0)
+ "#(...)")
+(string= (write-to-string '#(1 2 3 4 5 6) :pretty nil :array t :length 1)
+ "#(1 ...)")
+(string= (write-to-string '#(1 2 3 4 5 6) :pretty nil :array t :length 2)
+ "#(1 2 ...)")
+(string= (write-to-string '#(1 2 3 4 5 6) :pretty nil :array t :length 3)
+ "#(1 2 3 ...)")
+(string= (write-to-string '#(1 2 3 4 5 6) :pretty nil :array t :length 4)
+ "#(1 2 3 4 ...)")
+(string= (write-to-string '#(1 2 3 4 5 6) :pretty nil :array t :length 5)
+ "#(1 2 3 4 5 ...)")
+(string= (write-to-string '#(1 2 3 4 5 6) :pretty nil :array t :length 6)
+ "#(1 2 3 4 5 6)")
+(string= (write-to-string '#(1 2 3 4 5 6) :pretty nil :array t :length 7)
+ "#(1 2 3 4 5 6)")
+(string= (write-to-string '#(1 2 3 4 5 6) :pretty nil :array t :length 100)
+ "#(1 2 3 4 5 6)")
+
+(string= (write-to-string '#(1 #(2 #(3 #(4 #(5 #(6))))))
+ :pretty nil :array t :level 0 :length 0)
+ "#")
+(string= (write-to-string '#(1 #(2 #(3 #(4 #(5 #(6))))))
+ :pretty nil :array t :level 1 :length 0)
+ "#(...)")
+(string= (write-to-string '#(1 #(2 #(3 #(4 #(5 #(6))))))
+ :pretty nil :array t :level 0 :length 1)
+ "#")
+(string= (write-to-string '#(1 #(2 #(3 #(4 #(5 #(6))))))
+ :pretty nil :array t :level 1 :length 1)
+ "#(1 ...)")
+(string= (write-to-string '#(1 #(2 #(3 #(4 #(5 #(6))))))
+ :pretty nil :array t :level 2 :length 1)
+ "#(1 ...)")
+(string= (write-to-string '#(1 #(2 #(3 #(4 #(5 #(6))))))
+ :pretty nil :array t :level 2 :length 2)
+ "#(1 #(2 #))")
+
+(string= (write-to-string '#(#(#(#(1))) #(#(2)) #(3) 4)
+ :pretty nil :array t :level 0 :length 0)
+ "#")
+(string= (write-to-string '#(#(#(#(1))) #(#(2)) #(3) 4)
+ :pretty nil :array t :level 1 :length 0)
+ "#(...)")
+(string= (write-to-string '#(#(#(#(1))) #(#(2)) #(3) 4)
+ :pretty nil :array t :level 1 :length 4)
+ "#(# # # 4)")
+(string= (write-to-string '#(#(#(#(1))) #(#(2)) #(3) 4)
+ :pretty nil :array t :level 2 :length 3)
+ "#(#(#) #(#) #(3) ...)")
+(string= (write-to-string '#(#(#(#(1))) #(#(2)) #(3) 4)
+ :pretty nil :array t :level 3 :length 3)
+ "#(#(#(#)) #(#(2)) #(3) ...)")
+(string= (write-to-string '#(#(#(#(1))) #(#(2)) #(3) 4)
+ :pretty nil :array t :level 4 :length 3)
+ "#(#(#(#(1))) #(#(2)) #(3) ...)")
+(string= (write-to-string '#(#(#(#(1))) #(#(2)) #(3) 4)
+ :pretty nil :array t :level 2 :length 4)
+ "#(#(#) #(#) #(3) 4)")
+(string= (write-to-string '#(#(#(#(1))) #(#(2)) #(3) 4)
+ :pretty nil :array t :level 4 :length 4)
+ "#(#(#(#(1))) #(#(2)) #(3) 4)")
+
+(string= (write-to-string '#(#(#(#(1))) #(#(2)) #(3) 4 #(5) #(#(6)) #(#(#(7))))
+ :pretty nil :array t :level 3 :length 6)
+ "#(#(#(#)) #(#(2)) #(3) 4 #(5) #(#(6)) ...)")
+
+(string= (write-to-string '#(#(#(#(1 #(#(2)) #(3))))
+ #(#(2 #(3) 4 5 6))
+ #(3 #(4 #(5 6))))
+ :pretty nil :array t :level 6 :length 3)
+ "#(#(#(#(1 #(#(2)) #(3)))) #(#(2 #(3) 4 ...)) #(3 #(4 #(5 6))))")
+(string= (write-to-string '#(#(#(#(1 #(#(2)) #(3))))
+ #(#(2 #(3) 4 5 6))
+ #(3 #(4 #(5 6))))
+ :pretty nil :array t :level 2 :length 2)
+ "#(#(#) #(#) ...)")
+(string= (write-to-string '#(#(#(#(1 #(#(2)) #(3))))
+ #(#(2 #(3) 4 5 6))
+ #(3 #(4 #(5 6))))
+ :pretty nil :array t :level 3 :length 2)
+ "#(#(#(#)) #(#(2 # ...)) ...)")
+(string= (write-to-string '#(#(#(1)) #(#(1) 2 #(#(3)) #(#(#(4)))) 3 #(4))
+ :pretty nil :array t :level 2 :length 3)
+ "#(#(#) #(# 2 # ...) 3 ...)")
+
+
+;; array
+(string= (write-to-string '#0A1 :pretty nil :array t) "#0A1")
+(string= (write-to-string '#1A() :pretty nil :array t) "#()")
+(string= (write-to-string '#1A(1 2 3) :pretty nil :array t) "#(1 2 3)")
+(string= (write-to-string '#2A((1 2 3) (4 5 6)) :pretty nil :array t)
+ "#2A((1 2 3) (4 5 6))")
+(string= (write-to-string '#3A(((1 a) (2 b) (3 c))
+ ((4 d) (5 e) (6 f))) :pretty nil :array t)
+ "#3A(((1 A) (2 B) (3 C)) ((4 D) (5 E) (6 F)))")
+(string= (write-to-string (make-array (make-list 20 :initial-element 1)
+ :initial-element 0)
+ :pretty nil :array t)
+ "#20A((((((((((((((((((((0))))))))))))))))))))")
+
+;; array *print-level* *print-length*
+;(string= (write-to-string '#0A10 :pretty nil :array t :level 0 :length 0) "#")
+(string= (write-to-string '#0A10 :pretty nil :array t :level 1 :length 1)
+ "#0A10")
+(string= (write-to-string '#2A((0) (1) (2) (3))
+ :pretty nil :array t :level 1 :length 1)
+ "#2A(# ...)")
+(string= (write-to-string '#2A((0) (1) (2) (3))
+ :pretty nil :array t :level 2 :length 2)
+ "#2A((0) (1) ...)")
+(string= (write-to-string '#2A((0) (1) (2) (3))
+ :pretty nil :array t :level 2 :length 0)
+ "#2A(...)")
+(string= (write-to-string '#3A(((0) (1) (2)) ((3) (4) (5)))
+ :pretty nil :array t :level 3 :length 2)
+ "#3A(((0) (1) ...) ((3) (4) ...))")
+(string= (write-to-string (make-array (make-list 20 :initial-element 1)
+ :initial-element 0)
+ :pretty nil :array t :level 0 :length 100)
+ "#")
+(string= (write-to-string (make-array (make-list 20 :initial-element 1)
+ :initial-element 0)
+ :pretty nil :array t :level 100 :length 0)
+ "#20A(...)")
+(string= (write-to-string (make-array (make-list 20 :initial-element 1)
+ :initial-element 0)
+ :pretty nil :array t :level 10 :length 100)
+ "#20A((((((((((#))))))))))")
+(string= (write-to-string '#2A((0 1 2) (3 4 5) (6 7 8) (9 10 11))
+ :pretty nil :array t :level 2 :length 2)
+ "#2A((0 1 ...) (3 4 ...) ...)")
+(string= (write-to-string '#2A((0 1 2) (3 4 5) (6 7 8) (9 10 11))
+ :pretty nil :array t :level 1 :length 2)
+ "#2A(# # ...)")
+(string= (write-to-string '#3A(((0) (1) (2)) ((3) (4) (5))
+ ((6) (7) (8)) ((9) (10) (11)))
+ :pretty nil :array t :level 2 :length 3)
+ "#3A((# # #) (# # #) (# # #) ...)")
+(string= (write-to-string '#3A(((0) (1) (2)) ((3) (4) (5))
+ ((6) (7) (8)) ((9) (10) (11)))
+ :pretty nil :array t :level 3 :length 4)
+ "#3A(((0) (1) (2)) ((3) (4) (5)) ((6) (7) (8)) ((9) (10) (11)))")
+
+
+;; *print-array*
+(string= (write-to-string "abc" :array t :escape nil) "abc")
+(string= (write-to-string "abc" :array nil :escape nil) "abc")
+(= 2 (mismatch "#<" (write-to-string #() :array nil)))
+(= 2 (mismatch "#<" (write-to-string #(1 2 3) :array nil)))
+(= 2 (mismatch "#<" (write-to-string #*1010 :array nil)))
+(= 2 (mismatch "#<" (write-to-string #2A((0 1 2) (3 4 5)) :array nil)))
+(= 2 (mismatch "#<" (write-to-string #3A(((0 1) (2 3)) ((4 5) (6 7)))
+ :array nil)))
+(= 2 (mismatch "#<" (write-to-string #4A((((0) (1)) ((2) (3)))
+ (((4) (5)) ((6) (7)))
+ (((8) (9)) ((10) (11)))
+ (((12) (13)) ((14) (15))))
+ :array nil)))
+
+
+
+;; label
+(let* ((list '#1=(#1# . #1#))
+ (x (read-from-string (write-to-string list :circle t))))
+ (and (eq x (car x))
+ (eq x (cdr x))))
+
+(let* ((list '#1=(a . #1#))
+ (x (read-from-string (write-to-string list :circle t))))
+ (and (eq (car x) 'a)
+ (eq x (cdr x))))
+
+(let* ((list '(a . #1=(b c . #1#)))
+ (x (read-from-string (write-to-string list :circle t))))
+ (and (eq (first x) 'a)
+ (eq (second x) 'b)
+ (eq (third x) 'c)
+ (eq (fourth x) 'b)
+ (eq (cdr x) (nthcdr 3 x))))
+
+(let* ((list '(#1=#:G1041 #1#))
+ (x (read-from-string (write-to-string list :circle t))))
+ ;; 22.1.3.3.1 Package Prefixes for Symbols
+ ;; http://www.lispworks.com/reference/HyperSpec/Body/22_acca.htm
+ ;; Because the #: syntax does not intern the following symbol, it is
+ ;; necessary to use circular-list syntax if *print-circle* is true and
+ ;; the same uninterned symbol appears several times in an expression to
+ ;; be printed. For example, the result of
+ ;;
+ ;; (let ((x (make-symbol "FOO"))) (list x x))
+ ;;
+ ;; would be printed as (#:foo #:foo) if *print-circle* were false, but as
+ ;; (#1=#:foo #1#) if *print-circle* were true.
+ (and (= 2 (length x))
+ (symbolp (first x))
+ (eq (first x) (second x))))
+
+(let* ((list '#1=(a (b #2=(x y z) . #1#) . #2#))
+ (x (read-from-string (write-to-string list :circle t))))
+ (and (eq (first x) 'a)
+ (eq x (cddr (second x)))
+ (eq (second (second x)) (cddr x))))
+
+(let* ((list '#1=#(#1# a))
+ (x (read-from-string (write-to-string list :circle t))))
+ (and (eq x (aref x 0))
+ (eq 'a (aref x 1))))
+
+(let* ((list '#1=#(a #1#))
+ (x (read-from-string (write-to-string list :circle t))))
+ (and (eq (aref x 0) 'a)
+ (eq x (aref x 1))))
+
+(let* ((list '#(#1=#:G00 #1#))
+ (x (read-from-string (write-to-string list :circle t))))
+ (and (eq (aref x 0) (aref x 1))
+ (string= (symbol-name (aref x 0)) "G00")
+ (null (symbol-package (aref x 0)))))
+
+(let* ((list '#(#(#1=#:G00) #2=#(#1# a) #(#2# #1#)))
+ (x (read-from-string (write-to-string list :circle t))))
+ (and (= 3 (length x))
+ (= 1 (length (aref x 0)))
+ (= 2 (length (aref x 1)))
+ (= 2 (length (aref x 2)))
+ (eq (aref (aref x 0) 0) (aref (aref x 1) 0))
+ (eq 'a (aref (aref x 1) 1))
+ (eq (aref (aref x 0) 0) (aref (aref x 2) 1))
+ (eq (aref x 1) (aref (aref x 2) 0))))
+
+(let* ((array '#1=#0A#1#)
+ (x (read-from-string (write-to-string array :array t :circle t))))
+ (and (null (array-dimensions array))
+ (eq x (aref x))))
+(let* ((array '#1=#2A((1 2 3) (4 5 #1#)))
+ (x (read-from-string (write-to-string array :array t :circle t))))
+ (and (equal (array-dimensions array) '(2 3))
+ (= 1 (aref x 0 0))
+ (= 2 (aref x 0 1))
+ (= 3 (aref x 0 2))
+ (= 4 (aref x 1 0))
+ (= 5 (aref x 1 1))
+ (eq x (aref x 1 2))))
+(let* ((array #1=#3A(((1 a) (2 b) (3 #1#)) ((4 d) (5 e) (6 f))))
+ (x (read-from-string (write-to-string array :array t :circle t))))
+ (and (equal (array-dimensions array) '(2 3 2))
+ (= 1 (aref x 0 0 0))
+ (eq 'a (aref x 0 0 1))
+ (= 2 (aref x 0 1 0))
+ (eq 'b (aref x 0 1 1))
+ (= 3 (aref x 0 2 0))
+ (eq x (aref x 0 2 1))
+ (= 4 (aref x 1 0 0))
+ (eq 'd (aref x 1 0 1))
+ (= 5 (aref x 1 1 0))
+ (eq 'e (aref x 1 1 1))
+ (= 6 (aref x 1 2 0))
+ (eq 'f (aref x 1 2 1))))
+
+(let* ((array #3A(((1 #1=#:G0) (#2=#:G1 b) (3 #1#)) ((4 d) (5 e) (#2# f))))
+ (x (read-from-string (write-to-string array :array t :circle t))))
+ (and (equal (array-dimensions array) '(2 3 2))
+ (= 1 (aref x 0 0 0))
+ (eq (aref x 0 0 1) (aref x 0 2 1))
+ (null (symbol-package (aref x 0 0 1)))
+ (string= "G0" (symbol-name (aref x 0 0 1)))
+ (eq (aref x 0 1 0) (aref x 1 2 0))
+ (null (symbol-package (aref x 0 1 0)))
+ (string= "G1" (symbol-name (aref x 0 1 0)))
+ (eq 'b (aref x 0 1 1))
+ (= 3 (aref x 0 2 0))
+ (= 4 (aref x 1 0 0))
+ (eq 'd (aref x 1 0 1))
+ (= 5 (aref x 1 1 0))
+ (eq 'e (aref x 1 1 1))
+ (eq 'f (aref x 1 2 1))))
+
+(let* ((array #1=#3A(((#1# #2=#:G0) (#3=#:G1 #2#) (#3# #1#))
+ ((#1# #2#) (#2# #3#) (#2# #1#))))
+ (x (read-from-string (write-to-string array :array t :circle t))))
+ (and (equal (array-dimensions array) '(2 3 2))
+ (eq x (aref x 0 0 0))
+ (null (symbol-package (aref x 0 0 1)))
+ (string= (symbol-name (aref x 0 0 1)) "G0")
+ (null (symbol-package (aref x 0 1 0)))
+ (string= (symbol-name (aref x 0 1 0)) "G1")
+ (eq (aref x 0 1 0) (aref x 0 2 0))
+ (eq x (aref x 0 2 1))
+ (eq x (aref x 1 0 0))
+ (eq (aref x 1 0 1) (aref x 0 0 1))
+ (eq (aref x 1 1 0) (aref x 0 0 1))
+ (eq (aref x 1 1 1) (aref x 0 1 0))
+ (eq (aref x 1 2 0) (aref x 0 0 1))
+ (eq (aref x 1 2 1) x)))
+
+(let* ((array #4A((((0 #1=#:G00 2) (#1# 4 #2=#:G01))
+ ((#3=#:G02 #2# 8) (9 #4=#:G03 #3#))
+ ((#4# 12 #5=#:G04) (#6=#:G05 #6# #5#)))))
+ (x (read-from-string (write-to-string array :array t :circle t))))
+ (and (equal (array-dimensions array) '(1 3 2 3))
+ (= 0 (aref x 0 0 0 0))
+ (null (symbol-package (aref x 0 0 0 1)))
+ (string= (symbol-name (aref x 0 0 0 1)) "G00")
+ (= 2 (aref x 0 0 0 2))
+
+ (eq (aref x 0 0 1 0) (aref x 0 0 0 1))
+ (= 4 (aref x 0 0 1 1))
+ (null (symbol-package (aref x 0 0 1 2)))
+ (string= (symbol-name (aref x 0 0 1 2)) "G01")
+
+ (null (symbol-package (aref x 0 1 0 0)))
+ (string= (symbol-name (aref x 0 1 0 0)) "G02")
+ (eq (aref x 0 1 0 1) (aref x 0 0 1 2))
+ (= 8 (aref x 0 1 0 2))
+
+ (= 9 (aref x 0 1 1 0))
+ (null (symbol-package (aref x 0 1 1 1)))
+ (string= (symbol-name (aref x 0 1 1 1)) "G03")
+ (eq (aref x 0 1 1 2) (aref x 0 1 0 0))
+
+ (eq (aref x 0 2 0 0) (aref x 0 1 1 1))
+ (= 12 (aref x 0 2 0 1))
+ (null (symbol-package (aref x 0 2 0 2)))
+ (string= (symbol-name (aref x 0 2 0 2)) "G04")
+
+ (null (symbol-package (aref x 0 2 1 0)))
+ (string= (symbol-name (aref x 0 2 1 0)) "G05")
+ (eq (aref x 0 2 1 1) (aref x 0 2 1 0))
+ (eq (aref x 0 2 1 2) (aref x 0 2 0 2))))
+
+
+(let* ((sequence '#1=(#(0 #2=(#1#) #1# 3) #3=#2A((#1# #2#) (#3# 4))))
+ (x (read-from-string (write-to-string sequence :array t :circle t))))
+ (and (= 2 (length x))
+ (= 4 (length (first x)))
+ (= 0 (aref (first x) 0))
+ (eq x (first (aref (first x) 1)))
+ (eq x (aref (first x) 2))
+ (= 3 (aref (first x) 3))
+ (equal (array-dimensions (second x)) '(2 2))
+ (eq x (aref (second x) 0 0))
+ (eq (aref (second x) 0 1) (aref (first x) 1))
+ (eq (aref (second x) 1 0) (second x))
+ (= 4 (aref (second x) 1 1))))
+
+(let* ((sequence '#1=#(#2=(0 1 . #3=(2)) #(#3# #2# #1#) #3A(((#1# #2# #3#)))))
+ (x (read-from-string (write-to-string sequence :array t :circle t))))
+ (and (= 3 (length x))
+ (= 3 (length (aref x 0)))
+ (= 0 (first (aref x 0)))
+ (= 1 (second (aref x 0)))
+ (= 2 (third (aref x 0)))
+ (= 3 (length (aref x 1)))
+ (eq (aref (aref x 1) 0) (cddr (aref x 0)))
+ (eq (aref (aref x 1) 1) (aref x 0))
+ (eq (aref (aref x 1) 2) x)
+ (equal (array-dimensions (aref x 2)) '(1 1 3))
+ (eq (aref (aref x 2) 0 0 0) x)
+ (eq (aref (aref x 2) 0 0 1) (aref x 0))
+ (eq (aref (aref x 2) 0 0 2) (cddr (aref x 0)))))
+
+;; *print-level* *print-length* array, vector, list intermingled
+(let* ((sequence '((1 2 3) #(4 5 6) #2A((7 8 9) (10 11 12)))))
+ (string= (write-to-string sequence
+ :pretty nil :array t :level 0 :length 10)
+ "#"))
+(let* ((sequence '((1 2 3) #(4 5 6) #2A((7 8 9) (10 11 12)))))
+ (string= (write-to-string sequence
+ :pretty nil :array t :level 1 :length 10)
+ "(# # #)"))
+(let* ((sequence '((1 2 3) #(4 5 6) #2A((7 8 9) (10 11 12)))))
+ (string= (write-to-string sequence
+ :pretty nil :array t :level 2 :length 10)
+ "((1 2 3) #(4 5 6) #2A(# #))"))
+(let* ((sequence '((1 2 3) #(4 5 6) #2A((7 8 9) (10 11 12)))))
+ (string= (write-to-string sequence
+ :pretty nil :array t :level 3 :length 10)
+ "((1 2 3) #(4 5 6) #2A((7 8 9) (10 11 12)))"))
+(let* ((sequence '((1 2 3) #(4 5 6) #2A((7 8 9) (10 11 12)))))
+ (string= (write-to-string sequence
+ :pretty nil :array t :level 3 :length 1)
+ "((1 ...) ...)"))
+(let* ((sequence '((1 2 3) #(4 5 6) #2A((7 8 9) (10 11 12)))))
+ (string= (write-to-string sequence
+ :pretty nil :array t :level 3 :length 2)
+ "((1 2 ...) #(4 5 ...) ...)"))
+(let* ((sequence '((1 2 3) #(4 5 6) #2A((7 8 9) (10 11 12)))))
+ (string= (write-to-string sequence
+ :pretty nil :array t :level 3 :length 3)
+ "((1 2 3) #(4 5 6) #2A((7 8 9) (10 11 12)))"))
+(let* ((sequence '((1 2 3) #(4 5 6) #2A((7 8 9 10) (11 12 13 14)))))
+ (string= (write-to-string sequence
+ :pretty nil :array t :level 3 :length 3)
+ "((1 2 3) #(4 5 6) #2A((7 8 9 ...) (11 12 13 ...)))"))
+
+(let* ((sequence '#((1 2 3) #(4 5 6) #2A((7 8 9) (10 11 12)))))
+ (string= (write-to-string sequence
+ :pretty nil :array t :level 0 :length 10)
+ "#"))
+(let* ((sequence '#((1 2 3) #(4 5 6) #2A((7 8 9) (10 11 12)))))
+ (string= (write-to-string sequence
+ :pretty nil :array t :level 1 :length 10)
+ "#(# # #)"))
+(let* ((sequence '#((1 2 3) #(4 5 6) #2A((7 8 9) (10 11 12)))))
+ (string= (write-to-string sequence
+ :pretty nil :array t :level 2 :length 10)
+ "#((1 2 3) #(4 5 6) #2A(# #))"))
+(let* ((sequence '#((1 2 3) #(4 5 6) #2A((7 8 9) (10 11 12)))))
+ (string= (write-to-string sequence
+ :pretty nil :array t :level 3 :length 10)
+ "#((1 2 3) #(4 5 6) #2A((7 8 9) (10 11 12)))"))
+(let* ((sequence '#((1 2 3) #(4 5 6) #2A((7 8 9) (10 11 12)))))
+ (string= (write-to-string sequence
+ :pretty nil :array t :level 3 :length 1)
+ "#((1 ...) ...)"))
+(let* ((sequence '#((1 2 3) #(4 5 6) #2A((7 8 9) (10 11 12)))))
+ (string= (write-to-string sequence
+ :pretty nil :array t :level 3 :length 2)
+ "#((1 2 ...) #(4 5 ...) ...)"))
+(let* ((sequence '#((1 2 3) #(4 5 6) #2A((7 8 9) (10 11 12)))))
+ (string= (write-to-string sequence
+ :pretty nil :array t :level 3 :length 3)
+ "#((1 2 3) #(4 5 6) #2A((7 8 9) (10 11 12)))"))
+(let* ((sequence '#((1 2 3) #(4 5 6) #2A((7 8 9 10) (11 12 13 14)))))
+ (string= (write-to-string sequence
+ :pretty nil :array t :level 3 :length 3)
+ "#((1 2 3) #(4 5 6) #2A((7 8 9 ...) (11 12 13 ...)))"))
+
+(let* ((array '#2A(((10) #(100)) ((0 1 2) #2A((3) (4) (5) (6) (7))))))
+ (string= (write-to-string array
+ :pretty nil :array t :level 0 :length 0)
+ "#"))
+(let* ((array '#2A(((10) #(100)) ((0 1 2) #2A((3) (4) (5) (6) (7))))))
+ (string= (write-to-string array
+ :pretty nil :array t :level 1 :length 0)
+ "#2A(...)"))
+(let* ((array '#2A(((10) #(100)) ((0 1 2) #2A((3) (4) (5) (6) (7))))))
+ (string= (write-to-string array
+ :pretty nil :array t :level 1 :length 1)
+ "#2A(# ...)"))
+(let* ((array '#2A(((10) #(100)) ((0 1 2) #2A((3) (4) (5) (6) (7))))))
+ (string= (write-to-string array
+ :pretty nil :array t :level 2 :length 1)
+ "#2A((# ...) ...)"))
+(let* ((array '#2A(((10) #(100)) ((0 1 2) #2A((3) (4) (5) (6) (7))))))
+ (string= (write-to-string array
+ :pretty nil :array t :level 2 :length 2)
+ "#2A((# #) (# #))"))
+(let* ((array '#2A(((10) #(100)) ((0 1 2) #2A((3) (4) (5) (6) (7))))))
+ (string= (write-to-string array
+ :pretty nil :array t :level 3 :length 1)
+ "#2A(((10) ...) ...)"))
+(let* ((array '#2A(((10) #(100)) ((0 1 2) #2A((3) (4) (5) (6) (7))))))
+ (string= (write-to-string array
+ :pretty nil :array t :level 3 :length 2)
+ "#2A(((10) #(100)) ((0 1 ...) #2A(# # ...)))"))
+(let* ((array '#2A(((10) #(100)) ((0 1 2) #2A((3) (4) (5) (6) (7))))))
+ (string= (write-to-string array
+ :pretty nil :array t :level 4 :length 2)
+ "#2A(((10) #(100)) ((0 1 ...) #2A((3) (4) ...)))"))
+(let* ((array '#2A(((10) #(100)) ((0 1 2) #2A((3) (4) (5) (6) (7))))))
+ (string= (write-to-string array
+ :pretty nil :array t :level 4 :length 3)
+ "#2A(((10) #(100)) ((0 1 2) #2A((3) (4) (5) ...)))"))
+(let* ((array '#2A(((10) #(100)) ((0 1 2) #2A((3) (4) (5) (6) (7))))))
+ (string= (write-to-string array
+ :pretty nil :array t :level 4 :length 5)
+ "#2A(((10) #(100)) ((0 1 2) #2A((3) (4) (5) (6) (7))))"))
+(let* ((array '#2A(((10) #((100)))
+ ((0 (1) ((2))) #2A((3) ((4)) (((5))) ((6)) (7))))))
+ (string= (write-to-string array
+ :pretty nil :array t :level 3 :length 5)
+ "#2A(((10) #(#)) ((0 # #) #2A(# # # # #)))"))
+(let* ((array '#2A(((10) #((100)))
+ ((0 (1) ((2))) #2A((3) ((4)) (((5))) ((6)) (7))))))
+ (string= (write-to-string array
+ :pretty nil :array t :level 4 :length 5)
+ "#2A(((10) #((100))) ((0 (1) (#)) #2A((3) (#) (#) (#) (7))))"))
+(let* ((array '#2A(((10) #((100)))
+ ((0 (1) ((2))) #2A((3) ((4)) (((5))) ((6)) (7))))))
+ (string=
+ (write-to-string array :pretty nil :array t :level 5 :length 5)
+ "#2A(((10) #((100))) ((0 (1) ((2))) #2A((3) ((4)) ((#)) ((6)) (7))))"))
+(let* ((array '#2A(((10) #((100)))
+ ((0 (1) ((2))) #2A((3) ((4)) (((5))) ((6)) (7))))))
+ (string=
+ (write-to-string array :pretty nil :array t :level 6 :length 4)
+ "#2A(((10) #((100))) ((0 (1) ((2))) #2A((3) ((4)) (((5))) ((6)) ...)))"))
+
+
+;; (string= (write-to-string '#1=(0 #1#) :pretty nil :length 1 :circle t)
+;; "(0 ...)") ;; or "#1=(0 ...)"
+
+;; *print-readably*, *print-level*, and *print-length
+(equal (read-from-string
+ (write-to-string '(0 1 2) :pretty nil :readably t :level 0 :length 0))
+ '(0 1 2))
+(equalp (read-from-string
+ (write-to-string #(0 1 2) :pretty nil :readably t :level 0 :length 0))
+ #(0 1 2))
+(equalp (read-from-string
+ (write-to-string #2A((0) (1) (2))
+ :pretty nil :readably t :level 0 :length 0))
+ #2A((0) (1) (2)))
+
+
+;; *print-level* *print-length*
+;; Variable *PRINT-LEVEL*, *PRINT-LENGTH*
+;; http://www.lispworks.com/reference/HyperSpec/Body/v_pr_lev.htm
+;; *print-level* and *print-length* affect the printing of an any object
+;; printed with a list-like syntax. They do not affect the printing of
+;; symbols, strings, and bit vectors.
+(string= "LENGTH" (write-to-string 'LENGTH :escape nil :level 0))
+(string= "LENGTH" (write-to-string 'LENGTH :escape nil :length 2))
+(string= "LENGTH" (write-to-string 'LENGTH :escape nil :level 0 :length 0))
+(string= "abcdefg" (write-to-string "abcdefg" :escape nil :level 0))
+(string= "abcdefg" (write-to-string "abcdefg" :escape nil :length 2))
+(string= "abcdefg" (write-to-string "abcdefg" :escape nil :level 0 :length 0))
+(string= "#*0101" (write-to-string #*0101 :array t :level 0))
+(string= "#*0101" (write-to-string #*0101 :array t :length 2))
+(string= "#*0101" (write-to-string #*0101 :array t :level 0 :length 0))
diff --git a/Sacla/tests/must-printer.patch b/Sacla/tests/must-printer.patch
new file mode 100644
index 0000000..0f3b883
--- /dev/null
+++ b/Sacla/tests/must-printer.patch
@@ -0,0 +1,13 @@
+*** sacla/lisp/test/must-printer.lisp 2004-08-03 08:34:55.000000000 +0200
+--- CLISP/clisp-20040712/sacla-tests/must-printer.lisp 2004-08-07 02:40:21.000000000 +0200
+***************
+*** 774,779 ****
+--- 774,780 ----
+ (string= "G01" (write-to-string (make-symbol "G01") :escape t :gensym nil))
+ (string= "G01" (write-to-string (make-symbol "G01") :escape nil :gensym nil))
+ (string= "#:G01" (write-to-string (make-symbol "G01") :escape t :gensym t))
++ #-CLISP ; CLISP prints symbols readably with vertical bars: "#:|G01|"
+ (string= "#:G01"
+ ;; Variable *PRINT-READABLY*
+ ;; http://www.lispworks.com/reference/HyperSpec/Body/v_pr_rda.htm
+
diff --git a/Sacla/tests/must-reader.lisp b/Sacla/tests/must-reader.lisp
new file mode 100644
index 0000000..d491390
--- /dev/null
+++ b/Sacla/tests/must-reader.lisp
@@ -0,0 +1,3052 @@
+;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
+;; ALL RIGHTS RESERVED.
+;;
+;; $Id: must-reader.lisp,v 1.11 2004/08/09 02:49:54 yuji Exp $
+;;
+;; 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.
+;;
+;; 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.
+
+
+(symbolp (read-from-string"|ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789!$\"'(),_-./:;?+<=>#%&*@[\\]{\|}`^~|"))
+(eq (read-from-string "this") 'this)
+(eq (read-from-string "cl:car") 'cl:car)
+(eq (read-from-string ":ok") :ok)
+(eq (read-from-string "ok#") 'ok\#)
+(eq (read-from-string "x#x") 'x\#x)
+(eq (read-from-string "abc(x y z)") 'abc)
+(multiple-value-bind (obj pos) (read-from-string "abc(x y z)")
+ (and (eq obj 'abc)
+ (equal (read-from-string "abc(x y z)" t nil :start pos) '(x y z))))
+(eq (read-from-string "abc") (read-from-string "ABC"))
+(eq (read-from-string "abc") (read-from-string "|ABC|"))
+(eq (read-from-string "abc") (read-from-string "a|B|c"))
+(not (eq (read-from-string "abc") (read-from-string "|abc|")))
+(eq (read-from-string "abc") (read-from-string "\\A\\B\\C"))
+(eq (read-from-string "abc") (read-from-string "a\\Bc"))
+(eq (read-from-string "abc") (read-from-string "\\ABC"))
+(not (eq (read-from-string "abc") (read-from-string "\\abc")))
+
+(= 1 (eval (read-from-string "(length '(this-that))")))
+(= 3 (eval (read-from-string "(length '(this - that))")))
+(= 2 (eval (read-from-string "(length '(a
+ b))")))
+(= 34 (eval (read-from-string "(+ 34)")))
+(= 7 (eval (read-from-string "(+ 3 4)")))
+
+
+(eq :key (let ((*package* (find-package "KEYWORD"))) (read-from-string "key")))
+(progn
+ (when (find-package 'test-foo) (delete-package 'test-foo))
+ (let ((*package* (make-package 'test-foo :use nil)))
+ (and (not (find-symbol "BAR"))
+ (eq (read-from-string "bar") (find-symbol "BAR")))))
+
+
+
+
+(= (read-from-string "1.0") 1.0)
+(= (read-from-string "2/3") 2/3)
+(zerop (read-from-string "0"))
+(zerop (read-from-string "0.0"))
+(zerop (read-from-string "0/3"))
+
+(null (read-from-string "()"))
+(equal (read-from-string "(a)") '(a))
+(equal (read-from-string "(a b)") '(a b))
+(equal (read-from-string "(a b c)") '(a b c))
+(equal (read-from-string "(a b c d)") '(a b c d))
+(equal (read-from-string "(a b c d e)") '(a b c d e))
+(equal (read-from-string "(a b c d e f)") '(a b c d e f))
+(equal (read-from-string "(a b c d e f g)") '(a b c d e f g))
+(equal (read-from-string "(a b c d e f g h)") '(a b c d e f g h))
+(handler-case (read-from-string ".")
+ (reader-error () t)
+ (error () nil)
+ (:no-error (&rest rest) (declare (ignore rest)) nil))
+(handler-case (read-from-string "...")
+ (reader-error () t)
+ (error () nil)
+ (:no-error (&rest rest) (declare (ignore rest)) nil))
+
+(let ((*read-base* 8)) (= (read-from-string "0") 0))
+(let ((*read-base* 8)) (= (read-from-string "1") 1))
+(let ((*read-base* 8)) (= (read-from-string "2") 2))
+(let ((*read-base* 8)) (= (read-from-string "3") 3))
+(let ((*read-base* 8)) (= (read-from-string "4") 4))
+(let ((*read-base* 8)) (= (read-from-string "5") 5))
+(let ((*read-base* 8)) (= (read-from-string "6") 6))
+(let ((*read-base* 8)) (= (read-from-string "7") 7))
+(let ((*read-base* 8)) (= (read-from-string "8.") 8))
+(let ((*read-base* 8)) (= (read-from-string "10") 8))
+(let ((*read-base* 8)) (= (read-from-string "11") 9))
+(let ((*read-base* 8)) (= (read-from-string "12") 10))
+(let ((*read-base* 8)) (= (read-from-string "13") 11))
+(let ((*read-base* 8)) (= (read-from-string "14") 12))
+(let ((*read-base* 8)) (= (read-from-string "15") 13))
+(let ((*read-base* 8)) (= (read-from-string "16") 14))
+(let ((*read-base* 8)) (= (read-from-string "17") 15))
+(let ((*read-base* 8)) (= (read-from-string "20") 16))
+(let ((*read-base* 8)) (= (read-from-string "21") 17))
+
+(let ((*read-base* 16)) (= (read-from-string "0") 0))
+(let ((*read-base* 16)) (= (read-from-string "1") 1))
+(let ((*read-base* 16)) (= (read-from-string "2") 2))
+(let ((*read-base* 16)) (= (read-from-string "3") 3))
+(let ((*read-base* 16)) (= (read-from-string "4") 4))
+(let ((*read-base* 16)) (= (read-from-string "5") 5))
+(let ((*read-base* 16)) (= (read-from-string "6") 6))
+(let ((*read-base* 16)) (= (read-from-string "7") 7))
+(let ((*read-base* 16)) (= (read-from-string "8") 8))
+(let ((*read-base* 16)) (= (read-from-string "9") 9))
+(let ((*read-base* 16)) (= (read-from-string "A") 10))
+(let ((*read-base* 16)) (= (read-from-string "a") 10))
+(let ((*read-base* 16)) (= (read-from-string "B") 11))
+(let ((*read-base* 16)) (= (read-from-string "b") 11))
+(let ((*read-base* 16)) (= (read-from-string "C") 12))
+(let ((*read-base* 16)) (= (read-from-string "c") 12))
+(let ((*read-base* 16)) (= (read-from-string "D") 13))
+(let ((*read-base* 16)) (= (read-from-string "d") 13))
+(let ((*read-base* 16)) (= (read-from-string "E") 14))
+(let ((*read-base* 16)) (= (read-from-string "e") 14))
+(let ((*read-base* 16)) (= (read-from-string "F") 15))
+(let ((*read-base* 16)) (= (read-from-string "f") 15))
+(let ((*read-base* 16)) (= (read-from-string "10") 16))
+(let ((*read-base* 16)) (= (read-from-string "11") 17))
+(let ((*read-base* 16)) (= (read-from-string "12") 18))
+(let ((*read-base* 16)) (= (read-from-string "13") 19))
+(let ((*read-base* 16)) (= (read-from-string "14") 20))
+(let ((*read-base* 16)) (= (read-from-string "15") 21))
+(let ((*read-base* 16)) (= (read-from-string "16") 22))
+(let ((*read-base* 16)) (= (read-from-string "17") 23))
+(let ((*read-base* 16)) (= (read-from-string "18") 24))
+(let ((*read-base* 16)) (= (read-from-string "19") 25))
+(let ((*read-base* 16)) (= (read-from-string "1A") 26))
+(let ((*read-base* 16)) (= (read-from-string "1a") 26))
+(let ((*read-base* 16)) (= (read-from-string "1B") 27))
+(let ((*read-base* 16)) (= (read-from-string "1b") 27))
+(let ((*read-base* 16)) (= (read-from-string "1C") 28))
+(let ((*read-base* 16)) (= (read-from-string "1c") 28))
+(let ((*read-base* 16)) (= (read-from-string "1D") 29))
+(let ((*read-base* 16)) (= (read-from-string "1d") 29))
+(let ((*read-base* 16)) (= (read-from-string "1E") 30))
+(let ((*read-base* 16)) (= (read-from-string "1e") 30))
+(let ((*read-base* 16)) (= (read-from-string "1F") 31))
+(let ((*read-base* 16)) (= (read-from-string "1f") 31))
+(let ((*read-base* 16)) (= (read-from-string "20") 32))
+
+
+(= (read-from-string "0") 0)
+(= (read-from-string "+0") 0)
+(= (read-from-string "-0") 0)
+(integerp (read-from-string "0"))
+(integerp (read-from-string "+0"))
+(integerp (read-from-string "-0"))
+(= (read-from-string "1") 1)
+(= (read-from-string "+1") 1)
+(= (read-from-string "-1") -1)
+(integerp (read-from-string "1"))
+(integerp (read-from-string "+1"))
+(integerp (read-from-string "-1"))
+(= (read-from-string "12") 12)
+(= (read-from-string "+12") 12)
+(= (read-from-string "-12") -12)
+(integerp (read-from-string "12"))
+(integerp (read-from-string "+12"))
+(integerp (read-from-string "-12"))
+(= (read-from-string "123") 123)
+(= (read-from-string "+123") 123)
+(= (read-from-string "-123") -123)
+(integerp (read-from-string "123"))
+(integerp (read-from-string "+123"))
+(integerp (read-from-string "-123"))
+(= (read-from-string "1234") 1234)
+(= (read-from-string "+1234") 1234)
+(= (read-from-string "-1234") -1234)
+(integerp (read-from-string "1234"))
+(integerp (read-from-string "+1234"))
+(integerp (read-from-string "-1234"))
+(= (read-from-string "12345") 12345)
+(= (read-from-string "+12345") 12345)
+(= (read-from-string "-12345") -12345)
+(integerp (read-from-string "12345"))
+(integerp (read-from-string "+12345"))
+(integerp (read-from-string "-12345"))
+(integerp (read-from-string "48148148031244413808971345"))
+(integerp (read-from-string "+48148148031244413808971345"))
+(integerp (read-from-string "-48148148031244413808971345"))
+
+(= (read-from-string "0.") 0)
+(= (read-from-string "+0.") 0)
+(= (read-from-string "-0.") 0)
+(integerp (read-from-string "0."))
+(integerp (read-from-string "+0."))
+(integerp (read-from-string "-0."))
+(= (read-from-string "1.") 1)
+(= (read-from-string "+1.") 1)
+(= (read-from-string "-1.") -1)
+(integerp (read-from-string "1."))
+(integerp (read-from-string "+1."))
+(integerp (read-from-string "-1."))
+(= (read-from-string "12.") 12)
+(= (read-from-string "+12.") 12)
+(= (read-from-string "-12.") -12)
+(integerp (read-from-string "12."))
+(integerp (read-from-string "+12."))
+(integerp (read-from-string "-12."))
+(= (read-from-string "123.") 123)
+(= (read-from-string "+123.") 123)
+(= (read-from-string "-123.") -123)
+(integerp (read-from-string "123."))
+(integerp (read-from-string "+123."))
+(integerp (read-from-string "-123."))
+(= (read-from-string "1234.") 1234)
+(= (read-from-string "+1234.") 1234)
+(= (read-from-string "-1234.") -1234)
+(integerp (read-from-string "1234."))
+(integerp (read-from-string "+1234."))
+(integerp (read-from-string "-1234."))
+(= (read-from-string "12345.") 12345)
+(= (read-from-string "+12345.") 12345)
+(= (read-from-string "-12345.") -12345)
+(integerp (read-from-string "12345."))
+(integerp (read-from-string "+12345."))
+(integerp (read-from-string "-12345."))
+(integerp (read-from-string "48148148031244413808971345."))
+(integerp (read-from-string "+48148148031244413808971345."))
+(integerp (read-from-string "-48148148031244413808971345."))
+
+(zerop (let ((*read-base* 2)) (read-from-string "0")))
+(zerop (let ((*read-base* 2)) (read-from-string "+0")))
+(zerop (let ((*read-base* 2)) (read-from-string "-0")))
+(= 1 (let ((*read-base* 2)) (read-from-string "1")))
+(= 1 (let ((*read-base* 2)) (read-from-string "+1")))
+(= -1 (let ((*read-base* 2)) (read-from-string "-1")))
+(= 2 (let ((*read-base* 2)) (read-from-string "10")))
+(= 2 (let ((*read-base* 2)) (read-from-string "+10")))
+(= -2 (let ((*read-base* 2)) (read-from-string "-10")))
+(= 3 (let ((*read-base* 2)) (read-from-string "11")))
+(= 3 (let ((*read-base* 2)) (read-from-string "+11")))
+(= -3 (let ((*read-base* 2)) (read-from-string "-11")))
+(= -11 (let ((*read-base* 2)) (read-from-string "-11.")))
+(integerp (let ((*read-base* 2)) (read-from-string "-11.")))
+(= 21 (let ((*read-base* 2)) (read-from-string "10101")))
+(= 21 (let ((*read-base* 2)) (read-from-string "+10101")))
+(= -21 (let ((*read-base* 2)) (read-from-string "-10101")))
+(= -1.0101 (let ((*read-base* 2)) (read-from-string "-1.0101")))
+(= 1.0101 (let ((*read-base* 2)) (read-from-string "1.0101")))
+(= 123 (let ((*read-base* 2)) (read-from-string "123.")))
+
+(zerop (let ((*read-base* 3)) (read-from-string "0")))
+(zerop (let ((*read-base* 3)) (read-from-string "+0")))
+(zerop (let ((*read-base* 3)) (read-from-string "-0")))
+(= 1 (let ((*read-base* 3)) (read-from-string "1")))
+(= 1 (let ((*read-base* 3)) (read-from-string "+1")))
+(= -1 (let ((*read-base* 3)) (read-from-string "-1")))
+(= 2 (let ((*read-base* 3)) (read-from-string "2")))
+(= 2 (let ((*read-base* 3)) (read-from-string "+2")))
+(= -2 (let ((*read-base* 3)) (read-from-string "-2")))
+(= 3 (let ((*read-base* 3)) (read-from-string "10")))
+(= 3 (let ((*read-base* 3)) (read-from-string "+10")))
+(= -3 (let ((*read-base* 3)) (read-from-string "-10")))
+(= 4 (let ((*read-base* 3)) (read-from-string "11")))
+(= 4 (let ((*read-base* 3)) (read-from-string "+11")))
+(= -4 (let ((*read-base* 3)) (read-from-string "-11")))
+(= 5 (let ((*read-base* 3)) (read-from-string "12")))
+(= 5 (let ((*read-base* 3)) (read-from-string "+12")))
+(= -5 (let ((*read-base* 3)) (read-from-string "-12")))
+(= 6 (let ((*read-base* 3)) (read-from-string "20")))
+(= 6 (let ((*read-base* 3)) (read-from-string "+20")))
+(= -6 (let ((*read-base* 3)) (read-from-string "-20")))
+(= 7 (let ((*read-base* 3)) (read-from-string "21")))
+(= 7 (let ((*read-base* 3)) (read-from-string "+21")))
+(= -7 (let ((*read-base* 3)) (read-from-string "-21")))
+(= 8 (let ((*read-base* 3)) (read-from-string "22")))
+(= 8 (let ((*read-base* 3)) (read-from-string "+22")))
+(= -8 (let ((*read-base* 3)) (read-from-string "-22")))
+
+(= 391514 (let ((*read-base* 3)) (read-from-string "201220001112")))
+(= 391514 (let ((*read-base* 3)) (read-from-string "+201220001112")))
+(= -391514 (let ((*read-base* 3)) (read-from-string "-201220001112")))
+
+(zerop (let ((*read-base* 8)) (read-from-string "0")))
+(zerop (let ((*read-base* 8)) (read-from-string "+0")))
+(zerop (let ((*read-base* 8)) (read-from-string "-0")))
+(= 1 (let ((*read-base* 8)) (read-from-string "1")))
+(= 1 (let ((*read-base* 8)) (read-from-string "+1")))
+(= -1 (let ((*read-base* 8)) (read-from-string "-1")))
+(= 7 (let ((*read-base* 8)) (read-from-string "7")))
+(= 7 (let ((*read-base* 8)) (read-from-string "+7")))
+(= -7 (let ((*read-base* 8)) (read-from-string "-7")))
+
+
+(zerop (let ((*read-base* 16)) (read-from-string "0")))
+(zerop (let ((*read-base* 16)) (read-from-string "+0")))
+(zerop (let ((*read-base* 16)) (read-from-string "-0")))
+(= 1 (let ((*read-base* 16)) (read-from-string "1")))
+(= 1 (let ((*read-base* 16)) (read-from-string "+1")))
+(= -1 (let ((*read-base* 16)) (read-from-string "-1")))
+(= 9 (let ((*read-base* 16)) (read-from-string "9")))
+(= 9 (let ((*read-base* 16)) (read-from-string "+9")))
+(= -9 (let ((*read-base* 16)) (read-from-string "-9")))
+(= 15 (let ((*read-base* 16)) (read-from-string "F")))
+(= -15 (let ((*read-base* 16)) (read-from-string "-F")))
+(= 15 (let ((*read-base* 16)) (read-from-string "F")))
+(= 15 (let ((*read-base* 16)) (read-from-string "f")))
+(= -15 (let ((*read-base* 16)) (read-from-string "-f")))
+(= 15 (let ((*read-base* 16)) (read-from-string "f")))
+(= 31 (let ((*read-base* 16)) (read-from-string "1F")))
+(= 31 (let ((*read-base* 16)) (read-from-string "+1F")))
+(= -31 (let ((*read-base* 16)) (read-from-string "-1F")))
+(= #x3F (let ((*read-base* 16)) (read-from-string "3F")))
+(= #x3F (let ((*read-base* 16)) (read-from-string "+3F")))
+(= #x-3F (let ((*read-base* 16)) (read-from-string "-3F")))
+(= 9 (let ((*read-base* 16)) (read-from-string "9.")))
+(integerp (let ((*read-base* 16)) (read-from-string "9.")))
+(= 10 (let ((*read-base* 16)) (read-from-string "10.")))
+(integerp (let ((*read-base* 16)) (read-from-string "10.")))
+
+(equal (let (stack)
+ (dotimes (i 6 stack)
+ (let ((*read-base* (+ 10. i)))
+ (let ((object (read-from-string "(\\DAD DAD |BEE| BEE 123. 123)")))
+ (push (list *read-base* object) stack)))))
+ '((15 (DAD 3088 BEE 2699 123 258))
+ (14 (DAD 2701 BEE BEE 123 227))
+ (13 (DAD DAD BEE BEE 123 198))
+ (12 (DAD DAD BEE BEE 123 171))
+ (11 (DAD DAD BEE BEE 123 146))
+ (10 (DAD DAD BEE BEE 123 123))))
+
+(loop for i from 2 upto 32
+ always (zerop (let ((*read-base* i)) (read-from-string "0"))))
+(loop for i from 2 upto 32
+ always (zerop (let ((*read-base* i)) (read-from-string "+0"))))
+(loop for i from 2 upto 32
+ always (zerop (let ((*read-base* i)) (read-from-string "-0"))))
+(loop for i from 2 upto 32
+ always (= 1 (let ((*read-base* i)) (read-from-string "1"))))
+(loop for i from 2 upto 32
+ always (= 1 (let ((*read-base* i)) (read-from-string "+1"))))
+(loop for i from 2 upto 32
+ always (= -1 (let ((*read-base* i)) (read-from-string "-1"))))
+(loop for i from 2 upto 32
+ for n = (let ((*read-base* i)) (read-from-string "10."))
+ always (and (integerp n) (= 10 n)))
+(loop for i from 2 upto 32
+ for n = (let ((*read-base* i)) (read-from-string "+10."))
+ always (and (integerp n) (= 10 n)))
+(loop for i from 2 upto 32
+ for n = (let ((*read-base* i)) (read-from-string "-10."))
+ always (and (integerp n) (= -10 n)))
+(loop for i from 2 upto 32
+ for n = (let ((*read-base* i)) (read-from-string "1.1"))
+ always (= 1.1 n))
+(loop for i from 2 upto 32
+ for n = (let ((*read-base* i)) (read-from-string "+1.1"))
+ always (= 1.1 n))
+(loop for i from 2 upto 32
+ for n = (let ((*read-base* i)) (read-from-string "-1.1"))
+ always (= -1.1 n))
+
+(zerop (read-from-string "0/2"))
+(zerop (read-from-string "0/3"))
+(zerop (read-from-string "0/4"))
+(zerop (read-from-string "0/5"))
+(zerop (read-from-string "0/6"))
+(zerop (read-from-string "0/7"))
+(zerop (read-from-string "0/8"))
+(zerop (read-from-string "0/9"))
+(zerop (read-from-string "0/10"))
+(zerop (read-from-string "0/11"))
+(zerop (read-from-string "0/12"))
+(zerop (read-from-string "0/13"))
+(zerop (read-from-string "0/14"))
+(zerop (read-from-string "0/15"))
+(zerop (read-from-string "0/16"))
+(zerop (read-from-string "0/17"))
+(zerop (read-from-string "0/18"))
+(zerop (read-from-string "0/19"))
+(zerop (read-from-string "0/20"))
+
+(= 1/2 (read-from-string "1/2"))
+(= 1/3 (read-from-string "1/3"))
+(= 1/4 (read-from-string "1/4"))
+(= 1/5 (read-from-string "1/5"))
+(= 1/6 (read-from-string "1/6"))
+(= 1/7 (read-from-string "1/7"))
+(= 1/8 (read-from-string "1/8"))
+(= 1/9 (read-from-string "1/9"))
+(= 1/10 (read-from-string "1/10"))
+(= 1/11 (read-from-string "1/11"))
+(= 1/12 (read-from-string "1/12"))
+(= 1/13 (read-from-string "1/13"))
+(= 1/14 (read-from-string "1/14"))
+(= 1/15 (read-from-string "1/15"))
+(= 1/16 (read-from-string "1/16"))
+(= 1/17 (read-from-string "1/17"))
+(= 1/18 (read-from-string "1/18"))
+(= 1/19 (read-from-string "1/19"))
+(= 1/20 (read-from-string "1/20"))
+
+(= 2/2 (read-from-string "2/2"))
+(= 2/3 (read-from-string "2/3"))
+(= 2/4 (read-from-string "2/4"))
+(= 2/5 (read-from-string "2/5"))
+(= 2/6 (read-from-string "2/6"))
+(= 2/7 (read-from-string "2/7"))
+(= 2/8 (read-from-string "2/8"))
+(= 2/9 (read-from-string "2/9"))
+(= 2/10 (read-from-string "2/10"))
+(= 2/11 (read-from-string "2/11"))
+(= 2/12 (read-from-string "2/12"))
+(= 2/13 (read-from-string "2/13"))
+(= 2/14 (read-from-string "2/14"))
+(= 2/15 (read-from-string "2/15"))
+(= 2/16 (read-from-string "2/16"))
+(= 2/17 (read-from-string "2/17"))
+(= 2/18 (read-from-string "2/18"))
+(= 2/19 (read-from-string "2/19"))
+(= 2/20 (read-from-string "2/20"))
+
+(= 17/2 (read-from-string "17/2"))
+(= 17/3 (read-from-string "17/3"))
+(= 17/4 (read-from-string "17/4"))
+(= 17/5 (read-from-string "17/5"))
+(= 17/6 (read-from-string "17/6"))
+(= 17/7 (read-from-string "17/7"))
+(= 17/8 (read-from-string "17/8"))
+(= 17/9 (read-from-string "17/9"))
+(= 17/10 (read-from-string "17/10"))
+(= 17/11 (read-from-string "17/11"))
+(= 17/12 (read-from-string "17/12"))
+(= 17/13 (read-from-string "17/13"))
+(= 17/14 (read-from-string "17/14"))
+(= 17/15 (read-from-string "17/15"))
+(= 17/16 (read-from-string "17/16"))
+(= 17/17 (read-from-string "17/17"))
+(= 17/18 (read-from-string "17/18"))
+(= 17/19 (read-from-string "17/19"))
+(= 17/20 (read-from-string "17/20"))
+
+(= 0 (let ((*read-base* 2)) (read-from-string "0/1")))
+(= 1 (let ((*read-base* 2)) (read-from-string "1/1")))
+(= 1/2 (let ((*read-base* 2)) (read-from-string "1/10")))
+(= 1/3 (let ((*read-base* 2)) (read-from-string "1/11")))
+(= 1/4 (let ((*read-base* 2)) (read-from-string "1/100")))
+(= 1/5 (let ((*read-base* 2)) (read-from-string "1/101")))
+(= 1/6 (let ((*read-base* 2)) (read-from-string "1/110")))
+(= 1/7 (let ((*read-base* 2)) (read-from-string "1/111")))
+(= 1/8 (let ((*read-base* 2)) (read-from-string "1/1000")))
+(= 1/9 (let ((*read-base* 2)) (read-from-string "1/1001")))
+(= 1/10 (let ((*read-base* 2)) (read-from-string "1/1010")))
+(= 1/11 (let ((*read-base* 2)) (read-from-string "1/1011")))
+(= 1/12 (let ((*read-base* 2)) (read-from-string "1/1100")))
+(= 1/13 (let ((*read-base* 2)) (read-from-string "1/1101")))
+(= 1/14 (let ((*read-base* 2)) (read-from-string "1/1110")))
+(= 1/15 (let ((*read-base* 2)) (read-from-string "1/1111")))
+(= 1/16 (let ((*read-base* 2)) (read-from-string "1/10000")))
+(= 1/17 (let ((*read-base* 2)) (read-from-string "1/10001")))
+(= 1/18 (let ((*read-base* 2)) (read-from-string "1/10010")))
+(= 1/19 (let ((*read-base* 2)) (read-from-string "1/10011")))
+(= 1/20 (let ((*read-base* 2)) (read-from-string "1/10100")))
+(= 1/21 (let ((*read-base* 2)) (read-from-string "1/10101")))
+(= 1/22 (let ((*read-base* 2)) (read-from-string "1/10110")))
+(= 1/23 (let ((*read-base* 2)) (read-from-string "1/10111")))
+
+(= 2 (let ((*read-base* 2)) (read-from-string "10/1")))
+(= 2/2 (let ((*read-base* 2)) (read-from-string "10/10")))
+(= 2/3 (let ((*read-base* 2)) (read-from-string "10/11")))
+(= 2/4 (let ((*read-base* 2)) (read-from-string "10/100")))
+(= 2/5 (let ((*read-base* 2)) (read-from-string "10/101")))
+(= 2/6 (let ((*read-base* 2)) (read-from-string "10/110")))
+(= 2/7 (let ((*read-base* 2)) (read-from-string "10/111")))
+(= 2/8 (let ((*read-base* 2)) (read-from-string "10/1000")))
+(= 2/9 (let ((*read-base* 2)) (read-from-string "10/1001")))
+(= 2/10 (let ((*read-base* 2)) (read-from-string "10/1010")))
+(= 2/11 (let ((*read-base* 2)) (read-from-string "10/1011")))
+(= 2/12 (let ((*read-base* 2)) (read-from-string "10/1100")))
+(= 2/13 (let ((*read-base* 2)) (read-from-string "10/1101")))
+(= 2/14 (let ((*read-base* 2)) (read-from-string "10/1110")))
+(= 2/15 (let ((*read-base* 2)) (read-from-string "10/1111")))
+(= 2/16 (let ((*read-base* 2)) (read-from-string "10/10000")))
+(= 2/17 (let ((*read-base* 2)) (read-from-string "10/10001")))
+(= 2/18 (let ((*read-base* 2)) (read-from-string "10/10010")))
+(= 2/19 (let ((*read-base* 2)) (read-from-string "10/10011")))
+(= 2/20 (let ((*read-base* 2)) (read-from-string "10/10100")))
+(= 2/21 (let ((*read-base* 2)) (read-from-string "10/10101")))
+(= 2/22 (let ((*read-base* 2)) (read-from-string "10/10110")))
+(= 2/23 (let ((*read-base* 2)) (read-from-string "10/10111")))
+
+(= 3 (let ((*read-base* 2)) (read-from-string "11/1")))
+(= 3/2 (let ((*read-base* 2)) (read-from-string "11/10")))
+(= 3/3 (let ((*read-base* 2)) (read-from-string "11/11")))
+(= 3/4 (let ((*read-base* 2)) (read-from-string "11/100")))
+(= 3/5 (let ((*read-base* 2)) (read-from-string "11/101")))
+(= 3/6 (let ((*read-base* 2)) (read-from-string "11/110")))
+(= 3/7 (let ((*read-base* 2)) (read-from-string "11/111")))
+(= 3/8 (let ((*read-base* 2)) (read-from-string "11/1000")))
+(= 3/9 (let ((*read-base* 2)) (read-from-string "11/1001")))
+(= 3/10 (let ((*read-base* 2)) (read-from-string "11/1010")))
+(= 3/11 (let ((*read-base* 2)) (read-from-string "11/1011")))
+(= 3/12 (let ((*read-base* 2)) (read-from-string "11/1100")))
+(= 3/13 (let ((*read-base* 2)) (read-from-string "11/1101")))
+(= 3/14 (let ((*read-base* 2)) (read-from-string "11/1110")))
+(= 3/15 (let ((*read-base* 2)) (read-from-string "11/1111")))
+(= 3/16 (let ((*read-base* 2)) (read-from-string "11/10000")))
+(= 3/17 (let ((*read-base* 2)) (read-from-string "11/10001")))
+(= 3/18 (let ((*read-base* 2)) (read-from-string "11/10010")))
+(= 3/19 (let ((*read-base* 2)) (read-from-string "11/10011")))
+(= 3/20 (let ((*read-base* 2)) (read-from-string "11/10100")))
+(= 3/21 (let ((*read-base* 2)) (read-from-string "11/10101")))
+(= 3/22 (let ((*read-base* 2)) (read-from-string "11/10110")))
+(= 3/23 (let ((*read-base* 2)) (read-from-string "11/10111")))
+
+(= 0 (let ((*read-base* 8)) (read-from-string "0/1")))
+(= 1/2 (let ((*read-base* 8)) (read-from-string "1/2")))
+(= 1/3 (let ((*read-base* 8)) (read-from-string "1/3")))
+(= 1/4 (let ((*read-base* 8)) (read-from-string "1/4")))
+(= 1/5 (let ((*read-base* 8)) (read-from-string "1/5")))
+(= 1/6 (let ((*read-base* 8)) (read-from-string "1/6")))
+(= 1/7 (let ((*read-base* 8)) (read-from-string "1/7")))
+(= 1/8 (let ((*read-base* 8)) (read-from-string "1/10")))
+(= 1/9 (let ((*read-base* 8)) (read-from-string "1/11")))
+(= 1/10 (let ((*read-base* 8)) (read-from-string "1/12")))
+(= 1/11 (let ((*read-base* 8)) (read-from-string "1/13")))
+(= 1/12 (let ((*read-base* 8)) (read-from-string "1/14")))
+(= 1/13 (let ((*read-base* 8)) (read-from-string "1/15")))
+(= 1/14 (let ((*read-base* 8)) (read-from-string "1/16")))
+(= 1/15 (let ((*read-base* 8)) (read-from-string "1/17")))
+(= 1/16 (let ((*read-base* 8)) (read-from-string "1/20")))
+(= 1/17 (let ((*read-base* 8)) (read-from-string "1/21")))
+(= 1/18 (let ((*read-base* 8)) (read-from-string "1/22")))
+(= 1/19 (let ((*read-base* 8)) (read-from-string "1/23")))
+(= 1/20 (let ((*read-base* 8)) (read-from-string "1/24")))
+
+(= 3/2 (let ((*read-base* 8)) (read-from-string "3/2")))
+(= 3/3 (let ((*read-base* 8)) (read-from-string "3/3")))
+(= 3/4 (let ((*read-base* 8)) (read-from-string "3/4")))
+(= 3/5 (let ((*read-base* 8)) (read-from-string "3/5")))
+(= 3/6 (let ((*read-base* 8)) (read-from-string "3/6")))
+(= 3/7 (let ((*read-base* 8)) (read-from-string "3/7")))
+(= 3/8 (let ((*read-base* 8)) (read-from-string "3/10")))
+(= 3/9 (let ((*read-base* 8)) (read-from-string "3/11")))
+(= 3/10 (let ((*read-base* 8)) (read-from-string "3/12")))
+(= 3/11 (let ((*read-base* 8)) (read-from-string "3/13")))
+(= 3/12 (let ((*read-base* 8)) (read-from-string "3/14")))
+(= 3/13 (let ((*read-base* 8)) (read-from-string "3/15")))
+(= 3/14 (let ((*read-base* 8)) (read-from-string "3/16")))
+(= 3/15 (let ((*read-base* 8)) (read-from-string "3/17")))
+(= 3/16 (let ((*read-base* 8)) (read-from-string "3/20")))
+(= 3/17 (let ((*read-base* 8)) (read-from-string "3/21")))
+(= 3/18 (let ((*read-base* 8)) (read-from-string "3/22")))
+(= 3/19 (let ((*read-base* 8)) (read-from-string "3/23")))
+(= 3/20 (let ((*read-base* 8)) (read-from-string "3/24")))
+
+(= 13/2 (let ((*read-base* 8)) (read-from-string "15/2")))
+(= 13/3 (let ((*read-base* 8)) (read-from-string "15/3")))
+(= 13/4 (let ((*read-base* 8)) (read-from-string "15/4")))
+(= 13/5 (let ((*read-base* 8)) (read-from-string "15/5")))
+(= 13/6 (let ((*read-base* 8)) (read-from-string "15/6")))
+(= 13/7 (let ((*read-base* 8)) (read-from-string "15/7")))
+(= 13/8 (let ((*read-base* 8)) (read-from-string "15/10")))
+(= 13/9 (let ((*read-base* 8)) (read-from-string "15/11")))
+(= 13/10 (let ((*read-base* 8)) (read-from-string "15/12")))
+(= 13/11 (let ((*read-base* 8)) (read-from-string "15/13")))
+(= 13/12 (let ((*read-base* 8)) (read-from-string "15/14")))
+(= 13/13 (let ((*read-base* 8)) (read-from-string "15/15")))
+(= 13/14 (let ((*read-base* 8)) (read-from-string "15/16")))
+(= 13/15 (let ((*read-base* 8)) (read-from-string "15/17")))
+(= 13/16 (let ((*read-base* 8)) (read-from-string "15/20")))
+(= 13/17 (let ((*read-base* 8)) (read-from-string "15/21")))
+(= 13/18 (let ((*read-base* 8)) (read-from-string "15/22")))
+(= 13/19 (let ((*read-base* 8)) (read-from-string "15/23")))
+(= 13/20 (let ((*read-base* 8)) (read-from-string "15/24")))
+
+
+(= 0 (let ((*read-base* 16)) (read-from-string "0/1")))
+(= 1/2 (let ((*read-base* 16)) (read-from-string "1/2")))
+(= 1/3 (let ((*read-base* 16)) (read-from-string "1/3")))
+(= 1/4 (let ((*read-base* 16)) (read-from-string "1/4")))
+(= 1/5 (let ((*read-base* 16)) (read-from-string "1/5")))
+(= 1/6 (let ((*read-base* 16)) (read-from-string "1/6")))
+(= 1/7 (let ((*read-base* 16)) (read-from-string "1/7")))
+(= 1/8 (let ((*read-base* 16)) (read-from-string "1/8")))
+(= 1/9 (let ((*read-base* 16)) (read-from-string "1/9")))
+(= 1/10 (let ((*read-base* 16)) (read-from-string "1/A")))
+(= 1/11 (let ((*read-base* 16)) (read-from-string "1/B")))
+(= 1/12 (let ((*read-base* 16)) (read-from-string "1/C")))
+(= 1/13 (let ((*read-base* 16)) (read-from-string "1/D")))
+(= 1/14 (let ((*read-base* 16)) (read-from-string "1/E")))
+(= 1/15 (let ((*read-base* 16)) (read-from-string "1/F")))
+(= 1/10 (let ((*read-base* 16)) (read-from-string "1/a")))
+(= 1/11 (let ((*read-base* 16)) (read-from-string "1/b")))
+(= 1/12 (let ((*read-base* 16)) (read-from-string "1/c")))
+(= 1/13 (let ((*read-base* 16)) (read-from-string "1/d")))
+(= 1/14 (let ((*read-base* 16)) (read-from-string "1/e")))
+(= 1/15 (let ((*read-base* 16)) (read-from-string "1/f")))
+(= 1/16 (let ((*read-base* 16)) (read-from-string "1/10")))
+(= 1/17 (let ((*read-base* 16)) (read-from-string "1/11")))
+(= 1/18 (let ((*read-base* 16)) (read-from-string "1/12")))
+(= 1/19 (let ((*read-base* 16)) (read-from-string "1/13")))
+(= 1/20 (let ((*read-base* 16)) (read-from-string "1/14")))
+(= 1/21 (let ((*read-base* 16)) (read-from-string "1/15")))
+(= 1/22 (let ((*read-base* 16)) (read-from-string "1/16")))
+(= 1/23 (let ((*read-base* 16)) (read-from-string "1/17")))
+(= 1/24 (let ((*read-base* 16)) (read-from-string "1/18")))
+(= 1/25 (let ((*read-base* 16)) (read-from-string "1/19")))
+(= 1/26 (let ((*read-base* 16)) (read-from-string "1/1A")))
+(= 1/27 (let ((*read-base* 16)) (read-from-string "1/1B")))
+(= 1/28 (let ((*read-base* 16)) (read-from-string "1/1C")))
+(= 1/29 (let ((*read-base* 16)) (read-from-string "1/1D")))
+(= 1/30 (let ((*read-base* 16)) (read-from-string "1/1E")))
+(= 1/31 (let ((*read-base* 16)) (read-from-string "1/1F")))
+(= 1/32 (let ((*read-base* 16)) (read-from-string "1/20")))
+(= 1/33 (let ((*read-base* 16)) (read-from-string "1/21")))
+(= 1/34 (let ((*read-base* 16)) (read-from-string "1/22")))
+(= 1/35 (let ((*read-base* 16)) (read-from-string "1/23")))
+(= 1/36 (let ((*read-base* 16)) (read-from-string "1/24")))
+
+(= 2/2 (let ((*read-base* 16)) (read-from-string "2/2")))
+(= 2/3 (let ((*read-base* 16)) (read-from-string "2/3")))
+(= 2/4 (let ((*read-base* 16)) (read-from-string "2/4")))
+(= 2/5 (let ((*read-base* 16)) (read-from-string "2/5")))
+(= 2/6 (let ((*read-base* 16)) (read-from-string "2/6")))
+(= 2/7 (let ((*read-base* 16)) (read-from-string "2/7")))
+(= 2/8 (let ((*read-base* 16)) (read-from-string "2/8")))
+(= 2/9 (let ((*read-base* 16)) (read-from-string "2/9")))
+(= 2/10 (let ((*read-base* 16)) (read-from-string "2/A")))
+(= 2/11 (let ((*read-base* 16)) (read-from-string "2/B")))
+(= 2/12 (let ((*read-base* 16)) (read-from-string "2/C")))
+(= 2/13 (let ((*read-base* 16)) (read-from-string "2/D")))
+(= 2/14 (let ((*read-base* 16)) (read-from-string "2/E")))
+(= 2/15 (let ((*read-base* 16)) (read-from-string "2/F")))
+(= 2/10 (let ((*read-base* 16)) (read-from-string "2/a")))
+(= 2/11 (let ((*read-base* 16)) (read-from-string "2/b")))
+(= 2/12 (let ((*read-base* 16)) (read-from-string "2/c")))
+(= 2/13 (let ((*read-base* 16)) (read-from-string "2/d")))
+(= 2/14 (let ((*read-base* 16)) (read-from-string "2/e")))
+(= 2/15 (let ((*read-base* 16)) (read-from-string "2/f")))
+(= 2/16 (let ((*read-base* 16)) (read-from-string "2/10")))
+(= 2/17 (let ((*read-base* 16)) (read-from-string "2/11")))
+(= 2/18 (let ((*read-base* 16)) (read-from-string "2/12")))
+(= 2/19 (let ((*read-base* 16)) (read-from-string "2/13")))
+(= 2/20 (let ((*read-base* 16)) (read-from-string "2/14")))
+(= 2/21 (let ((*read-base* 16)) (read-from-string "2/15")))
+(= 2/22 (let ((*read-base* 16)) (read-from-string "2/16")))
+(= 2/23 (let ((*read-base* 16)) (read-from-string "2/17")))
+(= 2/24 (let ((*read-base* 16)) (read-from-string "2/18")))
+(= 2/25 (let ((*read-base* 16)) (read-from-string "2/19")))
+(= 2/26 (let ((*read-base* 16)) (read-from-string "2/1A")))
+(= 2/27 (let ((*read-base* 16)) (read-from-string "2/1B")))
+(= 2/28 (let ((*read-base* 16)) (read-from-string "2/1C")))
+(= 2/29 (let ((*read-base* 16)) (read-from-string "2/1D")))
+(= 2/30 (let ((*read-base* 16)) (read-from-string "2/1E")))
+(= 2/31 (let ((*read-base* 16)) (read-from-string "2/1F")))
+(= 2/32 (let ((*read-base* 16)) (read-from-string "2/20")))
+(= 2/33 (let ((*read-base* 16)) (read-from-string "2/21")))
+(= 2/34 (let ((*read-base* 16)) (read-from-string "2/22")))
+(= 2/35 (let ((*read-base* 16)) (read-from-string "2/23")))
+(= 2/36 (let ((*read-base* 16)) (read-from-string "2/24")))
+
+
+(= 10/2 (let ((*read-base* 16)) (read-from-string "a/2")))
+(= 10/3 (let ((*read-base* 16)) (read-from-string "a/3")))
+(= 10/4 (let ((*read-base* 16)) (read-from-string "a/4")))
+(= 10/5 (let ((*read-base* 16)) (read-from-string "a/5")))
+(= 10/6 (let ((*read-base* 16)) (read-from-string "a/6")))
+(= 10/7 (let ((*read-base* 16)) (read-from-string "a/7")))
+(= 10/8 (let ((*read-base* 16)) (read-from-string "a/8")))
+(= 10/9 (let ((*read-base* 16)) (read-from-string "a/9")))
+(= 10/10 (let ((*read-base* 16)) (read-from-string "a/A")))
+(= 10/11 (let ((*read-base* 16)) (read-from-string "a/B")))
+(= 10/12 (let ((*read-base* 16)) (read-from-string "a/C")))
+(= 10/13 (let ((*read-base* 16)) (read-from-string "a/D")))
+(= 10/14 (let ((*read-base* 16)) (read-from-string "a/E")))
+(= 10/15 (let ((*read-base* 16)) (read-from-string "a/F")))
+(= 10/10 (let ((*read-base* 16)) (read-from-string "a/a")))
+(= 10/11 (let ((*read-base* 16)) (read-from-string "a/b")))
+(= 10/12 (let ((*read-base* 16)) (read-from-string "a/c")))
+(= 10/13 (let ((*read-base* 16)) (read-from-string "a/d")))
+(= 10/14 (let ((*read-base* 16)) (read-from-string "a/e")))
+(= 10/15 (let ((*read-base* 16)) (read-from-string "a/f")))
+(= 10/16 (let ((*read-base* 16)) (read-from-string "a/10")))
+(= 10/17 (let ((*read-base* 16)) (read-from-string "a/11")))
+(= 10/18 (let ((*read-base* 16)) (read-from-string "a/12")))
+(= 10/19 (let ((*read-base* 16)) (read-from-string "a/13")))
+(= 10/20 (let ((*read-base* 16)) (read-from-string "a/14")))
+(= 10/21 (let ((*read-base* 16)) (read-from-string "a/15")))
+(= 10/22 (let ((*read-base* 16)) (read-from-string "a/16")))
+(= 10/23 (let ((*read-base* 16)) (read-from-string "a/17")))
+(= 10/24 (let ((*read-base* 16)) (read-from-string "a/18")))
+(= 10/25 (let ((*read-base* 16)) (read-from-string "a/19")))
+(= 10/26 (let ((*read-base* 16)) (read-from-string "a/1A")))
+(= 10/27 (let ((*read-base* 16)) (read-from-string "a/1B")))
+(= 10/28 (let ((*read-base* 16)) (read-from-string "a/1C")))
+(= 10/29 (let ((*read-base* 16)) (read-from-string "a/1D")))
+(= 10/30 (let ((*read-base* 16)) (read-from-string "a/1E")))
+(= 10/31 (let ((*read-base* 16)) (read-from-string "a/1F")))
+(= 10/32 (let ((*read-base* 16)) (read-from-string "a/20")))
+(= 10/33 (let ((*read-base* 16)) (read-from-string "a/21")))
+(= 10/34 (let ((*read-base* 16)) (read-from-string "a/22")))
+(= 10/35 (let ((*read-base* 16)) (read-from-string "a/23")))
+(= 10/36 (let ((*read-base* 16)) (read-from-string "a/24")))
+
+
+(= 35/2 (let ((*read-base* 16)) (read-from-string "23/2")))
+(= 35/3 (let ((*read-base* 16)) (read-from-string "23/3")))
+(= 35/4 (let ((*read-base* 16)) (read-from-string "23/4")))
+(= 35/5 (let ((*read-base* 16)) (read-from-string "23/5")))
+(= 35/6 (let ((*read-base* 16)) (read-from-string "23/6")))
+(= 35/7 (let ((*read-base* 16)) (read-from-string "23/7")))
+(= 35/8 (let ((*read-base* 16)) (read-from-string "23/8")))
+(= 35/9 (let ((*read-base* 16)) (read-from-string "23/9")))
+(= 35/10 (let ((*read-base* 16)) (read-from-string "23/A")))
+(= 35/11 (let ((*read-base* 16)) (read-from-string "23/B")))
+(= 35/12 (let ((*read-base* 16)) (read-from-string "23/C")))
+(= 35/13 (let ((*read-base* 16)) (read-from-string "23/D")))
+(= 35/14 (let ((*read-base* 16)) (read-from-string "23/E")))
+(= 35/15 (let ((*read-base* 16)) (read-from-string "23/F")))
+(= 35/10 (let ((*read-base* 16)) (read-from-string "23/a")))
+(= 35/11 (let ((*read-base* 16)) (read-from-string "23/b")))
+(= 35/12 (let ((*read-base* 16)) (read-from-string "23/c")))
+(= 35/13 (let ((*read-base* 16)) (read-from-string "23/d")))
+(= 35/14 (let ((*read-base* 16)) (read-from-string "23/e")))
+(= 35/15 (let ((*read-base* 16)) (read-from-string "23/f")))
+(= 35/16 (let ((*read-base* 16)) (read-from-string "23/10")))
+(= 35/17 (let ((*read-base* 16)) (read-from-string "23/11")))
+(= 35/18 (let ((*read-base* 16)) (read-from-string "23/12")))
+(= 35/19 (let ((*read-base* 16)) (read-from-string "23/13")))
+(= 35/20 (let ((*read-base* 16)) (read-from-string "23/14")))
+(= 35/21 (let ((*read-base* 16)) (read-from-string "23/15")))
+(= 35/22 (let ((*read-base* 16)) (read-from-string "23/16")))
+(= 35/23 (let ((*read-base* 16)) (read-from-string "23/17")))
+(= 35/24 (let ((*read-base* 16)) (read-from-string "23/18")))
+(= 35/25 (let ((*read-base* 16)) (read-from-string "23/19")))
+(= 35/26 (let ((*read-base* 16)) (read-from-string "23/1A")))
+(= 35/27 (let ((*read-base* 16)) (read-from-string "23/1B")))
+(= 35/28 (let ((*read-base* 16)) (read-from-string "23/1C")))
+(= 35/29 (let ((*read-base* 16)) (read-from-string "23/1D")))
+(= 35/30 (let ((*read-base* 16)) (read-from-string "23/1E")))
+(= 35/31 (let ((*read-base* 16)) (read-from-string "23/1F")))
+(= 35/32 (let ((*read-base* 16)) (read-from-string "23/20")))
+(= 35/33 (let ((*read-base* 16)) (read-from-string "23/21")))
+(= 35/34 (let ((*read-base* 16)) (read-from-string "23/22")))
+(= 35/35 (let ((*read-base* 16)) (read-from-string "23/23")))
+(= 35/36 (let ((*read-base* 16)) (read-from-string "23/24")))
+
+(= 110/2 (let ((*read-base* 16)) (read-from-string "6E/2")))
+(= 110/3 (let ((*read-base* 16)) (read-from-string "6E/3")))
+(= 110/4 (let ((*read-base* 16)) (read-from-string "6E/4")))
+(= 110/5 (let ((*read-base* 16)) (read-from-string "6E/5")))
+(= 110/6 (let ((*read-base* 16)) (read-from-string "6E/6")))
+(= 110/7 (let ((*read-base* 16)) (read-from-string "6E/7")))
+(= 110/8 (let ((*read-base* 16)) (read-from-string "6E/8")))
+(= 110/9 (let ((*read-base* 16)) (read-from-string "6E/9")))
+(= 110/10 (let ((*read-base* 16)) (read-from-string "6E/A")))
+(= 110/11 (let ((*read-base* 16)) (read-from-string "6E/B")))
+(= 110/12 (let ((*read-base* 16)) (read-from-string "6E/C")))
+(= 110/13 (let ((*read-base* 16)) (read-from-string "6E/D")))
+(= 110/14 (let ((*read-base* 16)) (read-from-string "6E/E")))
+(= 110/15 (let ((*read-base* 16)) (read-from-string "6E/F")))
+(= 110/10 (let ((*read-base* 16)) (read-from-string "6E/a")))
+(= 110/11 (let ((*read-base* 16)) (read-from-string "6E/b")))
+(= 110/12 (let ((*read-base* 16)) (read-from-string "6E/c")))
+(= 110/13 (let ((*read-base* 16)) (read-from-string "6E/d")))
+(= 110/14 (let ((*read-base* 16)) (read-from-string "6E/e")))
+(= 110/15 (let ((*read-base* 16)) (read-from-string "6E/f")))
+(= 110/16 (let ((*read-base* 16)) (read-from-string "6E/10")))
+(= 110/17 (let ((*read-base* 16)) (read-from-string "6E/11")))
+(= 110/18 (let ((*read-base* 16)) (read-from-string "6E/12")))
+(= 110/19 (let ((*read-base* 16)) (read-from-string "6E/13")))
+(= 110/20 (let ((*read-base* 16)) (read-from-string "6E/14")))
+(= 110/21 (let ((*read-base* 16)) (read-from-string "6E/15")))
+(= 110/22 (let ((*read-base* 16)) (read-from-string "6E/16")))
+(= 110/23 (let ((*read-base* 16)) (read-from-string "6E/17")))
+(= 110/24 (let ((*read-base* 16)) (read-from-string "6E/18")))
+(= 110/25 (let ((*read-base* 16)) (read-from-string "6E/19")))
+(= 110/26 (let ((*read-base* 16)) (read-from-string "6E/1A")))
+(= 110/27 (let ((*read-base* 16)) (read-from-string "6E/1B")))
+(= 110/28 (let ((*read-base* 16)) (read-from-string "6E/1C")))
+(= 110/29 (let ((*read-base* 16)) (read-from-string "6E/1D")))
+(= 110/30 (let ((*read-base* 16)) (read-from-string "6E/1E")))
+(= 110/31 (let ((*read-base* 16)) (read-from-string "6E/1F")))
+(= 110/32 (let ((*read-base* 16)) (read-from-string "6E/20")))
+(= 110/33 (let ((*read-base* 16)) (read-from-string "6E/21")))
+(= 110/34 (let ((*read-base* 16)) (read-from-string "6E/22")))
+(= 110/35 (let ((*read-base* 16)) (read-from-string "6E/23")))
+(= 110/36 (let ((*read-base* 16)) (read-from-string "6E/24")))
+
+(= 11/1111111111111111111111111111111111
+ (read-from-string "11/1111111111111111111111111111111111"))
+
+
+;; float ::= [sign] {decimal-digit}* decimal-point {decimal-digit}+ [exponent]
+;; | [sign] {decimal-digit}+ [decimal-point {decimal-digit}*] exponent
+(let ((f (read-from-string "0.0"))) (and (floatp f) (zerop f)))
+(let ((f (read-from-string "+0.0"))) (and (floatp f) (zerop f)))
+(let ((f (read-from-string "-0.0"))) (and (floatp f) (zerop f)))
+
+(let ((f (read-from-string ".0"))) (and (floatp f) (zerop f)))
+(let ((f (read-from-string "+.0"))) (and (floatp f) (zerop f)))
+(let ((f (read-from-string "-.0"))) (and (floatp f) (zerop f)))
+
+(let ((f (read-from-string "1.0"))) (and (floatp f) (= 1.0 f)))
+(let ((f (read-from-string "+1.0"))) (and (floatp f) (= 1.0 f)))
+(let ((f (read-from-string "-1.0"))) (and (floatp f) (= -1.0 f)))
+
+(let ((f (read-from-string "1d1"))) (and (floatp f) (= 1d1 f)))
+(let ((f (read-from-string "1e1"))) (and (floatp f) (= 1e1 f)))
+(let ((f (read-from-string "1f1"))) (and (floatp f) (= 1f1 f)))
+(let ((f (read-from-string "1l1"))) (and (floatp f) (= 1l1 f)))
+(let ((f (read-from-string "1s1"))) (and (floatp f) (= 1s1 f)))
+(LET ((F (READ-FROM-STRING "1D1"))) (AND (FLOATP F) (= 1D1 F)))
+(LET ((F (READ-FROM-STRING "1E1"))) (AND (FLOATP F) (= 1E1 F)))
+(LET ((F (READ-FROM-STRING "1F1"))) (AND (FLOATP F) (= 1F1 F)))
+(LET ((F (READ-FROM-STRING "1L1"))) (AND (FLOATP F) (= 1L1 F)))
+(LET ((F (READ-FROM-STRING "1S1"))) (AND (FLOATP F) (= 1S1 F)))
+
+(let ((f (read-from-string "1d+1"))) (and (floatp f) (= 1d1 f)))
+(let ((f (read-from-string "1e+1"))) (and (floatp f) (= 1e1 f)))
+(let ((f (read-from-string "1f+1"))) (and (floatp f) (= 1f1 f)))
+(let ((f (read-from-string "1l+1"))) (and (floatp f) (= 1l1 f)))
+(let ((f (read-from-string "1s+1"))) (and (floatp f) (= 1s1 f)))
+(LET ((F (READ-FROM-STRING "1D+1"))) (AND (FLOATP F) (= 1D1 F)))
+(LET ((F (READ-FROM-STRING "1E+1"))) (AND (FLOATP F) (= 1E1 F)))
+(LET ((F (READ-FROM-STRING "1F+1"))) (AND (FLOATP F) (= 1F1 F)))
+(LET ((F (READ-FROM-STRING "1L+1"))) (AND (FLOATP F) (= 1L1 F)))
+(LET ((F (READ-FROM-STRING "1S+1"))) (AND (FLOATP F) (= 1S1 F)))
+
+(let ((f (read-from-string "1d-1"))) (and (floatp f) (= 1d-1 f)))
+(let ((f (read-from-string "1e-1"))) (and (floatp f) (= 1e-1 f)))
+(let ((f (read-from-string "1f-1"))) (and (floatp f) (= 1f-1 f)))
+(let ((f (read-from-string "1l-1"))) (and (floatp f) (= 1l-1 f)))
+(let ((f (read-from-string "1s-1"))) (and (floatp f) (= 1s-1 f)))
+(LET ((F (READ-FROM-STRING "1D-1"))) (AND (FLOATP F) (= 1D-1 F)))
+(LET ((F (READ-FROM-STRING "1E-1"))) (AND (FLOATP F) (= 1E-1 F)))
+(LET ((F (READ-FROM-STRING "1F-1"))) (AND (FLOATP F) (= 1F-1 F)))
+(LET ((F (READ-FROM-STRING "1L-1"))) (AND (FLOATP F) (= 1L-1 F)))
+(LET ((F (READ-FROM-STRING "1S-1"))) (AND (FLOATP F) (= 1S-1 F)))
+
+
+(let ((f (read-from-string "+1d1"))) (and (floatp f) (= 1d1 f)))
+(let ((f (read-from-string "+1e1"))) (and (floatp f) (= 1e1 f)))
+(let ((f (read-from-string "+1f1"))) (and (floatp f) (= 1f1 f)))
+(let ((f (read-from-string "+1l1"))) (and (floatp f) (= 1l1 f)))
+(let ((f (read-from-string "+1s1"))) (and (floatp f) (= 1s1 f)))
+(LET ((F (READ-FROM-STRING "+1D1"))) (AND (FLOATP F) (= 1D1 F)))
+(LET ((F (READ-FROM-STRING "+1E1"))) (AND (FLOATP F) (= 1E1 F)))
+(LET ((F (READ-FROM-STRING "+1F1"))) (AND (FLOATP F) (= 1F1 F)))
+(LET ((F (READ-FROM-STRING "+1L1"))) (AND (FLOATP F) (= 1L1 F)))
+(LET ((F (READ-FROM-STRING "+1S1"))) (AND (FLOATP F) (= 1S1 F)))
+
+(let ((f (read-from-string "+1d+1"))) (and (floatp f) (= 1d1 f)))
+(let ((f (read-from-string "+1e+1"))) (and (floatp f) (= 1e1 f)))
+(let ((f (read-from-string "+1f+1"))) (and (floatp f) (= 1f1 f)))
+(let ((f (read-from-string "+1l+1"))) (and (floatp f) (= 1l1 f)))
+(let ((f (read-from-string "+1s+1"))) (and (floatp f) (= 1s1 f)))
+(LET ((F (READ-FROM-STRING "+1D+1"))) (AND (FLOATP F) (= 1D1 F)))
+(LET ((F (READ-FROM-STRING "+1E+1"))) (AND (FLOATP F) (= 1E1 F)))
+(LET ((F (READ-FROM-STRING "+1F+1"))) (AND (FLOATP F) (= 1F1 F)))
+(LET ((F (READ-FROM-STRING "+1L+1"))) (AND (FLOATP F) (= 1L1 F)))
+(LET ((F (READ-FROM-STRING "+1S+1"))) (AND (FLOATP F) (= 1S1 F)))
+
+(let ((f (read-from-string "+1d-1"))) (and (floatp f) (= 1d-1 f)))
+(let ((f (read-from-string "+1e-1"))) (and (floatp f) (= 1e-1 f)))
+(let ((f (read-from-string "+1f-1"))) (and (floatp f) (= 1f-1 f)))
+(let ((f (read-from-string "+1l-1"))) (and (floatp f) (= 1l-1 f)))
+(let ((f (read-from-string "+1s-1"))) (and (floatp f) (= 1s-1 f)))
+(LET ((F (READ-FROM-STRING "+1D-1"))) (AND (FLOATP F) (= 1D-1 F)))
+(LET ((F (READ-FROM-STRING "+1E-1"))) (AND (FLOATP F) (= 1E-1 F)))
+(LET ((F (READ-FROM-STRING "+1F-1"))) (AND (FLOATP F) (= 1F-1 F)))
+(LET ((F (READ-FROM-STRING "+1L-1"))) (AND (FLOATP F) (= 1L-1 F)))
+(LET ((F (READ-FROM-STRING "+1S-1"))) (AND (FLOATP F) (= 1S-1 F)))
+
+
+(let ((f (read-from-string "-1d1"))) (and (floatp f) (= -1d1 f)))
+(let ((f (read-from-string "-1e1"))) (and (floatp f) (= -1e1 f)))
+(let ((f (read-from-string "-1f1"))) (and (floatp f) (= -1f1 f)))
+(let ((f (read-from-string "-1l1"))) (and (floatp f) (= -1l1 f)))
+(let ((f (read-from-string "-1s1"))) (and (floatp f) (= -1s1 f)))
+(LET ((F (READ-FROM-STRING "-1D1"))) (AND (FLOATP F) (= -1D1 F)))
+(LET ((F (READ-FROM-STRING "-1E1"))) (AND (FLOATP F) (= -1E1 F)))
+(LET ((F (READ-FROM-STRING "-1F1"))) (AND (FLOATP F) (= -1F1 F)))
+(LET ((F (READ-FROM-STRING "-1L1"))) (AND (FLOATP F) (= -1L1 F)))
+(LET ((F (READ-FROM-STRING "-1S1"))) (AND (FLOATP F) (= -1S1 F)))
+
+(let ((f (read-from-string "-1d+1"))) (and (floatp f) (= -1d1 f)))
+(let ((f (read-from-string "-1e+1"))) (and (floatp f) (= -1e1 f)))
+(let ((f (read-from-string "-1f+1"))) (and (floatp f) (= -1f1 f)))
+(let ((f (read-from-string "-1l+1"))) (and (floatp f) (= -1l1 f)))
+(let ((f (read-from-string "-1s+1"))) (and (floatp f) (= -1s1 f)))
+(LET ((F (READ-FROM-STRING "-1D+1"))) (AND (FLOATP F) (= -1D1 F)))
+(LET ((F (READ-FROM-STRING "-1E+1"))) (AND (FLOATP F) (= -1E1 F)))
+(LET ((F (READ-FROM-STRING "-1F+1"))) (AND (FLOATP F) (= -1F1 F)))
+(LET ((F (READ-FROM-STRING "-1L+1"))) (AND (FLOATP F) (= -1L1 F)))
+(LET ((F (READ-FROM-STRING "-1S+1"))) (AND (FLOATP F) (= -1S1 F)))
+
+(let ((f (read-from-string "-1d-1"))) (and (floatp f) (= -1d-1 f)))
+(let ((f (read-from-string "-1e-1"))) (and (floatp f) (= -1e-1 f)))
+(let ((f (read-from-string "-1f-1"))) (and (floatp f) (= -1f-1 f)))
+(let ((f (read-from-string "-1l-1"))) (and (floatp f) (= -1l-1 f)))
+(let ((f (read-from-string "-1s-1"))) (and (floatp f) (= -1s-1 f)))
+(LET ((F (READ-FROM-STRING "-1D-1"))) (AND (FLOATP F) (= -1D-1 F)))
+(LET ((F (READ-FROM-STRING "-1E-1"))) (AND (FLOATP F) (= -1E-1 F)))
+(LET ((F (READ-FROM-STRING "-1F-1"))) (AND (FLOATP F) (= -1F-1 F)))
+(LET ((F (READ-FROM-STRING "-1L-1"))) (AND (FLOATP F) (= -1L-1 F)))
+(LET ((F (READ-FROM-STRING "-1S-1"))) (AND (FLOATP F) (= -1S-1 F)))
+
+
+(let ((f (read-from-string "1d10"))) (and (floatp f) (= 1d10 f)))
+(let ((f (read-from-string "1e10"))) (and (floatp f) (= 1e10 f)))
+(let ((f (read-from-string "1f10"))) (and (floatp f) (= 1f10 f)))
+(let ((f (read-from-string "1l10"))) (and (floatp f) (= 1l10 f)))
+(let ((f (read-from-string "1s10"))) (and (floatp f) (= 1s10 f)))
+(LET ((F (READ-FROM-STRING "1D10"))) (AND (FLOATP F) (= 1D10 F)))
+(LET ((F (READ-FROM-STRING "1E10"))) (AND (FLOATP F) (= 1E10 F)))
+(LET ((F (READ-FROM-STRING "1F10"))) (AND (FLOATP F) (= 1F10 F)))
+(LET ((F (READ-FROM-STRING "1L10"))) (AND (FLOATP F) (= 1L10 F)))
+(LET ((F (READ-FROM-STRING "1S10"))) (AND (FLOATP F) (= 1S10 F)))
+
+(let ((f (read-from-string "1d+10"))) (and (floatp f) (= 1d10 f)))
+(let ((f (read-from-string "1e+10"))) (and (floatp f) (= 1e10 f)))
+(let ((f (read-from-string "1f+10"))) (and (floatp f) (= 1f10 f)))
+(let ((f (read-from-string "1l+10"))) (and (floatp f) (= 1l10 f)))
+(let ((f (read-from-string "1s+10"))) (and (floatp f) (= 1s10 f)))
+(LET ((F (READ-FROM-STRING "1D+10"))) (AND (FLOATP F) (= 1D10 F)))
+(LET ((F (READ-FROM-STRING "1E+10"))) (AND (FLOATP F) (= 1E10 F)))
+(LET ((F (READ-FROM-STRING "1F+10"))) (AND (FLOATP F) (= 1F10 F)))
+(LET ((F (READ-FROM-STRING "1L+10"))) (AND (FLOATP F) (= 1L10 F)))
+(LET ((F (READ-FROM-STRING "1S+10"))) (AND (FLOATP F) (= 1S10 F)))
+
+(let ((f (read-from-string "1d-10"))) (and (floatp f) (= 1d-10 f)))
+(let ((f (read-from-string "1e-10"))) (and (floatp f) (= 1e-10 f)))
+(let ((f (read-from-string "1f-10"))) (and (floatp f) (= 1f-10 f)))
+(let ((f (read-from-string "1l-10"))) (and (floatp f) (= 1l-10 f)))
+(let ((f (read-from-string "1s-10"))) (and (floatp f) (= 1s-10 f)))
+(LET ((F (READ-FROM-STRING "1D-10"))) (AND (FLOATP F) (= 1D-10 F)))
+(LET ((F (READ-FROM-STRING "1E-10"))) (AND (FLOATP F) (= 1E-10 F)))
+(LET ((F (READ-FROM-STRING "1F-10"))) (AND (FLOATP F) (= 1F-10 F)))
+(LET ((F (READ-FROM-STRING "1L-10"))) (AND (FLOATP F) (= 1L-10 F)))
+(LET ((F (READ-FROM-STRING "1S-10"))) (AND (FLOATP F) (= 1S-10 F)))
+
+
+(let ((f (read-from-string "+1d10"))) (and (floatp f) (= 1d10 f)))
+(let ((f (read-from-string "+1e10"))) (and (floatp f) (= 1e10 f)))
+(let ((f (read-from-string "+1f10"))) (and (floatp f) (= 1f10 f)))
+(let ((f (read-from-string "+1l10"))) (and (floatp f) (= 1l10 f)))
+(let ((f (read-from-string "+1s10"))) (and (floatp f) (= 1s10 f)))
+(LET ((F (READ-FROM-STRING "+1D10"))) (AND (FLOATP F) (= 1D10 F)))
+(LET ((F (READ-FROM-STRING "+1E10"))) (AND (FLOATP F) (= 1E10 F)))
+(LET ((F (READ-FROM-STRING "+1F10"))) (AND (FLOATP F) (= 1F10 F)))
+(LET ((F (READ-FROM-STRING "+1L10"))) (AND (FLOATP F) (= 1L10 F)))
+(LET ((F (READ-FROM-STRING "+1S10"))) (AND (FLOATP F) (= 1S10 F)))
+
+(let ((f (read-from-string "+1d+10"))) (and (floatp f) (= 1d10 f)))
+(let ((f (read-from-string "+1e+10"))) (and (floatp f) (= 1e10 f)))
+(let ((f (read-from-string "+1f+10"))) (and (floatp f) (= 1f10 f)))
+(let ((f (read-from-string "+1l+10"))) (and (floatp f) (= 1l10 f)))
+(let ((f (read-from-string "+1s+10"))) (and (floatp f) (= 1s10 f)))
+(LET ((F (READ-FROM-STRING "+1D+10"))) (AND (FLOATP F) (= 1D10 F)))
+(LET ((F (READ-FROM-STRING "+1E+10"))) (AND (FLOATP F) (= 1E10 F)))
+(LET ((F (READ-FROM-STRING "+1F+10"))) (AND (FLOATP F) (= 1F10 F)))
+(LET ((F (READ-FROM-STRING "+1L+10"))) (AND (FLOATP F) (= 1L10 F)))
+(LET ((F (READ-FROM-STRING "+1S+10"))) (AND (FLOATP F) (= 1S10 F)))
+
+(let ((f (read-from-string "+1d-10"))) (and (floatp f) (= 1d-10 f)))
+(let ((f (read-from-string "+1e-10"))) (and (floatp f) (= 1e-10 f)))
+(let ((f (read-from-string "+1f-10"))) (and (floatp f) (= 1f-10 f)))
+(let ((f (read-from-string "+1l-10"))) (and (floatp f) (= 1l-10 f)))
+(let ((f (read-from-string "+1s-10"))) (and (floatp f) (= 1s-10 f)))
+(LET ((F (READ-FROM-STRING "+1D-10"))) (AND (FLOATP F) (= 1D-10 F)))
+(LET ((F (READ-FROM-STRING "+1E-10"))) (AND (FLOATP F) (= 1E-10 F)))
+(LET ((F (READ-FROM-STRING "+1F-10"))) (AND (FLOATP F) (= 1F-10 F)))
+(LET ((F (READ-FROM-STRING "+1L-10"))) (AND (FLOATP F) (= 1L-10 F)))
+(LET ((F (READ-FROM-STRING "+1S-10"))) (AND (FLOATP F) (= 1S-10 F)))
+
+
+(let ((f (read-from-string "-1d10"))) (and (floatp f) (= -1d10 f)))
+(let ((f (read-from-string "-1e10"))) (and (floatp f) (= -1e10 f)))
+(let ((f (read-from-string "-1f10"))) (and (floatp f) (= -1f10 f)))
+(let ((f (read-from-string "-1l10"))) (and (floatp f) (= -1l10 f)))
+(let ((f (read-from-string "-1s10"))) (and (floatp f) (= -1s10 f)))
+(LET ((F (READ-FROM-STRING "-1D10"))) (AND (FLOATP F) (= -1D10 F)))
+(LET ((F (READ-FROM-STRING "-1E10"))) (AND (FLOATP F) (= -1E10 F)))
+(LET ((F (READ-FROM-STRING "-1F10"))) (AND (FLOATP F) (= -1F10 F)))
+(LET ((F (READ-FROM-STRING "-1L10"))) (AND (FLOATP F) (= -1L10 F)))
+(LET ((F (READ-FROM-STRING "-1S10"))) (AND (FLOATP F) (= -1S10 F)))
+
+(let ((f (read-from-string "-1d+10"))) (and (floatp f) (= -1d10 f)))
+(let ((f (read-from-string "-1e+10"))) (and (floatp f) (= -1e10 f)))
+(let ((f (read-from-string "-1f+10"))) (and (floatp f) (= -1f10 f)))
+(let ((f (read-from-string "-1l+10"))) (and (floatp f) (= -1l10 f)))
+(let ((f (read-from-string "-1s+10"))) (and (floatp f) (= -1s10 f)))
+(LET ((F (READ-FROM-STRING "-1D+10"))) (AND (FLOATP F) (= -1D10 F)))
+(LET ((F (READ-FROM-STRING "-1E+10"))) (AND (FLOATP F) (= -1E10 F)))
+(LET ((F (READ-FROM-STRING "-1F+10"))) (AND (FLOATP F) (= -1F10 F)))
+(LET ((F (READ-FROM-STRING "-1L+10"))) (AND (FLOATP F) (= -1L10 F)))
+(LET ((F (READ-FROM-STRING "-1S+10"))) (AND (FLOATP F) (= -1S10 F)))
+
+(let ((f (read-from-string "-1d-10"))) (and (floatp f) (= -1d-10 f)))
+(let ((f (read-from-string "-1e-10"))) (and (floatp f) (= -1e-10 f)))
+(let ((f (read-from-string "-1f-10"))) (and (floatp f) (= -1f-10 f)))
+(let ((f (read-from-string "-1l-10"))) (and (floatp f) (= -1l-10 f)))
+(let ((f (read-from-string "-1s-10"))) (and (floatp f) (= -1s-10 f)))
+(LET ((F (READ-FROM-STRING "-1D-10"))) (AND (FLOATP F) (= -1D-10 F)))
+(LET ((F (READ-FROM-STRING "-1E-10"))) (AND (FLOATP F) (= -1E-10 F)))
+(LET ((F (READ-FROM-STRING "-1F-10"))) (AND (FLOATP F) (= -1F-10 F)))
+(LET ((F (READ-FROM-STRING "-1L-10"))) (AND (FLOATP F) (= -1L-10 F)))
+(LET ((F (READ-FROM-STRING "-1S-10"))) (AND (FLOATP F) (= -1S-10 F)))
+
+(floatp (read-from-string "-1.23"))
+(floatp (read-from-string "-823.0023D10"))
+(floatp (read-from-string "-324.0293E10"))
+(floatp (read-from-string "-12.0023F10"))
+(floatp (read-from-string "-911.823L10"))
+(floatp (read-from-string "-788.823S10"))
+
+(eq '|\256| (read-from-string "\\256"))
+(eq '|25\64| (read-from-string "25\\64"))
+(eq '|1.0\E6| (read-from-string "1.0\\E6"))
+(eq '|100| (read-from-string "|100|"))
+(eq '|3.14159| (read-from-string "3\\.14159"))
+(eq '|3/4| (read-from-string "|3/4|"))
+(eq '|3/4| (read-from-string "3\\/4"))
+(eq '|5| (read-from-string "5||"))
+(eq '|5| (read-from-string "||5"))
+(eq '|567| (read-from-string "||567"))
+(eq '|567| (read-from-string "5||67"))
+(eq '|567| (read-from-string "56||7"))
+(eq '|567| (read-from-string "567||"))
+(eq '|567| (read-from-string "||5||6||7||"))
+(eq '|567| (read-from-string "||||5||||6||||7||||"))
+(eq '|567| (read-from-string "567||||||"))
+
+
+(eq '|/| (read-from-string "/"))
+(eq '|/5| (read-from-string "/5"))
+(eq '|+| (read-from-string "+"))
+(eq '|1+| (read-from-string "1+"))
+(eq '|1-| (read-from-string "1-"))
+(eq '|FOO+| (read-from-string "foo+"))
+(eq '|AB.CD| (read-from-string "ab.cd"))
+(eq '|_| (read-from-string "_"))
+(eq '|^| (read-from-string "^"))
+(eq '|^/-| (read-from-string "^/-"))
+
+(eq :a (read-from-string ":a"))
+(eq :b (read-from-string ":b"))
+(eq :c (read-from-string ":c"))
+(eq :d (read-from-string ":d"))
+(eq :keyword-symbol (read-from-string ":keyword-symbol"))
+(eq 'cl::cdr (read-from-string "cl::cdr"))
+(eq 'cl:append (read-from-string "cl:append"))
+(eq 'cl-user::append (read-from-string "cl-user::append"))
+(progn
+ (when (find-package 'test-foo) (delete-package 'test-foo))
+ (make-package 'test-foo :use nil)
+ (handler-case (read-from-string "test-foo:no-such-symbol")
+ (error () t)
+ (:no-error (&rest rest) (declare (ignore rest)) nil)))
+(progn
+ (when (find-package 'test-foo) (delete-package 'test-foo))
+ (make-package 'test-foo :use nil)
+ (and (not (find-symbol "NEW-ONE" "TEST-FOO"))
+ (read-from-string "test-foo::new-one")
+ (find-symbol "NEW-ONE" "TEST-FOO")))
+(progn
+ (when (find-package 'test-foo) (delete-package 'test-foo))
+ (let ((*package* (make-package 'test-foo :use nil)))
+ (read-from-string "my-symbol")))
+(string= " " (symbol-name (read-from-string "cl-user::\\ ")))
+(progn
+ (when (find-package 'no-such-package) (delete-package 'no-such-package))
+ (handler-case (read-from-string "no-such-package::bar")
+ (error () t)
+ (:no-error (&rest rest) (declare (ignore rest)) nil)))
+(progn
+ (when (find-package 'no-such-package) (delete-package 'no-such-package))
+ (handler-case (read-from-string "no-such-package::no-such-symbol")
+ (error () t)
+ (:no-error (&rest rest) (declare (ignore rest)) nil)))
+
+
+(string= "FROBBOZ" (symbol-name (read-from-string "FROBBOZ")))
+(string= "FROBBOZ" (symbol-name (read-from-string "frobboz")))
+(string= "FROBBOZ" (symbol-name (read-from-string "fRObBoz")))
+(string= "UNWIND-PROTECT" (symbol-name (read-from-string "unwind-protect")))
+(string= "+$" (symbol-name (read-from-string "+$")))
+(string= "1+" (symbol-name (read-from-string "1+")))
+(= 1 (read-from-string "+1"))
+(string= "PASCAL_STYLE" (symbol-name (read-from-string "pascal_style")))
+(string= "FILE.REL.43" (symbol-name (read-from-string "file.rel.43")))
+(string= "\(" (symbol-name (read-from-string "\\(")))
+(string= "\+1" (symbol-name (read-from-string "\\+1")))
+(string= "+\1" (symbol-name (read-from-string "+\\1")))
+(string= "fROBBOZ" (symbol-name (read-from-string "\\frobboz")))
+(string= "3.14159265s0" (symbol-name (read-from-string "3.14159265\\s0")))
+(string= "3.14159265S0" (symbol-name (read-from-string "3.14159265\\S0")))
+(string= "FOo" (symbol-name (read-from-string "fo\\o")))
+
+(string= "APL\\360" (symbol-name (read-from-string "APL\\\\360")))
+(string= "APL\\360" (symbol-name (read-from-string "apl\\\\360")))
+(string= "(B^2)-4*A*C" (symbol-name (read-from-string "\\(b^2\\)\\-\\4*a*c")))
+(string= "(b^2)-4*a*c"
+ (symbol-name (read-from-string "\\(\\b^2\\)\\-\\4*\\a*\\c")))
+(string= "\"" (symbol-name (read-from-string "|\"|")))
+(string= "(b^2) - 4*a*c" (symbol-name (read-from-string "|(b^2) - 4*a*c|")))
+(string= "frobboz" (symbol-name (read-from-string "|frobboz|")))
+(string= "APL360" (symbol-name (read-from-string "|APL\\360|")))
+(string= "APL\\360" (symbol-name (read-from-string "|APL\\\\360|")))
+(string= "apl\\360" (symbol-name (read-from-string "|apl\\\\360|")))
+(string= "||" (symbol-name (read-from-string "|\\|\\||")))
+(string= "(B^2) - 4*A*C" (symbol-name (read-from-string "|(B^2) - 4*A*C|")))
+(string= "(b^2) - 4*a*c" (symbol-name (read-from-string "|(b^2) - 4*a*c|")))
+(string= "." (symbol-name (read-from-string "\\.")))
+(string= ".." (symbol-name (read-from-string "|..|")))
+
+
+(null (read-from-string "()"))
+(null (read-from-string "( )"))
+(null (read-from-string "( )"))
+(equal (read-from-string "(a)") '(a))
+(equal (read-from-string "( a)") '(a))
+(equal (read-from-string "(a )") '(a))
+(equal (read-from-string "( a )") '(a))
+(equal (read-from-string "(a b)") '(a b))
+(equal (read-from-string "( a b)") '(a b))
+(equal (read-from-string "( a b )") '(a b))
+(equal (read-from-string "( a b )") '(a b))
+(equal (read-from-string "( a b )") '(a b))
+(equal (read-from-string "(a #| |# b)") '(a b))
+(equal (read-from-string "(a #| |# b #| |# )") '(a b))
+(equal (read-from-string "(a #| |# b
+)") '(a b))
+(equal (read-from-string "(
+a
+b
+)") '(a b))
+(equal (read-from-string "(a . b)") '(a . b))
+(equal (read-from-string "(a . nil)") '(a))
+(equal (read-from-string "(a . (b))") '(a b))
+(equal (read-from-string "(a . (b . (c . (d))))") '(a b c d))
+(let ((x (read-from-string "(a .$b)")))
+ (and (= 2 (length x))
+ (eq (first x) 'a)
+ (eq (second x) '|.$B|)))
+(equal (read-from-string "(a b c . d)")
+ (cons 'a (cons 'b (cons 'c 'd))))
+(equal (read-from-string "(this-one . that-one)")
+ (cons 'this-one 'that-one))
+(equal (read-from-string "(a b c d . (e f . (g)))") '(a b c d e f g))
+(equal (read-from-string "(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30)")
+ '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30))
+(handler-case (read-from-string ")")
+ (error () t)
+ (:no-error (&rest rest) (declare (ignore rest)) nil))
+
+(equal (read-from-string "(a (b (c d)))") '(a (b (c d))))
+(equal (read-from-string "'a") '(quote a))
+(equal (read-from-string "'(a b c)") '(quote (a b c)))
+(equal (read-from-string "'''(a b c)") '(quote (quote (quote (a b c)))))
+(equal (read-from-string "'(a 'b '('c))")
+ '(quote (a (quote b) (quote ((quote c))))))
+(equal (read-from-string "'('('a '('b 'c)))")
+ '(quote ((quote ((quote a) (quote ((quote b) (quote c))))))))
+(equal (read-from-string "''''''a")
+ '(quote (quote (quote (quote (quote (quote a)))))))
+(equal (read-from-string "' a") '(quote a))
+(eq 'quote (eval (read-from-string "(car ''foo)")))
+
+
+
+(eq (read-from-string "; comment
+a") 'a)
+(= 7 (eval (read-from-string "(+ 3 ; three
+4)")))
+(eq 'a (read-from-string ";;;;;;;
+a"))
+(equal (read-from-string "(a ;;;;;;;
+b ;;
+;;
+c;;;;;;;;;;;;;;;;;;;;;;;;;;;
+d)") '(a b c d))
+(equal (read-from-string "(a ; comment
+ ;
+ ;
+;
+b)") '(a b))
+(equal (read-from-string "(a\\;b c)") '(|A;B| c))
+
+(string= (read-from-string "\"hello\"") "hello")
+(string= (read-from-string "\"\\\"hello\\\"\"") "\"hello\"")
+(string= (read-from-string "\"|hello|\"") "|hello|")
+(string= "string" (read-from-string " \"string\""))
+(let ((x (read-from-string "\"\\\\\"")))
+ (and (= 1 (length x)) (char= #\\ (char x 0))))
+(string= " This is a sentence. " (read-from-string "\" This is a sentence. \""))
+(simple-string-p (read-from-string "\"a simple string\""))
+(let ((x (read-from-string "\"\\\"\"")))
+ (and (= 1 (length x)) (char= #\" (char x 0))))
+(let ((x (read-from-string "\"|\"")))
+ (and (= 1 (length x)) (char= #\| (char x 0))))
+
+
+(eq (eval (read-from-string "`a")) 'a)
+(equal (eval (read-from-string "(let ((x 1)) `(a ,x))")) '(a 1))
+(equal (eval (read-from-string "(let ((x 1)) `(a ,`(,x)))")) '(a (1)))
+(equal (eval (read-from-string "(let ((a 0) (c 2) (d '(3))) `((,a b) ,c ,@d))"))
+ '((0 b) 2 3))
+(equal
+ (eval (read-from-string "(let ((a 0) (c 2) (d '(3 4 5))) `((,a b) ,c ,@d))"))
+ '((0 b) 2 3 4 5))
+(equal
+ (eval (read-from-string "(let ((a '(0 1)) (c 2) (d '(3 4 5)))
+ `((,a b) ,c ,@d))"))
+ '(((0 1) b) 2 3 4 5))
+(equal
+ (eval (read-from-string "(let ((a '(0 1)) (c 2) (d '(3 4 5)))
+ `((,@a b) ,c ,@d))"))
+ '((0 1 b) 2 3 4 5))
+(equal (eval (read-from-string "`(a b ,`c)")) '(a b c))
+(equal (eval (read-from-string "`(a ,@(map 'list #'char-upcase \"bcd\") e f)"))
+ '(a #\B #\C #\D E F))
+(equal (eval (read-from-string "(let ((x 1)) `(a . ,x))")) '(a . 1))
+(equal (eval (read-from-string "(let ((x '(b c))) `(a . ,x))")) '(a b c))
+(equalp (eval (read-from-string "(let ((x #(b c))) `(a . ,x))")) '(a . #(b c)))
+(equalp (eval (read-from-string "(let ((x '(b c))) `#(a ,x))")) #(a (b c)))
+(equalp (eval (read-from-string "(let ((x 'b ) (y 'c)) `#(a ,x ,y))"))
+ #(a b c))
+(equalp (eval (read-from-string "(let ((x '(b c))) `#(a ,@x))")) #(a b c))
+(equalp (eval (read-from-string "`\"abc\"")) "abc")
+(equalp (eval (read-from-string "(let ((x '(b c)) (y '(d e)) (z '(f g))) `(a ,@x ,@y ,@z))")) '(a b c d e f g))
+(equalp (eval (read-from-string "(let ((x '(b c)) (y 'd) (z '(e f g h))) `(a ,@x ,y ,@z))")) '(a b c d e f g h))
+(equal (eval (read-from-string "`(a ,@(mapcar #'char-downcase `(,(char-upcase #\\b) ,(char-upcase #\\c) ,(char-upcase #\\d))) e f)"))
+ '(a #\b #\c #\d e f))
+(equal (eval (read-from-string "`(a ,@(map 'list #'char-downcase `#(,(char-upcase #\\b) ,(char-upcase #\\c) ,(char-upcase #\\d))) e f)"))
+ '(a #\b #\c #\d e f))
+(equal (eval (read-from-string "(let ((x 1)) `(a (,x)))")) '(a (1)))
+(equal (eval (read-from-string "(let ((x 1)) `(a ((,x))))")) '(a ((1))))
+(equal (eval (read-from-string "(let ((x 1)) `(a (((,x)))))")) '(a (((1)))))
+(equalp (eval (read-from-string "(let ((x 1)) `(a ((#(,x)))))")) '(a ((#(1)))))
+(equalp (eval (read-from-string "(let ((x 1)) `(a #((#(,x)))))")) '(a #((#(1)))))
+(equalp (eval (read-from-string "(let ((x 1)) `#(a #((#(,x)))))"))
+ '#(a #((#(1)))))
+(equal (eval (read-from-string "(let ((x 1) (y 2) (z 3)) `(,x (,y) ((,z))))"))
+ '(1 (2) ((3))))
+(equal (eval (read-from-string
+ "(let ((x 1) (y 2) (z 3)) `((,x) ((,y)) (((,z)))))"))
+ '((1) ((2)) (((3)))))
+(equal (eval (read-from-string
+ "(let ((x 1) (y 2) (z 3)) `(((,x)) (((,y))) ((((,z))))))"))
+ '(((1)) (((2))) ((((3))))))
+(equal (eval (read-from-string
+ "(let ((x 1) (y 2) (z 3)) `((((,x))) ((((,y)))) (((((,z)))))))"))
+ '((((1))) ((((2)))) (((((3)))))))
+(equalp (eval (read-from-string "(let ((x 1) (y 2) (z 3)) `#(,x (,y) ((,z))))"))
+ '#(1 (2) ((3))))
+(equalp (eval (read-from-string
+ "(let ((x 1) (y 2) (z 3)) `#((,x) ((,y)) (((,z)))))"))
+ '#((1) ((2)) (((3)))))
+(equalp (eval (read-from-string
+ "(let ((x 1) (y 2) (z 3)) `#(((,x)) (((,y))) ((((,z))))))"))
+ '#(((1)) (((2))) ((((3))))))
+(equalp (eval (read-from-string
+ "(let ((x 1) (y 2) (z 3)) `#((((,x))) ((((,y)))) (((((,z)))))))"))
+ '#((((1))) ((((2)))) (((((3)))))))
+(equal (eval (read-from-string "(let ((x 1)) `'(,x))")) ''(1))
+(equal (eval (read-from-string "(let ((x 1)) `'(',x))")) ''('1))
+(equal (eval (read-from-string "`'(','x))")) ''('x))
+(equal (eval (read-from-string "`(a . b)")) '(a . b))
+(equal (eval (read-from-string "(let ((x 1)) `(a . ,x))")) '(a . 1))
+(equal (eval (read-from-string "(let ((x 1)) `(a . (b . (,x))))")) '(a b 1))
+(equal (eval (read-from-string "(let ((x 1)) `(a ,x . z))")) '(a 1 . z))
+(equalp (eval (read-from-string "(let ((x 1)) `(a #(#(#(,x))) . z))"))
+ '(a #(#(#(1))) . z))
+
+(handler-case (read-from-string ",")
+ (error () t)
+ (:no-error (&rest rest) (declare (ignore rest)) nil))
+
+(handler-case (read-from-string "'(,x)")
+ (error () t)
+ (:no-error (&rest rest) (declare (ignore rest)) nil))
+
+(handler-case (read-from-string "`(,(append ,x y))")
+ (error () t)
+ (:no-error (&rest rest) (declare (ignore rest)) nil))
+
+(char= (read-from-string "#\\a") #\a)
+(char= (read-from-string "#\\b") #\b)
+(char= (read-from-string "#\\c") #\c)
+(char= (read-from-string "#\\d") #\d)
+(char= (read-from-string "#\\e") #\e)
+(char= (read-from-string "#\\f") #\f)
+(char= (read-from-string "#\\g") #\g)
+(char= (read-from-string "#\\h") #\h)
+(char= (read-from-string "#\\i") #\i)
+(char= (read-from-string "#\\j") #\j)
+(char= (read-from-string "#\\k") #\k)
+(char= (read-from-string "#\\l") #\l)
+(char= (read-from-string "#\\m") #\m)
+(char= (read-from-string "#\\n") #\n)
+(char= (read-from-string "#\\o") #\o)
+(char= (read-from-string "#\\p") #\p)
+(char= (read-from-string "#\\q") #\q)
+(char= (read-from-string "#\\r") #\r)
+(char= (read-from-string "#\\s") #\s)
+(char= (read-from-string "#\\t") #\t)
+(char= (read-from-string "#\\u") #\u)
+(char= (read-from-string "#\\v") #\v)
+(char= (read-from-string "#\\w") #\w)
+(char= (read-from-string "#\\x") #\x)
+(char= (read-from-string "#\\y") #\y)
+(char= (read-from-string "#\\z") #\z)
+(CHAR= (READ-FROM-STRING "#\\A") #\A)
+(CHAR= (READ-FROM-STRING "#\\B") #\B)
+(CHAR= (READ-FROM-STRING "#\\C") #\C)
+(CHAR= (READ-FROM-STRING "#\\D") #\D)
+(CHAR= (READ-FROM-STRING "#\\E") #\E)
+(CHAR= (READ-FROM-STRING "#\\F") #\F)
+(CHAR= (READ-FROM-STRING "#\\G") #\G)
+(CHAR= (READ-FROM-STRING "#\\H") #\H)
+(CHAR= (READ-FROM-STRING "#\\I") #\I)
+(CHAR= (READ-FROM-STRING "#\\J") #\J)
+(CHAR= (READ-FROM-STRING "#\\K") #\K)
+(CHAR= (READ-FROM-STRING "#\\L") #\L)
+(CHAR= (READ-FROM-STRING "#\\M") #\M)
+(CHAR= (READ-FROM-STRING "#\\N") #\N)
+(CHAR= (READ-FROM-STRING "#\\O") #\O)
+(CHAR= (READ-FROM-STRING "#\\P") #\P)
+(CHAR= (READ-FROM-STRING "#\\Q") #\Q)
+(CHAR= (READ-FROM-STRING "#\\R") #\R)
+(CHAR= (READ-FROM-STRING "#\\S") #\S)
+(CHAR= (READ-FROM-STRING "#\\T") #\T)
+(CHAR= (READ-FROM-STRING "#\\U") #\U)
+(CHAR= (READ-FROM-STRING "#\\V") #\V)
+(CHAR= (READ-FROM-STRING "#\\W") #\W)
+(CHAR= (READ-FROM-STRING "#\\X") #\X)
+(CHAR= (READ-FROM-STRING "#\\Y") #\Y)
+(CHAR= (READ-FROM-STRING "#\\Z") #\Z)
+(not (char= (read-from-string "#\\Z") (read-from-string "#\\z")))
+
+(char= (read-from-string "#\\0") #\0)
+(char= (read-from-string "#\\1") #\1)
+(char= (read-from-string "#\\2") #\2)
+(char= (read-from-string "#\\3") #\3)
+(char= (read-from-string "#\\4") #\4)
+(char= (read-from-string "#\\5") #\5)
+(char= (read-from-string "#\\6") #\6)
+(char= (read-from-string "#\\7") #\7)
+(char= (read-from-string "#\\8") #\8)
+(char= (read-from-string "#\\9") #\9)
+
+(char= (read-from-string "#\\!") #\!)
+(char= (read-from-string "#\\$") #\$)
+(char= (read-from-string "#\\\"") #\")
+(char= (read-from-string "#\\'") #\')
+(char= (read-from-string "#\\(") #\()
+(char= (read-from-string "#\\)") #\))
+(char= (read-from-string "#\\,") #\,)
+(char= (read-from-string "#\\_") #\_)
+(char= (read-from-string "#\\-") #\-)
+(char= (read-from-string "#\\.") #\.)
+(char= (read-from-string "#\\/") #\/)
+(char= (read-from-string "#\\:") #\:)
+(char= (read-from-string "#\\;") #\;)
+(char= (read-from-string "#\\?") #\?)
+(char= (read-from-string "#\\+") #\+)
+(char= (read-from-string "#\\<") #\<)
+(char= (read-from-string "#\\=") #\=)
+(char= (read-from-string "#\\>") #\>)
+(char= (read-from-string "#\\#") #\#)
+(char= (read-from-string "#\\%") #\%)
+(char= (read-from-string "#\\&") #\&)
+(char= (read-from-string "#\\*") #\*)
+(char= (read-from-string "#\\@") #\@)
+(char= (read-from-string "#\\[") #\[)
+(char= (read-from-string "#\\\\") #\\)
+(char= (read-from-string "#\\]") #\])
+(char= (read-from-string "#\\{") #\{)
+(char= (read-from-string "#\\|") #\|)
+(char= (read-from-string "#\\}") #\})
+(char= (read-from-string "#\\`") #\`)
+(char= (read-from-string "#\\^") #\^)
+(char= (read-from-string "#\\~") #\~)
+
+(char= (read-from-string "#\\newline") #\newline)
+(char= (read-from-string "#\\space") #\space)
+(char= (read-from-string "#\\Newline") #\newline)
+(char= (read-from-string "#\\Space") #\space)
+(char= (read-from-string "#\\NeWlInE") #\newline)
+(char= (read-from-string "#\\SpAcE") #\space)
+(char= (read-from-string "#\\NEWLINE") #\newline)
+(char= (read-from-string "#\\SPACE") #\space)
+
+
+(equal (read-from-string "#'car") '(function car))
+(eq (eval (read-from-string "#'car")) #'car)
+
+(simple-vector-p (read-from-string "#(a)"))
+(equalp (read-from-string "#(a)") #(a))
+(equalp (read-from-string "#()") #())
+(equalp (read-from-string "#(a b)") #(a b))
+(equalp (read-from-string "#(a b c)") #(a b c))
+(equalp (read-from-string "#(a b c d)") #(a b c d))
+(equalp (read-from-string "#(a b c d e)") #(a b c d e))
+(equalp (read-from-string "#(a b c d e f)") #(a b c d e f))
+(equalp (read-from-string "#(a b c d e f g)") #(a b c d e f g))
+(equalp (read-from-string "#(a b c c c c)") #(a b c c c c))
+(equalp (read-from-string "#6(a b c c c c)") #(a b c c c c))
+(equalp (read-from-string "#6(a b c)") #(a b c c c c))
+(equalp (read-from-string "#6(a b c c)") #(a b c c c c))
+(let ((x (read-from-string "#(a b c)"))) (= 3 (length x)))
+(let ((x (read-from-string "#()")))
+ (and (simple-vector-p x)
+ (zerop (length x))
+ (equalp x #0())))
+(let ((x (read-from-string "#0()")))
+ (and (simple-vector-p x)
+ (zerop (length x))
+ (equalp x #())))
+(equalp (read-from-string "#1(a)") #(a))
+(equalp (read-from-string "#2(a b)") #(a b))
+(equalp (read-from-string "#3(a b c)") #(a b c))
+(equalp (read-from-string "#4(a b c d)") #(a b c d))
+(equalp (read-from-string "#5(a b c d e)") #(a b c d e))
+(equalp (read-from-string "#6(a b c d e f)") #(a b c d e f))
+(equalp (read-from-string "#2(a)") #(a a))
+(equalp (read-from-string "#3(a)") #(a a a))
+(equalp (read-from-string "#4(a)") #(a a a a))
+(equalp (read-from-string "#5(a)") #(a a a a a))
+(equalp (read-from-string "#6(a)") #(a a a a a a))
+(equalp (read-from-string "#7(a)") #(a a a a a a a))
+(equalp (read-from-string "#8(a)") #(a a a a a a a a))
+(equalp (read-from-string "#9(a)") #(a a a a a a a a a))
+(equalp (read-from-string "#10(a)") #(a a a a a a a a a a))
+(let ((x (read-from-string "#100(a)")))
+ (and (simple-vector-p x)
+ (= 100 (length x))
+ (every #'symbolp x)
+ (every #'(lambda (s) (eq s 'a)) x)))
+(let ((x (read-from-string "#100(#\\z)")))
+ (and (simple-vector-p x)
+ (= 100 (length x))
+ (every #'characterp x)
+ (every #'(lambda (c) (char= c #\z)) x)))
+(let ((x (read-from-string "#100(#())")))
+ (and (simple-vector-p x)
+ (= 100 (length x))
+ (every #'simple-vector-p x)
+ (every #'(lambda (v) (zerop (length v))) x)))
+
+
+(equalp (read-from-string "#*0") #*0)
+(equalp (read-from-string "#*1") #*1)
+(equalp (read-from-string "#*01") #*01)
+(equalp (read-from-string "#*10") #*10)
+(equalp (read-from-string "#*11") #*11)
+(equalp (read-from-string "#0*") #*)
+(equalp (read-from-string "#*") #*)
+(equalp (read-from-string "#3*1") #*111)
+(equalp (read-from-string "#3*10") #*100)
+(equalp (read-from-string "#*101111") #*101111)
+(equalp (read-from-string "#6*101111") #*101111)
+(equalp (read-from-string "#6*101") #*101111)
+(equalp (read-from-string "#6*1011") #*101111)
+(let ((x (read-from-string "#*10")))
+ (and (simple-bit-vector-p x)
+ (= 2 (length x))
+ (= 1 (bit x 0))
+ (= 0 (bit x 1))))
+(let ((x (read-from-string "#*")))
+ (and (simple-bit-vector-p x)
+ (zerop (length x))))
+(let ((x (read-from-string "#100*0")))
+ (and (simple-bit-vector-p x)
+ (= 100 (length x))
+ (every #'zerop x)))
+(let ((x (read-from-string "#100*1")))
+ (and (simple-bit-vector-p x)
+ (= 100 (length x))
+ (every #'(lambda (n) (= 1 n)) x)))
+(handler-case (read-from-string "#3*1110")
+ (reader-error () t)
+ (error () nil)
+ (:no-error (&rest rest) (declare (ignore rest)) nil))
+(handler-case (read-from-string "#3*")
+ (reader-error () t)
+ (error () nil)
+ (:no-error (&rest rest) (declare (ignore rest)) nil))
+(handler-case (read-from-string "#3*abc")
+ (reader-error () t)
+ (error () nil)
+ (:no-error (&rest rest) (declare (ignore rest)) nil))
+
+(let ((symbol (read-from-string "#:ok")))
+ (and (null (symbol-package symbol)) (string= (symbol-name symbol) "OK")))
+(let ((symbol (read-from-string "#:g10")))
+ (and (null (symbol-package symbol)) (string= (symbol-name symbol) "G10")))
+(let ((symbol (read-from-string "#:10")))
+ (and (null (symbol-package symbol)) (string= (symbol-name symbol) "10")))
+(let ((symbol (read-from-string "#:0")))
+ (and (null (symbol-package symbol)) (string= (symbol-name symbol) "0")))
+(let ((symbol (read-from-string "#:-")))
+ (and (null (symbol-package symbol)) (string= (symbol-name symbol) "-")))
+(let ((symbol (read-from-string "#:\\-")))
+ (and (null (symbol-package symbol)) (string= (symbol-name symbol) "-")))
+(let ((symbol (read-from-string "#:$$-$$")))
+ (and (null (symbol-package symbol)) (string= (symbol-name symbol) "$$-$$")))
+
+(eq 'a (read-from-string "#.'a"))
+(packagep (read-from-string "#.*package*"))
+(= 11 (read-from-string "#.(let ((x 10)) (1+ x))"))
+(= 4 (read-from-string "#.(1+ 3)"))
+(handler-case (let ((*read-eval* nil)) (read-from-string "#.(1+ 3)"))
+ (reader-error () t)
+ (error () nil)
+ (:no-error (&rest rest) (declare (ignore rest)) nil))
+(equal '(a b . 3) (read-from-string "#.(let ((x 3)) `(a b . ,x))"))
+
+
+(= (read-from-string "#b0") 0)
+(= (read-from-string "#B0") 0)
+(= (read-from-string "#b01") 1)
+(= (read-from-string "#B01") 1)
+(= (read-from-string "#B1101") 13)
+(= (read-from-string "#b101/11") 5/3)
+(= 172236929 (read-from-string "#b1010010001000010000010000001"))
+
+(= (read-from-string "#o0") 0)
+(= (read-from-string "#O0") 0)
+(= (read-from-string "#o37/15") 31/13)
+(= (read-from-string "#o777") 511)
+(= (read-from-string "#o105") 69)
+(= (read-from-string "#O37/15") 31/13)
+(= (read-from-string "#O777") 511)
+(= (read-from-string "#O105") 69)
+(= 342391 (read-from-string "#o1234567"))
+
+(= (read-from-string "#x0") 0)
+(= (read-from-string "#xF00") 3840)
+(= (read-from-string "#x105") 261)
+(= (read-from-string "#X0") 0)
+(= (read-from-string "#XF00") 3840)
+(= (read-from-string "#Xf00") 3840)
+(= (read-from-string "#X105") 261)
+(= 81985529216486895 (read-from-string "#X0123456789ABCDEF"))
+
+(= (read-from-string "#3r0") 0)
+(= (read-from-string "#2r11010101") 213)
+(= (read-from-string "#b11010101") 213)
+(= (read-from-string "#b+11010101") 213)
+(= (read-from-string "#o325") 213)
+(= (read-from-string "#xD5") 213)
+(= (read-from-string "#16r+D5") 213)
+(= (read-from-string "#o-300") -192)
+(= (read-from-string "#3r-21010") -192)
+(= (read-from-string "#25R-7H") -192)
+(= (read-from-string "#xACCEDED") 181202413)
+
+
+
+
+
+(zerop (read-from-string "#c(0 0)"))
+(= (read-from-string "#c(1 0)") #c(1 0))
+(complexp (read-from-string "#c(1 10)"))
+(= (read-from-string "#c(1 0)") 1)
+(= (read-from-string "#c(0 1)") #c(0 1))
+(= (read-from-string "#c(1 1)") #c(1 1))
+(= (read-from-string "#C(3.0s1 2.0s-1)") #C(3.0s1 2.0s-1))
+(= (read-from-string "#C(5 -3)") #c(5 -3))
+(= (read-from-string "#C(5/3 7.0)") #c(5/3 7.0))
+(let ((x (read-from-string "#C(5/3 7.0)")))
+ (and (floatp (realpart x)) (floatp (imagpart x))))
+
+(= (read-from-string "#C(0 1)") #C(0 1))
+
+;; array
+(equalp (read-from-string "#1A(0 1)") #(0 1))
+(let ((x (read-from-string "#1A(0 1)")))
+ (and (vectorp x)
+ (= 2 (length x))
+ (= 0 (aref x 0))
+ (= 1 (aref x 1))))
+(equalp (read-from-string "#2A((0 1 5) (foo 2 (hot dog)))")
+ #2A((0 1 5) (foo 2 (hot dog))))
+(let ((x (read-from-string "#2A((0 1 5) (foo 2 (hot dog)))")))
+ (and (arrayp x)
+ (equal (array-dimensions x) '(2 3))
+ (zerop (aref x 0 0))
+ (= (aref x 0 1) 1)
+ (= (aref x 0 2) 5)
+ (eq (aref x 1 0) 'foo)
+ (= (aref x 1 1) 2)
+ (equal (aref x 1 2) '(hot dog))))
+(equal (aref (read-from-string "#0A((0 1 5) (foo 2 (hot dog)))"))
+ '((0 1 5) (foo 2 (hot dog))))
+(let ((x (read-from-string "#0A((0 1 5) (foo 2 (hot dog)))")))
+ (and (arrayp x)
+ (null (array-dimensions x))
+ (equal (aref x) '((0 1 5) (foo 2 (hot dog))))))
+(equalp (read-from-string "#0A foo") #0Afoo)
+(let ((x (read-from-string "#0A foo")))
+ (and (arrayp x)
+ (null (array-dimensions x))
+ (eq (aref x) 'foo)))
+
+(equal (array-dimensions (read-from-string "#3A((() ()) (() ()) (() ()))"))
+ '(3 2 0))
+(equal (array-dimensions (read-from-string "#10A(() ())"))
+ '(2 0 0 0 0 0 0 0 0 0))
+(let ((x (read-from-string "
+#4A((((0 1 2 3) (4 5 6 7) (8 9 10 11))
+ ((12 13 14 15) (16 17 18 19) (20 21 22 23))))")))
+ (and (arrayp x)
+ (equal (array-dimensions x) '(1 2 3 4))
+ (loop for i below 24 always (= i (row-major-aref x i)))))
+
+;; label
+(eq (read-from-string "#1=a") 'a)
+(equal (read-from-string "(#1=a #1#)") '(a a))
+(let ((x (read-from-string "#1=(a . #1#)"))) (eq x (cdr x)))
+(let ((x (read-from-string "((a b) . #1=(#2=(p q) foo #2# . #1#))")))
+ (and (eq (nthcdr 1 x) (nthcdr 4 x))
+ (eq (nthcdr 4 x) (nthcdr 7 x))
+ (eq (nthcdr 7 x) (nthcdr 10 x))
+ (eq (nth 1 x) (nth 3 x))
+ (eq (nth 3 x) (nth 6 x))
+ (eq (nth 6 x) (nth 9 x))
+ (eq (nth 9 x) (nth 12 x))))
+(let ((x (read-from-string "(#1=(a . #1#) #2=(#1# . #2#))")))
+ (and (eq (car x) (caadr x))
+ (eq (car x) (cdar x))
+ (eq (cadr x) (cdadr x))))
+(let ((x (read-from-string "#1=#2=#3=(0 . #1#)")))
+ (and (eq x (cdr x)) (zerop (car x))))
+(let ((x (read-from-string "#1=#2=#3=(0 . #2#)")))
+ (and (eq x (cdr x)) (zerop (car x))))
+(let ((x (read-from-string "#1=#2=#3=(0 . #3#)")))
+ (and (eq x (cdr x)) (zerop (car x))))
+(let ((x (read-from-string "#1=#2=#3=(0 #1# #2# #3#)")))
+ (and (= 4 (length x))
+ (zerop (first x))
+ (eq x (second x))
+ (eq x (third x))
+ (eq x (fourth x))))
+(equal (read-from-string "(#1000=a #1000#)") '(a a))
+(let ((x (read-from-string "(#1=#:g10 #1#)")))
+ (and (= 2 (length x))
+ (string= (symbol-name (first x)) "G10")
+ (eq (first x) (second x))))
+(let ((x (read-from-string "#1=(a (b #2=(x y z) . #1#) . #2#)")))
+ (and (eq (first x) 'a)
+ (eq x (cddr (second x)))
+ (eq (second (second x)) (cddr x))))
+(let ((x (read-from-string "(#1=(a (b #2=(x y z) . #1#) . #2#))")))
+ (and (eq (caar x) 'a)
+ (eq (car x) (cddr (second (first x))))
+ (eq (second (second (first x))) (cddr (first x)))))
+(let ((x (read-from-string "#1=(a #2=(b #3=(c . #3#) . #2#) . #1#)")))
+ (and (eq (first x) 'a)
+ (eq (first (second x)) 'b)
+ (eq (first (second (second x))) 'c)
+ (eq x (cddr x))
+ (eq (second x) (cddr (second x)))
+ (eq (second (second x)) (cdr (second (second x))))))
+(let ((x (read-from-string "#1=(a #2=(b #3=(c . #1#) . #2#) . #3#)")))
+ (and (eq (first x) 'a)
+ (eq (first (second x)) 'b)
+ (eq (first (second (second x))) 'c)
+ (eq x (cdr (second (second x))))
+ (eq (second x) (cddr (second x)))
+ (eq (second (second x)) (cddr x))))
+(let ((x (read-from-string "(#1=#(0 1 2) #1#)")))
+ (and (= 2 (length x))
+ (eq (first x) (second x))
+ (equalp (first x) #(0 1 2))))
+
+(let ((x (read-from-string "#1=#(#1# 1 2)")))
+ (and (= 3 (length x))
+ (eq (aref x 0) x)
+ (= (aref x 1) 1)
+ (= (aref x 2) 2)))
+(let ((x (read-from-string "#(#1=#:g00 a b #1#)")))
+ (and (= 4 (length x))
+ (string= (symbol-name (aref x 0)) "G00")
+ (eq (aref x 0) (aref x 3))
+ (eq (aref x 1) 'a)
+ (eq (aref x 2) 'b)))
+(let ((x (read-from-string "#1=#(#2=#:g00 a #2# #1#)")))
+ (and (= 4 (length x))
+ (string= (symbol-name (aref x 0)) "G00")
+ (eq x (aref x 3))
+ (eq (aref x 0) (aref x 2))
+ (eq (aref x 1) 'a)))
+(let ((x (read-from-string "#1=#(#1# #1# #1#)")))
+ (and (= 3 (length x))
+ (eq x (aref x 0))
+ (eq (aref x 0) (aref x 1))
+ (eq (aref x 1) (aref x 2))))
+(let ((x (read-from-string "#1=#(#(#1#))")))
+ (and (= 1 (length x))
+ (= 1 (length (aref x 0)))
+ (eq x (aref (aref x 0) 0))))
+(let ((x (read-from-string "#1=#(#2=#(#3=#(#3# #2# #1#))))")))
+ (and (= 1 (length x))
+ (= 1 (length (aref x 0)))
+ (= 3 (length (aref (aref x 0) 0)))
+ (eq x (aref (aref (aref x 0) 0) 2))
+ (eq (aref x 0) (aref (aref (aref x 0) 0) 1))
+ (eq (aref (aref x 0) 0) (aref (aref (aref x 0) 0) 0))))
+(let ((x (read-from-string "#1=#(#2=#(#3=#(#1# #2# #3#))))")))
+ (and (= 1 (length x))
+ (= 1 (length (aref x 0)))
+ (= 3 (length (aref (aref x 0) 0)))
+ (eq x (aref (aref (aref x 0) 0) 0))
+ (eq (aref x 0) (aref (aref (aref x 0) 0) 1))
+ (eq (aref (aref x 0) 0) (aref (aref (aref x 0) 0) 2))))
+(let ((x (read-from-string "(#1=#(0 #2=#:g100 2) #2# #1#)")))
+ (and (= 3 (length x))
+ (eq (first x) (third x))
+ (string= (symbol-name (aref (first x) 1)) "G100")
+ (null (symbol-package (aref (first x) 1)))
+ (eq (aref (first x) 1) (second x))))
+(let ((x (read-from-string "(a #1=#(0 (#1#) 2) c)")))
+ (and (= 3 (length x))
+ (eq (first x) 'a)
+ (eq (second x) (first (aref (second x) 1)))
+ (eq (third x) 'c)
+ (= 0 (aref (second x) 0))
+ (= 2 (aref (second x) 2))))
+(let ((x (read-from-string "#1=#2A((a b) (c #1#))")))
+ (and (= 4 (array-total-size x))
+ (eq (aref x 0 0) 'a)
+ (eq (aref x 0 1) 'b)
+ (eq (aref x 1 0) 'c)
+ (eq (aref x 1 1) x)))
+(let ((x (read-from-string "#2A((#1=#:G10 b) (#1# d))")))
+ (and (= 4 (array-total-size x))
+ (eq (aref x 0 0) (aref x 1 0))
+ (null (symbol-package (aref x 0 0)))
+ (string= (symbol-name (aref x 0 0)) "G10")
+ (eq (aref x 0 1) 'b)
+ (eq (aref x 1 1) 'd)))
+(let ((x (read-from-string "#1=#2A((#2=#:GG #1#) (#2# #1#))")))
+ (and (= 4 (array-total-size x))
+ (eq (aref x 0 0) (aref x 1 0))
+ (null (symbol-package (aref x 0 0)))
+ (string= "GG" (symbol-name (aref x 0 0)))
+ (eq x (aref x 0 1))
+ (eq x (aref x 1 1))))
+(let ((x (read-from-string "#1=#0A#1#")))
+ (and (arrayp x)
+ (eq x (aref x))))
+(let ((x (read-from-string "#1=#0A(#1#)")))
+ (and (arrayp x)
+ (consp (aref x))
+ (= 1 (length (aref x)))
+ (eq x (first (aref x)))))
+(let ((x (read-from-string "#1=#1A(#1#)")))
+ (and (vectorp x)
+ (= 1 (length x))
+ (eq x (aref x 0))))
+(let ((x (read-from-string "#1=#1A(#2=(a b c) #1# #2#)")))
+ (and (vectorp x)
+ (= 3 (length x))
+ (equal (aref x 0) '(a b c))
+ (eq (aref x 0) (aref x 2))
+ (eq x (aref x 1))))
+(let ((x (read-from-string
+ "#1=#3A(((0 a) (1 b) (2 c))
+ ((3 d) (4 #2A((41 #2=#(x y z)) (43 #1#))) (5 f))
+ ((6 g) (((#2#)) h) (9 i)))")))
+ (and (= 18 (array-total-size x))
+ (= 0 (aref x 0 0 0))
+ (eq 'a (aref x 0 0 1))
+ (= 1 (aref x 0 1 0))
+ (eq 'b (aref x 0 1 1))
+ (= 2 (aref x 0 2 0))
+ (eq 'c (aref x 0 2 1))
+ (= 3 (aref x 1 0 0))
+ (eq 'd (aref x 1 0 1))
+ (= 4 (aref x 1 1 0))
+ (= (array-total-size (aref x 1 1 1)) 4)
+ (= 41 (aref (aref x 1 1 1) 0 0))
+ (equalp (aref (aref x 1 1 1) 0 1) #(x y z))
+ (= 43 (aref (aref x 1 1 1) 1 0))
+ (eq x (aref (aref x 1 1 1) 1 1))
+ (= 5 (aref x 1 2 0))
+ (eq 'f (aref x 1 2 1))
+ (= 6 (aref x 2 0 0))
+ (eq 'g (aref x 2 0 1))
+ (eq (caar (aref x 2 1 0)) (aref (aref x 1 1 1) 0 1))
+ (eq 'h (aref x 2 1 1))
+ (= 9 (aref x 2 2 0))
+ (eq 'i (aref x 2 2 1))))
+
+
+(progn
+ #-CLISP ;Bruno: ANSI CL 2.2. refers to the spec of READ, which says that
+ ; an error of type end-of-file is signalled.
+ (handler-case (null (let ((*features* '())) (read-from-string "#+test1 a")))
+ (error () nil))
+ #+CLISP 'skipped)
+
+(let ((*features* '()))
+ (equal (with-input-from-string (stream "#+test1 a #-test1 b")
+ (loop
+ for x = (read stream nil 'end)
+ until (eq x 'end)
+ collecting x))
+ '(b)))
+(let ((*features* '(:test1)))
+ (equal (with-input-from-string (stream "#+test1 a #-test1 b")
+ (loop
+ for x = (read stream nil 'end)
+ until (eq x 'end)
+ collecting x))
+ '(a)))
+(let ((*features* '()))
+ (equal (with-input-from-string (stream "#+(not test1) eat-this")
+ (loop
+ for x = (read stream nil 'end)
+ until (eq x 'end)
+ collecting x))
+ '(eat-this)))
+(let ((*features* '(:test1)))
+ (equal (with-input-from-string (stream "#+(not test1) eat-this")
+ (loop
+ for x = (read stream nil 'end)
+ until (eq x 'end)
+ collecting x))
+ '()))
+(let ((*features* '(:test1)))
+ (equal (with-input-from-string (stream "#-(not test1) eat-this")
+ (loop
+ for x = (read stream nil 'end)
+ until (eq x 'end)
+ collecting x))
+ '(eat-this)))
+(let ((*features* '()))
+ (equal (with-input-from-string (stream "#-(not test1) eat-this")
+ (loop
+ for x = (read stream nil 'end)
+ until (eq x 'end)
+ collecting x))
+ '()))
+
+(let ((*features* '(:test1 :test2)))
+ (equal (with-input-from-string (stream "#+(and test1 test2) eat-this")
+ (loop
+ for x = (read stream nil 'end)
+ until (eq x 'end)
+ collecting x))
+ '(eat-this)))
+(let ((*features* '(:test1)))
+ (equal (with-input-from-string (stream "#+(and test1 test2) eat-this")
+ (loop
+ for x = (read stream nil 'end)
+ until (eq x 'end)
+ collecting x))
+ '()))
+(let ((*features* '()))
+ (equal (with-input-from-string (stream "#+(and test1 test2) eat-this")
+ (loop
+ for x = (read stream nil 'end)
+ until (eq x 'end)
+ collecting x))
+ '()))
+(let ((*features* '()))
+ (equal (with-input-from-string (stream "#+(or test1 test2) eat-this")
+ (loop
+ for x = (read stream nil 'end)
+ until (eq x 'end)
+ collecting x))
+ '()))
+(let ((*features* '(:test1)))
+ (equal (with-input-from-string (stream "#+(or test1 test2) eat-this")
+ (loop
+ for x = (read stream nil 'end)
+ until (eq x 'end)
+ collecting x))
+ '(eat-this)))
+(let ((*features* '(:test2)))
+ (equal (with-input-from-string (stream "#+(or test1 test2) eat-this")
+ (loop
+ for x = (read stream nil 'end)
+ until (eq x 'end)
+ collecting x))
+ '(eat-this)))
+(let ((*features* '(:test1 :test2)))
+ (equal (with-input-from-string (stream "#+(or test1 test2) eat-this")
+ (loop
+ for x = (read stream nil 'end)
+ until (eq x 'end)
+ collecting x))
+ '(eat-this)))
+(let ((*features* '(:test1 :test2 :test3)))
+ (equal (with-input-from-string (stream "#+(or test1 test2) eat-this")
+ (loop
+ for x = (read stream nil 'end)
+ until (eq x 'end)
+ collecting x))
+ '(eat-this)))
+
+(let ((*features* '(:test1 :test2)))
+ (equal (with-input-from-string (stream "#+(and test1 (not test2)) eat-this")
+ (loop
+ for x = (read stream nil 'end)
+ until (eq x 'end)
+ collecting x))
+ '()))
+(let ((*features* '()))
+ (equal (with-input-from-string (stream "#+(and test1 (not test2)) eat-this")
+ (loop
+ for x = (read stream nil 'end)
+ until (eq x 'end)
+ collecting x))
+ '()))
+(let ((*features* '(:test1)))
+ (equal (with-input-from-string (stream "#+(and test1 (not test2)) eat-this")
+ (loop
+ for x = (read stream nil 'end)
+ until (eq x 'end)
+ collecting x))
+ '(eat-this)))
+(let ((*features* '()))
+ (equal (with-input-from-string
+ (stream "#+(or (and test1 (not test2)) test3) eat-this")
+ (loop
+ for x = (read stream nil 'end)
+ until (eq x 'end)
+ collecting x))
+ '()))
+(let ((*features* '(:test1)))
+ (equal (with-input-from-string
+ (stream "#+(or (and test1 (not test2)) test3) eat-this")
+ (loop
+ for x = (read stream nil 'end)
+ until (eq x 'end)
+ collecting x))
+ '(eat-this)))
+(let ((*features* '(:test1 :test2)))
+ (equal (with-input-from-string
+ (stream "#+(or (and test1 (not test2)) test3) eat-this")
+ (loop
+ for x = (read stream nil 'end)
+ until (eq x 'end)
+ collecting x))
+ '()))
+(let ((*features* '(:test1 :test2 :test3)))
+ (equal (with-input-from-string
+ (stream "#+(or (and test1 (not test2)) test3) eat-this")
+ (loop
+ for x = (read stream nil 'end)
+ until (eq x 'end)
+ collecting x))
+ '(eat-this)))
+(let ((*features* '(:test1 :test3)))
+ (equal (with-input-from-string
+ (stream "#+(or (and test1 (not test2)) test3) eat-this")
+ (loop
+ for x = (read stream nil 'end)
+ until (eq x 'end)
+ collecting x))
+ '(eat-this)))
+(let ((*features* '(:test2 :test3)))
+ (equal (with-input-from-string
+ (stream "#+(or (and test1 (not test2)) test3) eat-this")
+ (loop
+ for x = (read stream nil 'end)
+ until (eq x 'end)
+ collecting x))
+ '(eat-this)))
+
+(let ((*features* '()))
+ (equal (with-input-from-string
+ (stream "#+(and test1 (not test2) (or test3 test4)) eat-this")
+ (loop
+ for x = (read stream nil 'end)
+ until (eq x 'end)
+ collecting x))
+ '()))
+(let ((*features* '(:test1)))
+ (equal (with-input-from-string
+ (stream "#+(and test1 (not test2) (or test3 test4)) eat-this")
+ (loop
+ for x = (read stream nil 'end)
+ until (eq x 'end)
+ collecting x))
+ '()))
+(let ((*features* '(:test1 :test3)))
+ (equal (with-input-from-string
+ (stream "#+(and test1 (not test2) (or test3 test4)) eat-this")
+ (loop
+ for x = (read stream nil 'end)
+ until (eq x 'end)
+ collecting x))
+ '(eat-this)))
+(let ((*features* '(:test1 :test4)))
+ (equal (with-input-from-string
+ (stream "#+(and test1 (not test2) (or test3 test4)) eat-this")
+ (loop
+ for x = (read stream nil 'end)
+ until (eq x 'end)
+ collecting x))
+ '(eat-this)))
+(let ((*features* '(:test1 :test2)))
+ (equal (with-input-from-string
+ (stream "#+(and test1 (not test2) (or test3 test4)) eat-this")
+ (loop
+ for x = (read stream nil 'end)
+ until (eq x 'end)
+ collecting x))
+ '()))
+(let ((*features* '(:test1 :test2 :test3)))
+ (equal (with-input-from-string
+ (stream "#+(and test1 (not test2) (or test3 test4)) eat-this")
+ (loop
+ for x = (read stream nil 'end)
+ until (eq x 'end)
+ collecting x))
+ '()))
+(let ((*features* '(:test1 :test2 :test3 :test4)))
+ (equal (with-input-from-string
+ (stream "#+(and test1 (not test2) (or test3 test4)) eat-this")
+ (loop
+ for x = (read stream nil 'end)
+ until (eq x 'end)
+ collecting x))
+ '()))
+(let ((*features* '(:test1 :test3 :test4)))
+ (equal (with-input-from-string
+ (stream "#+(and test1 (not test2) (or test3 test4)) eat-this")
+ (loop
+ for x = (read stream nil 'end)
+ until (eq x 'end)
+ collecting x))
+ '(eat-this)))
+
+(let ((*features* '()))
+ (equal (with-input-from-string
+ (stream "#-(not (and test1 (not test2) (or test3 test4))) eat-this")
+ (loop
+ for x = (read stream nil 'end)
+ until (eq x 'end)
+ collecting x))
+ '()))
+(let ((*features* '(:test1)))
+ (equal (with-input-from-string
+ (stream "#-(not (and test1 (not test2) (or test3 test4))) eat-this")
+ (loop
+ for x = (read stream nil 'end)
+ until (eq x 'end)
+ collecting x))
+ '()))
+(let ((*features* '(:test1 :test3)))
+ (equal (with-input-from-string
+ (stream "#-(not (and test1 (not test2) (or test3 test4))) eat-this")
+ (loop
+ for x = (read stream nil 'end)
+ until (eq x 'end)
+ collecting x))
+ '(eat-this)))
+(let ((*features* '(:test1 :test4)))
+ (equal (with-input-from-string
+ (stream "#-(not (and test1 (not test2) (or test3 test4))) eat-this")
+ (loop
+ for x = (read stream nil 'end)
+ until (eq x 'end)
+ collecting x))
+ '(eat-this)))
+(let ((*features* '(:test1 :test2)))
+ (equal (with-input-from-string
+ (stream "#-(not (and test1 (not test2) (or test3 test4))) eat-this")
+ (loop
+ for x = (read stream nil 'end)
+ until (eq x 'end)
+ collecting x))
+ '()))
+(let ((*features* '(:test1 :test2 :test3)))
+ (equal (with-input-from-string
+ (stream "#-(not (and test1 (not test2) (or test3 test4))) eat-this")
+ (loop
+ for x = (read stream nil 'end)
+ until (eq x 'end)
+ collecting x))
+ '()))
+(let ((*features* '(:test1 :test2 :test3 :test4)))
+ (equal (with-input-from-string
+ (stream "#-(not (and test1 (not test2) (or test3 test4))) eat-this")
+ (loop
+ for x = (read stream nil 'end)
+ until (eq x 'end)
+ collecting x))
+ '()))
+(let ((*features* '(:test1 :test3 :test4)))
+ (equal (with-input-from-string
+ (stream "#-(not (and test1 (not test2) (or test3 test4))) eat-this")
+ (loop
+ for x = (read stream nil 'end)
+ until (eq x 'end)
+ collecting x))
+ '(eat-this)))
+
+
+(eq (read-from-string "#| comment |# a") 'a)
+(eq (read-from-string "#| #| nested comment |# |# a") 'a)
+(eq (read-from-string "#| comment
+comment
+ still comment
+|# a") 'a)
+
+(handler-case (read-from-string "#<invalid-token>")
+ (reader-error () t)
+ (error () nil)
+ (:no-error (&rest rest) (declare (ignore rest)) nil))
+(handler-case (read-from-string "# ")
+ (reader-error () t)
+ (error () nil)
+ (:no-error (&rest rest) (declare (ignore rest)) nil))
+(handler-case (read-from-string "#
+")
+ (reader-error () t)
+ (error () nil)
+ (:no-error (&rest rest) (declare (ignore rest)) nil))
+(handler-case (read-from-string "#)")
+ (reader-error () t)
+ (error () nil)
+ (:no-error (&rest rest) (declare (ignore rest)) nil))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :upcase)
+ (string= "ZEBRA" (symbol-name (read-from-string "ZEBRA"))))
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :upcase)
+ (string= "ZEBRA" (symbol-name (read-from-string "Zebra"))))
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :upcase)
+ (string= "ZEBRA" (symbol-name (read-from-string "zebra"))))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :downcase)
+ (string= "zebra" (symbol-name (read-from-string "ZEBRA"))))
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :downcase)
+ (string= "zebra" (symbol-name (read-from-string "Zebra"))))
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :downcase)
+ (string= "zebra" (symbol-name (read-from-string "zebra"))))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :preserve)
+ (string= "ZEBRA" (symbol-name (read-from-string "ZEBRA"))))
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :preserve)
+ (string= "Zebra" (symbol-name (read-from-string "Zebra"))))
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :preserve)
+ (string= "zebra" (symbol-name (read-from-string "zebra"))))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :invert)
+ (string= "zebra" (symbol-name (read-from-string "ZEBRA"))))
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :invert)
+ (string= "Zebra" (symbol-name (read-from-string "Zebra"))))
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :invert)
+ (string= "ZEBRA" (symbol-name (read-from-string "zebra"))))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :upcase)
+ (string= "CAT-AND-MOUSE" (symbol-name (read-from-string "cat-and-mouse"))))
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :upcase)
+ (string= "CAT-AND-MOUSE" (symbol-name (read-from-string "Cat-And-Mouse"))))
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :upcase)
+ (string= "CAT-AND-MOUSE" (symbol-name (read-from-string "CAT-AND-MOUSE"))))
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :downcase)
+ (string= "cat-and-mouse" (symbol-name (read-from-string "cat-and-mouse"))))
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :downcase)
+ (string= "cat-and-mouse" (symbol-name (read-from-string "Cat-And-Mouse"))))
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :downcase)
+ (string= "cat-and-mouse" (symbol-name (read-from-string "CAT-AND-MOUSE"))))
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :preserve)
+ (string= "cat-and-mouse" (symbol-name (read-from-string "cat-and-mouse"))))
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :preserve)
+ (string= "Cat-And-Mouse" (symbol-name (read-from-string "Cat-And-Mouse"))))
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :preserve)
+ (string= "CAT-AND-MOUSE" (symbol-name (read-from-string "CAT-AND-MOUSE"))))
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :invert)
+ (string= "CAT-AND-MOUSE" (symbol-name (read-from-string "cat-and-mouse"))))
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :invert)
+ (string= "Cat-And-Mouse" (symbol-name (read-from-string "Cat-And-Mouse"))))
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :invert)
+ (string= "cat-and-mouse" (symbol-name (read-from-string "CAT-AND-MOUSE"))))
+
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :upcase)
+ (string= "CAT*AND*MOUSE" (symbol-name (read-from-string "cat*and*mouse"))))
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :upcase)
+ (string= "CAT*AND*MOUSE" (symbol-name (read-from-string "Cat*And*Mouse"))))
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :upcase)
+ (string= "CAT*AND*MOUSE" (symbol-name (read-from-string "CAT*AND*MOUSE"))))
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :downcase)
+ (string= "cat*and*mouse" (symbol-name (read-from-string "cat*and*mouse"))))
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :downcase)
+ (string= "cat*and*mouse" (symbol-name (read-from-string "Cat*And*Mouse"))))
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :downcase)
+ (string= "cat*and*mouse" (symbol-name (read-from-string "CAT*AND*MOUSE"))))
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :preserve)
+ (string= "cat*and*mouse" (symbol-name (read-from-string "cat*and*mouse"))))
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :preserve)
+ (string= "Cat*And*Mouse" (symbol-name (read-from-string "Cat*And*Mouse"))))
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :preserve)
+ (string= "CAT*AND*MOUSE" (symbol-name (read-from-string "CAT*AND*MOUSE"))))
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :invert)
+ (string= "CAT*AND*MOUSE" (symbol-name (read-from-string "cat*and*mouse"))))
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :invert)
+ (string= "Cat*And*Mouse" (symbol-name (read-from-string "Cat*And*Mouse"))))
+(let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :invert)
+ (string= "cat*and*mouse" (symbol-name (read-from-string "CAT*AND*MOUSE"))))
+
+
+(with-input-from-string (stream "a b")
+ (and (eq 'a (read-preserving-whitespace stream))
+ (eq #\Space (read-char stream))
+ (eq #\b (read-char stream))))
+
+(handler-case (with-input-from-string (stream " ") (read stream))
+ (end-of-file () t)
+ (error () nil)
+ (:no-error (&rest rest) (declare (ignore rest)) nil))
+
+(let ((x nil))
+ (and (eq t (handler-case (with-input-from-string (stream "a")
+ (setq x (read stream))
+ (read stream))
+ (end-of-file () t)
+ (error () nil)
+ (:no-error (&rest rest) (declare (ignore rest)) nil)))
+ (eq x 'a)))
+
+(progn
+ (let ((*readtable* (copy-readtable nil)))
+ (set-macro-character
+ #\/
+ #'(lambda (stream char)
+ (declare (ignore char))
+ `(path . ,(loop for dir = (read-preserving-whitespace stream t)
+ then (progn (read-char stream t nil t)
+ (read-preserving-whitespace stream t))
+ collect dir
+ while (eql (peek-char nil stream nil nil t) #\/)))))
+ (equal (read-from-string "(zyedh /usr/games/zork /usr/games/boggle)")
+ '(zyedh (path usr games zork) (path usr games boggle)))))
+
+(progn
+ (let ((*readtable* (copy-readtable nil)))
+ (set-macro-character
+ #\/
+ #'(lambda (stream char)
+ (declare (ignore char))
+ `(path . ,(loop for dir = (read stream t)
+ then (progn (read-char stream t nil t)
+ (read stream t))
+ collect dir
+ while (eql (peek-char nil stream nil nil t) #\/)))))
+ (equal (read-from-string "(zyedh /usr/games/zork /usr/games/boggle)")
+ '(zyedh (path usr games zork usr games boggle)))))
+
+
+(let ((*readtable* (copy-readtable nil)))
+ (and (eq t (set-syntax-from-char #\7 #\;))
+ (= 1235 (read-from-string "123579"))))
+
+
+
+
+
+(readtablep *readtable*)
+
+(readtablep (copy-readtable))
+(readtablep (copy-readtable nil))
+(readtablep (copy-readtable nil (copy-readtable)))
+(let ((to (copy-readtable)))
+ (eq to (copy-readtable nil to)))
+
+(let ((zvar 123)
+ (table2 (copy-readtable)))
+ (declare (special zvar))
+ (and (= zvar 123)
+ (set-syntax-from-char #\z #\' table2)
+ (= zvar 123)
+ (let ((*readtable* table2))
+ (and (equal '(quote var) (read-from-string "zvar"))
+ (setq *readtable* (copy-readtable))
+ (equal '(quote var) (read-from-string "zvar"))
+ (setq *readtable* (copy-readtable nil))
+ (= 123 (eval (read-from-string "zvar")))))))
+
+(not (eq (copy-readtable) *readtable*))
+(not (eq (copy-readtable) (copy-readtable)))
+(not (eq (copy-readtable nil) *readtable*))
+(not (eq (copy-readtable nil) (copy-readtable nil)))
+
+(let ((*readtable* (copy-readtable nil)))
+ (and (handler-case (read-from-string "#<abc")
+ (reader-error () t)
+ (error () nil)
+ (:no-error (&rest rest) (declare (ignore rest)) nil))
+ (set-dispatch-macro-character #\# #\<
+ #'(lambda (s c n)
+ (declare (ignore c n))
+ (read-char s t nil t)
+ (read s t nil t)))
+ (eq 'bc (read-from-string "#<abc"))
+ (setq *readtable* (copy-readtable))
+ (eq 'bc (read-from-string "#<abc"))
+ (setq *readtable* (copy-readtable nil))
+ (handler-case (read-from-string "#<abc")
+ (reader-error () t)
+ (error () nil)
+ (:no-error (&rest rest) (declare (ignore rest)) nil))))
+
+(let ((*readtable* (copy-readtable nil)))
+ (and (handler-case (read-from-string "#<abc")
+ (reader-error () t)
+ (error () nil)
+ (:no-error (&rest rest) (declare (ignore rest)) nil))
+ (set-dispatch-macro-character #\# #\<
+ #'(lambda (s c n)
+ (declare (ignore c n))
+ (read-char s t nil t)
+ (read s t nil t)))
+ (eq 'bc (read-from-string "#<abc"))
+ (setq *readtable* (copy-readtable))
+ (eq 'bc (read-from-string "#<abc"))
+ (set-dispatch-macro-character #\# #\<
+ #'(lambda (s c n)
+ (declare (ignore c n))
+ (read-char s t nil t)
+ (read-char s t nil t)
+ (read s t nil t)))
+ (eq 'c (read-from-string "#<abc"))
+ (setq *readtable* (copy-readtable nil))
+ (handler-case (read-from-string "#<abc")
+ (reader-error () t)
+ (error () nil)
+ (:no-error (&rest rest) (declare (ignore rest)) nil))))
+
+
+(let ((table (copy-readtable nil)))
+ (and (eq :upcase (readtable-case table))
+ (setf (readtable-case table) :invert)
+ (let ((copy (copy-readtable table)))
+ (and (not (eq table copy)) (eq (readtable-case copy) :invert)))))
+
+(let ((table (copy-readtable nil))
+ copy)
+ (and (eq :upcase (readtable-case table))
+ (setf (readtable-case table) :invert)
+ (eq (readtable-case table) :invert)
+ (setq copy (copy-readtable table))
+ (eq (readtable-case copy) :invert)
+ (setf (readtable-case copy) :preserve)
+ (eq (readtable-case table) :invert)))
+
+(eq :upcase (let ((x (copy-readtable nil))) (readtable-case x)))
+(let ((x (copy-readtable nil)))
+ (and (eq (setf (readtable-case x) :upcase) (readtable-case x))
+ (eq (setf (readtable-case x) :downcase) (readtable-case x))
+ (eq (setf (readtable-case x) :preserve) (readtable-case x))
+ (eq (setf (readtable-case x) :invert) (readtable-case x))))
+
+(handler-case (readtable-case 'not-a-readtable)
+ (type-error () t)
+ (error () nil)
+ (:no-error (&rest rest) (declare (ignore rest)) nil))
+
+(handler-case (setf (readtable-case (copy-readtable nil)) :no-such-mode)
+ (type-error () t)
+ (error () nil)
+ (:no-error (&rest rest) (declare (ignore rest)) nil))
+
+(let ((table (copy-readtable nil)))
+ (and (eq :upcase (readtable-case table))
+ (setf (readtable-case table) :downcase)
+ (eq :downcase (readtable-case (copy-readtable table)))))
+
+(not (readtablep nil))
+(not (readtablep 'readtable))
+(readtablep *readtable*)
+(readtablep (copy-readtable))
+(not (readtablep '*readtable*))
+
+(null (get-dispatch-macro-character #\# #\0))
+(null (get-dispatch-macro-character #\# #\1))
+(null (get-dispatch-macro-character #\# #\2))
+(null (get-dispatch-macro-character #\# #\3))
+(null (get-dispatch-macro-character #\# #\4))
+(null (get-dispatch-macro-character #\# #\5))
+(null (get-dispatch-macro-character #\# #\6))
+(null (get-dispatch-macro-character #\# #\7))
+(null (get-dispatch-macro-character #\# #\8))
+(null (get-dispatch-macro-character #\# #\9))
+
+(get-dispatch-macro-character #\# #\\)
+(get-dispatch-macro-character #\# #\')
+(get-dispatch-macro-character #\# #\()
+(get-dispatch-macro-character #\# #\*)
+(get-dispatch-macro-character #\# #\:)
+(get-dispatch-macro-character #\# #\.)
+(get-dispatch-macro-character #\# #\b)
+(get-dispatch-macro-character #\# #\o)
+(get-dispatch-macro-character #\# #\x)
+(get-dispatch-macro-character #\# #\r)
+(get-dispatch-macro-character #\# #\c)
+(get-dispatch-macro-character #\# #\a)
+(get-dispatch-macro-character #\# #\s)
+(get-dispatch-macro-character #\# #\p)
+(get-dispatch-macro-character #\# #\=)
+(get-dispatch-macro-character #\# #\#)
+(get-dispatch-macro-character #\# #\+)
+(get-dispatch-macro-character #\# #\-)
+(get-dispatch-macro-character #\# #\|)
+
+(get-dispatch-macro-character #\# #\newline)
+(get-dispatch-macro-character #\# #\space)
+
+(handler-case (get-dispatch-macro-character #\a #\b)
+ (error () t)
+ (:no-error (&rest rest) (declare (ignore rest)) nil))
+
+(handler-case (get-dispatch-macro-character #\a #\b nil)
+ (error () t)
+ (:no-error (&rest rest) (declare (ignore rest)) nil))
+
+(handler-case (get-dispatch-macro-character #\a #\b *readtable*)
+ (error () t)
+ (:no-error (&rest rest) (declare (ignore rest)) nil))
+
+(handler-case (set-dispatch-macro-character #\a #\b #'identity)
+ (error () t)
+ (:no-error (&rest rest) (declare (ignore rest)) nil))
+
+(handler-case (set-dispatch-macro-character #\a #\b #'identity *readtable*)
+ (error () t)
+ (:no-error (&rest rest) (declare (ignore rest)) nil))
+
+
+
+(let ((*readtable* (copy-readtable nil)))
+ (and (eq t (set-dispatch-macro-character
+ #\# #\{ ;dispatch on #{
+ #'(lambda(s c n)
+ (declare (ignore c))
+ (let ((list (read s nil (values) t))) ;list is object after #n{
+ (when (consp list) ;return nth element of list
+ (unless (and n (< 0 n (length list))) (setq n 0))
+ (setq list (nth n list)))
+ list))))
+ (= 1 (read-from-string "#{(1 2 3 4)"))
+ (= 3 (read-from-string "#3{(0 1 2 3)"))
+ (= 123 (read-from-string "#{123"))))
+
+(let ((*readtable* (copy-readtable))
+ (dollar #'(lambda (stream subchar arg)
+ (declare (ignore subchar arg))
+ (list 'dollars (read stream t nil t)))))
+ (and (eq t (set-dispatch-macro-character #\# #\$ dollar))
+ (equal '(dollars foo) (read-from-string "#$foo"))))
+
+
+
+
+(and (let ((*readtable* (copy-readtable)))
+ (and (setf (readtable-case *readtable*) :invert)
+ (string= "ABC" (symbol-name (read-from-string "abc")))
+ (string= "abc" (symbol-name (read-from-string "ABC")))
+ (string= "AbC" (symbol-name (read-from-string "AbC")))
+ (setf (readtable-case *readtable*) :preserve)
+ (string= "abc" (symbol-name (read-from-string "abc")))
+ (string= "ABC" (symbol-name (read-from-string "ABC")))
+ (string= "AbC" (symbol-name (read-from-string "AbC")))))
+ (eq (readtable-case *readtable*) :upcase)
+ (string= "ABC" (symbol-name (read-from-string "abc")))
+ (string= "ABC" (symbol-name (read-from-string "ABC")))
+ (string= "ABC" (symbol-name (read-from-string "AbC"))))
+
+
+(let ((*readtable* (copy-readtable)))
+ (and (setf (readtable-case *readtable*) :invert)
+ (set-macro-character #\< #'(lambda (stream c)
+ (declare (ignore c))
+ (read-delimited-list #\> stream t))
+ t)
+ (set-macro-character #\> (get-macro-character #\)))
+ (equal '(a b) (read-from-string "<a b>"))))
+
+(let ((*readtable* (copy-readtable)))
+ (and (setf (readtable-case *readtable*) :invert)
+ (set-macro-character #\< #'(lambda (stream c)
+ (declare (ignore c))
+ (read-delimited-list #\> stream t)))
+ (set-macro-character #\> (get-macro-character #\)))
+ (with-input-from-string (stream "xyz<A b>jKl")
+ (and (eq 'xyz (read stream))
+ (equal '(|a| b) (read stream))
+ (eq '|jKl| (read stream))
+ (eq 'end (read stream nil 'end))))))
+
+(let ((*readtable* (copy-readtable nil)))
+ (and (equal (multiple-value-list (get-macro-character #\{)) '(nil nil))
+ (eq t (make-dispatch-macro-character #\{))
+ (get-macro-character #\{)))
+
+(let ((*readtable* (copy-readtable nil)))
+ (and (eq t (make-dispatch-macro-character #\{))
+ (handler-case (read-from-string "{$a")
+ (reader-error () t)
+ (error () nil)
+ (:no-error (&rest rest) (declare (ignore rest)) nil))))
+
+
+(let ((*readtable* (copy-readtable nil)))
+ (and (eq t (make-dispatch-macro-character #\{))
+ #-clisp (handler-case (read-from-string "{$a")
+ (reader-error () t)
+ (error () nil)
+ (:no-error (&rest rest) (declare (ignore rest)) nil))
+ (set-dispatch-macro-character #\{ #\$
+ #'(lambda (s c n)
+ (declare (ignore c n))
+ (read s t nil t)))
+ (eq 'a (read-from-string "{$a"))))
+
+
+(let ((*readtable* (copy-readtable nil)))
+ (and (eq t (make-dispatch-macro-character #\{))
+ #-clisp (handler-case (read-from-string "{$a")
+ (reader-error () t)
+ (error () nil)
+ (:no-error (&rest rest) (declare (ignore rest)) nil))
+ (set-dispatch-macro-character #\{ #\$
+ #'(lambda (s c n)
+ (declare (ignore c n))
+ (read s t nil t)))
+ (with-input-from-string (stream "xyz{$a")
+ (and (eq 'xyz (read stream))
+ (eq 'a (read stream))
+ (eq 'end (read stream nil 'end))))))
+
+(let ((*readtable* (copy-readtable nil)))
+ (and (eq t (make-dispatch-macro-character #\{ t))
+ #-clisp (handler-case (read-from-string "{$a")
+ (reader-error () t)
+ (error () nil)
+ (:no-error (&rest rest) (declare (ignore rest)) nil))
+ (set-dispatch-macro-character #\{ #\$
+ #'(lambda (s c n)
+ (declare (ignore c n))
+ (read s t nil t)))
+ (with-input-from-string (stream "xyz{$a")
+ (and (eq '|XYZ{$A| (read stream))
+ (eq 'end (read stream nil 'end))))))
+
+
+(let ((table (copy-readtable nil)))
+ (and (eq t (make-dispatch-macro-character #\{ nil table))
+ #-clisp (let ((*readtable* table))
+ (handler-case (read-from-string "{$a")
+ (reader-error () t)
+ (error () nil)
+ (:no-error (&rest rest) (declare (ignore rest)) nil)))
+ (set-dispatch-macro-character #\{ #\$
+ #'(lambda (s c n)
+ (declare (ignore c n))
+ (read s t nil t))
+ table)
+ (let ((*readtable* table))
+ (with-input-from-string (stream "xyz{$a")
+ (and (eq 'xyz (read stream))
+ (eq 'a (read stream))
+ (eq 'end (read stream nil 'end)))))))
+
+
+(let ((table (copy-readtable nil)))
+ (and (eq t (make-dispatch-macro-character #\{ t table))
+ #-clisp (let ((*readtable* table))
+ (handler-case (read-from-string "{$a")
+ (reader-error () t)
+ (error () nil)
+ (:no-error (&rest rest) (declare (ignore rest)) nil)))
+ (set-dispatch-macro-character #\{ #\$
+ #'(lambda (s c n)
+ (declare (ignore c n))
+ (read s t nil t))
+ table)
+ (let ((*readtable* table))
+ (with-input-from-string (stream "xyz{$a")
+ (and (eq '|XYZ{$A| (read stream))
+ (eq 'end (read stream nil 'end)))))))
+
+
+(with-input-from-string (stream "")
+ (handler-case (read stream t)
+ (end-of-file () t)
+ (error () nil)
+ (:no-error (&rest rest) (declare (ignore rest)) nil)))
+
+(with-input-from-string (stream "")
+ (handler-case (read-preserving-whitespace stream t)
+ (end-of-file () t)
+ (error () nil)
+ (:no-error (&rest rest) (declare (ignore rest)) nil)))
+
+(with-input-from-string (stream "")
+ (handler-case (read stream t 'ignored)
+ (end-of-file () t)
+ (error () nil)
+ (:no-error (&rest rest) (declare (ignore rest)) nil)))
+
+(with-input-from-string (stream "")
+ (handler-case (read-preserving-whitespace stream t 'ignored)
+ (end-of-file () t)
+ (error () nil)
+ (:no-error (&rest rest) (declare (ignore rest)) nil)))
+
+
+(with-input-from-string (stream "")
+ (eq 'end (read stream nil 'end)))
+
+(with-input-from-string (stream "")
+ (eq 'end (read-preserving-whitespace stream nil 'end)))
+
+(with-input-from-string (stream "a b")
+ (and (eq 'a (read-preserving-whitespace stream t nil nil))
+ (equal (loop for c = (read-char stream nil nil)
+ while c collecting c)
+ '(#\space #\space #\b))))
+
+(with-input-from-string (stream "a b")
+ (and (eq 'a (read-preserving-whitespace stream t nil))
+ (equal (loop for c = (read-char stream nil nil)
+ while c collecting c)
+ '(#\space #\space #\b))))
+
+
+(with-input-from-string (stream "ok")
+ (let ((*standard-input* stream))
+ (eq 'ok (read))))
+
+(with-input-from-string (stream "ok")
+ (let ((*standard-input* stream))
+ (eq 'ok (read-preserving-whitespace))))
+
+
+(with-input-from-string (stream "")
+ (let ((*standard-input* stream))
+ (handler-case (read)
+ (end-of-file () t)
+ (error () nil)
+ (:no-error (&rest rest) (declare (ignore rest)) nil))))
+
+(with-input-from-string (stream "")
+ (let ((*standard-input* stream))
+ (handler-case (read-preserving-whitespace)
+ (end-of-file () t)
+ (error () nil)
+ (:no-error (&rest rest) (declare (ignore rest)) nil))))
+
+
+(with-input-from-string (stream "")
+ (let ((*standard-input* stream))
+ (null (read nil nil))))
+
+(with-input-from-string (stream "")
+ (let ((*standard-input* stream))
+ (null (read-preserving-whitespace nil nil))))
+
+
+(with-input-from-string (*standard-input* "(a b")
+ (handler-case (read)
+ (end-of-file () t)
+ (error () nil)
+ (:no-error (&rest rest) (declare (ignore rest)) nil)))
+
+(with-input-from-string (*standard-input* "(a b")
+ (handler-case (read-preserving-whitespace)
+ (end-of-file () t)
+ (error () nil)
+ (:no-error (&rest rest) (declare (ignore rest)) nil)))
+
+(with-input-from-string (*standard-input* "(a (b")
+ (handler-case (read)
+ (end-of-file () t)
+ (error () nil)
+ (:no-error (&rest rest) (declare (ignore rest)) nil)))
+
+(with-input-from-string (*standard-input* "(a (b")
+ (handler-case (read-preserving-whitespace)
+ (end-of-file () t)
+ (error () nil)
+ (:no-error (&rest rest) (declare (ignore rest)) nil)))
+
+;; read-delimited-list
+(with-input-from-string (*standard-input* "a b)")
+ (equal '(a b) (read-delimited-list #\))))
+(with-input-from-string (*standard-input* ")")
+ (null (read-delimited-list #\))))
+(with-input-from-string (*standard-input* "a b )")
+ (equal '(a b) (read-delimited-list #\))))
+(with-input-from-string (*standard-input* " a b )")
+ (equal '(a b) (read-delimited-list #\))))
+(with-input-from-string (*standard-input* " a b ) ")
+ (equal '(a b) (read-delimited-list #\))))
+(with-input-from-string (*standard-input* "a b c d e f g h i j k l m n o p q r)")
+ (equal '(a b c d e f g h i j k l m n o p q r) (read-delimited-list #\))))
+
+(with-input-from-string
+ (*standard-input* "a (b) c (d) e f g h i j (k l m ) n o p q r)")
+ (equal '(a (b) c (d) e f g h i j (k l m) n o p q r) (read-delimited-list #\))))
+(with-input-from-string (*standard-input* "a x\\)x b)")
+ (equal '(a |X)X| b) (read-delimited-list #\))))
+
+(with-input-from-string (*standard-input* "a b) xyz")
+ (and (equal '(a b) (read-delimited-list #\)))
+ (eq 'xyz (read))))
+
+(with-input-from-string (*standard-input* "a #'car)")
+ (equal '(a #'car) (read-delimited-list #\))))
+
+(with-input-from-string (*standard-input* "a #'car ;;
+d #| e f |# g
+z)")
+ (equal '(a #'car d g z) (read-delimited-list #\))))
+
+(with-input-from-string (*standard-input* "a #'car ;;
+d #| e f |# g
+z)
+xyz")
+ (and (equal '(a #'car d g z) (read-delimited-list #\)))
+ (eq 'xyz (read))))
+
+(with-input-from-string (*standard-input* "1 2 3 4 5 6 ]")
+ (equal (read-delimited-list #\])
+ '(1 2 3 4 5 6)))
+
+(get-macro-character #\) nil)
+
+(let ((*readtable* (copy-readtable nil))
+ (f #'(lambda (stream char arg)
+ (declare (ignore char arg))
+ (mapcon #'(lambda (x)
+ (mapcar #'(lambda (y) (list (car x) y)) (cdr x)))
+ (read-delimited-list #\} stream t)))))
+ (set-dispatch-macro-character #\# #\{ f)
+ (get-macro-character #\) nil)
+ (set-macro-character #\} (get-macro-character #\) nil))
+ (with-input-from-string (*standard-input* "#{ p q z a}")
+ (equal (read) '((p q) (p z) (p a) (q z) (q a) (z a)))))
+(handler-case (with-input-from-string (stream "1 2 3 . 4)")
+ (read-delimited-list #\) stream t))
+ (error () t)
+ (:no-error (&rest rest) (declare (ignore rest)) nil))
+
+
+(get-dispatch-macro-character #\# #\( nil)
+(set-syntax-from-char #\z #\' (copy-readtable nil) nil)
+
+
+(equal '(abc 3) (multiple-value-list (read-from-string "abc")))
+
+(handler-case (read-from-string "")
+ (end-of-file () t)
+ (error () nil)
+ (:no-error (&rest rest) (declare (ignore rest)) nil))
+
+(handler-case (read-from-string "" t 'ignored)
+ (end-of-file () t)
+ (error () nil)
+ (:no-error (&rest rest) (declare (ignore rest)) nil))
+
+(eq 'end (read-from-string "" nil 'end))
+
+(equal '(b 5) (multiple-value-list (read-from-string "(a b c)" t nil
+ :start 2 :end 6)))
+
+(equal '(b 4) (multiple-value-list (read-from-string "(a b c)" t nil
+ :start 2
+ :preserve-whitespace t)))
+
+(null (read-from-string "" nil))
+
+(multiple-value-bind (thing pos) (read-from-string " a b" t nil :start 3)
+ (and (eq thing 'b)
+ (or (= pos 4) (= pos 5))))
+
+(multiple-value-bind (thing pos) (read-from-string "abcdefg" t nil :end 2)
+ (and (eq thing 'ab)
+ (or (= pos 2) (= pos 3))))
+
+(equal '(ijk 3)
+ (multiple-value-list (read-from-string "ijk xyz" t nil
+ :preserve-whitespace t)))
+
+(equal '(def 7)
+ (multiple-value-list (read-from-string "abc def ghi" t nil
+ :start 4 :end 9
+ :preserve-whitespace t)))
+
+(= 3 (read-from-string " 1 3 5" t nil :start 2))
+(multiple-value-bind (thing pos) (read-from-string "(a b c)")
+ (and (equal thing '(A B C))
+ (or (= pos 7) (= pos 8))))
+
+(handler-case (read-from-string "(a b")
+ (error () t)
+ (:no-error (&rest rest) (declare (ignore rest)) nil))
+
+
+(let ((*readtable* (copy-readtable)))
+ (and (progn
+ #-clisp (handler-case (read-from-string "#<abc")
+ (reader-error () t)
+ (error () nil)
+ (:no-error (&rest rest) (declare (ignore rest)) nil))
+ #+clisp t)
+ (set-dispatch-macro-character #\# #\<
+ #'(lambda (s c n)
+ (declare (ignore c n))
+ (read-char s t nil t)
+ (read s t nil t)))
+ (eq 'bc (read-from-string "#<abc"))
+ (setq *readtable* (copy-readtable))
+ (eq 'bc (read-from-string "#<abc"))
+ (set-dispatch-macro-character #\# #\<
+ #'(lambda (s c n)
+ (declare (ignore c n))
+ (read-char s t nil t)
+ (read-char s t nil t)
+ (read s t nil t)))
+ (eq 'c (read-from-string "#<abc"))
+ (setq *readtable* (copy-readtable nil))
+ (progn
+ #-clisp
+ (handler-case (read-from-string "#<abc")
+ (reader-error () t)
+ (error () nil)
+ (:no-error (&rest rest) (declare (ignore rest)) nil))
+ #+clisp t)))
+
+
+(let ((*readtable* (copy-readtable)))
+ (and (eq t (make-dispatch-macro-character #\{))
+ (eq t (set-dispatch-macro-character
+ #\{ #\s #'(lambda (s c n)
+ (declare (ignore c n))
+ `(section ,(read s t nil t)))))
+ (equal '(section (x y z)) (read-from-string "{s (x y z)"))
+ (equal '(section (x y z)) (read-from-string "{S (x y z)"))))
+
+
+(multiple-value-bind (function non-terminating-p) (get-macro-character #\")
+ (and function (not non-terminating-p)))
+(multiple-value-bind (function non-terminating-p) (get-macro-character #\#)
+ (and function non-terminating-p))
+(multiple-value-bind (function non-terminating-p) (get-macro-character #\')
+ (and function (not non-terminating-p)))
+(multiple-value-bind (function non-terminating-p) (get-macro-character #\()
+ (and function (not non-terminating-p)))
+(multiple-value-bind (function non-terminating-p) (get-macro-character #\))
+ (and function (not non-terminating-p)))
+(multiple-value-bind (function non-terminating-p) (get-macro-character #\,)
+ (and function (not non-terminating-p)))
+(multiple-value-bind (function non-terminating-p) (get-macro-character #\;)
+ (and function (not non-terminating-p)))
+(multiple-value-bind (function non-terminating-p) (get-macro-character #\`)
+ (and function (not non-terminating-p)))
+
+(multiple-value-bind (function non-terminating-p) (get-macro-character #\a)
+ (and (null function) (not non-terminating-p)))
+(multiple-value-bind (function non-terminating-p) (get-macro-character #\z)
+ (and (null function) (not non-terminating-p)))
+(multiple-value-bind (function non-terminating-p) (get-macro-character #\Space)
+ (and (null function) (not non-terminating-p)))
+(multiple-value-bind (function non-terminating-p) (get-macro-character #\Tab)
+ (and (null function) (not non-terminating-p)))
+
+(multiple-value-bind (function non-terminating-p) (get-macro-character #\" nil)
+ (and function (not non-terminating-p)))
+(multiple-value-bind (function non-terminating-p) (get-macro-character #\# nil)
+ (and function non-terminating-p))
+(multiple-value-bind (function non-terminating-p) (get-macro-character #\' nil)
+ (and function (not non-terminating-p)))
+(multiple-value-bind (function non-terminating-p) (get-macro-character #\( nil)
+ (and function (not non-terminating-p)))
+(multiple-value-bind (function non-terminating-p) (get-macro-character #\) nil)
+ (and function (not non-terminating-p)))
+(multiple-value-bind (function non-terminating-p) (get-macro-character #\, nil)
+ (and function (not non-terminating-p)))
+(multiple-value-bind (function non-terminating-p) (get-macro-character #\; nil)
+ (and function (not non-terminating-p)))
+(multiple-value-bind (function non-terminating-p) (get-macro-character #\` nil)
+ (and function (not non-terminating-p)))
+
+(multiple-value-bind (function non-terminating-p) (get-macro-character #\a nil)
+ (and (null function) (not non-terminating-p)))
+(multiple-value-bind (function non-terminating-p) (get-macro-character #\z nil)
+ (and (null function) (not non-terminating-p)))
+(multiple-value-bind (function non-terminating-p)
+ (get-macro-character #\Space nil)
+ (and (null function) (not non-terminating-p)))
+(multiple-value-bind (function non-terminating-p) (get-macro-character #\Tab nil)
+ (and (null function) (not non-terminating-p)))
+
+(and (let ((*readtable* (copy-readtable)))
+ (and (eq t (set-macro-character #\$
+ #'(lambda (s c)
+ (declare (ignore c))
+ `(dollars ,(read s t nil t)))))
+ (equal '(dollars 100) (read-from-string "$100"))
+ (eq '|$100| (read-from-string "\\$100"))
+ (eq '|$100| (read-from-string "|$|100"))))
+ (null (get-macro-character #\$))
+ (eq '|$100| (read-from-string "$100")))
+
+
+(let ((*readtable* (copy-readtable)))
+ (and (eq t (set-syntax-from-char #\[ #\())
+ (equal '(0 1 2 3) (read-from-string "[0 1 2 3)"))))
+
+(let ((table1 (copy-readtable nil))
+ (table2 (copy-readtable nil)))
+ (and (eq t (set-syntax-from-char #\[ #\( table1 table1))
+ (equal '(0 1 2 3) (let ((*readtable* table1))
+ (read-from-string "[0 1 2 3)")))
+ (eq t (set-syntax-from-char #\{ #\[ table2 table1))
+ (equal '(0 1 2 3) (let ((*readtable* table2))
+ (read-from-string "{0 1 2 3)")))))
+
+(let ((*readtable* (copy-readtable)))
+ (and (eq t (set-syntax-from-char #\[ #\.))
+ (eq '|3[0| (read-from-string "3[0"))))
+
+(let* ((str (concatenate 'string
+ (loop repeat 100 collecting #\()
+ "kernel"
+ (loop repeat 100 collecting #\))))
+ (thing (read-from-string str)))
+ (and (= 1 (length thing))
+ (eq 'kernel (loop repeat 101
+ for x = thing then (car x)
+ finally (return x)))))
+
+
+
+
+(null (let ((*read-suppress* t)) (read-from-string "abc")))
+(null (let ((*read-suppress* t))
+ (with-input-from-string (stream "abc")
+ (read stream))))
+(null (let ((*read-suppress* t))
+ (with-input-from-string (stream "abc")
+ (read-preserving-whitespace stream))))
+(null (let ((*read-suppress* t))
+ ;; http://www.lispworks.com/reference/HyperSpec/Body/v_rd_sup.htm
+ ;; If the value of *read-suppress* is true, read,
+ ;; read-preserving-whitespace, read-delimited-list,
+ ;; and read-from-string all return a primary value of nil
+ ;; when they complete successfully;
+ (with-input-from-string (stream "abc xyz)")
+ (read-delimited-list #\) stream))))
+
+(flet ((num2str (n base)
+ (let* ((base-digits "0123456789ABCDEFGHIJKLMNOPQRSTUV")
+ (minus-p (< n 0))
+ (n (if minus-p (- n) n))
+ digits)
+ (loop with x = n
+ do (multiple-value-bind (q r) (floor x base)
+ (push (aref base-digits r) digits)
+ (setq x q)
+ (when (zerop q) (return))))
+ (when minus-p (push #\- digits))
+ (make-array (length digits)
+ :element-type 'character :initial-contents digits))))
+ (loop for base from 2 upto 32
+ always (loop for n from -100 upto 100
+ always (= n (let ((*read-base* base))
+ (read-from-string (num2str n base)))))))
+
+(labels ((int2str (n base)
+ (let* ((base-digits "0123456789ABCDEFGHIJKLMNOPQRSTUV")
+ (minus-p (< n 0))
+ (n (if minus-p (- n) n))
+ digits)
+ (loop with x = n
+ do (multiple-value-bind (q r) (floor x base)
+ (push (aref base-digits r) digits)
+ (setq x q)
+ (when (zerop q) (return))))
+ (when minus-p (push #\- digits))
+ (make-array (length digits)
+ :element-type 'character :initial-contents digits)))
+ (ratio2str (r base)
+ (concatenate 'string
+ (int2str (numerator r) base)
+ "/"
+ (int2str (denominator r) base))))
+ (loop for base from 2 upto 32
+ always (loop for numerator from -100 upto 100 by 23
+ always (loop for denominator from 1 upto 300 by 51
+ always (= (/ numerator denominator)
+ (let ((*read-base* base))
+ (read-from-string
+ (ratio2str (/ numerator
+ denominator)
+ base))))))))
diff --git a/Sacla/tests/must-reader.patch b/Sacla/tests/must-reader.patch
new file mode 100644
index 0000000..a2db10f
--- /dev/null
+++ b/Sacla/tests/must-reader.patch
@@ -0,0 +1,26 @@
+*** sacla/lisp/test/must-reader.lisp 2004-08-03 08:34:55.000000000 +0200
+--- CLISP/clisp-20040712/sacla-tests/must-reader.lisp 2004-08-07 02:10:05.000000000 +0200
+***************
+*** 1828,1837 ****
+
+
+ (progn
+! #-clisp
+ (handler-case (null (let ((*features* '())) (read-from-string "#+test1 a")))
+ (error () nil))
+! #+clisp 'skipped)
+
+ (let ((*features* '()))
+ (equal (with-input-from-string (stream "#+test1 a #-test1 b")
+--- 1828,1838 ----
+
+
+ (progn
+! #-CLISP ; ANSI CL 2.2. refers to the spec of READ, which says that an error
+! ; of type end-of-file is signalled.
+ (handler-case (null (let ((*features* '())) (read-from-string "#+test1 a")))
+ (error () nil))
+! #+CLISP 'skipped)
+
+ (let ((*features* '()))
+ (equal (with-input-from-string (stream "#+test1 a #-test1 b")
diff --git a/Sacla/tests/must-sequence.lisp b/Sacla/tests/must-sequence.lisp
new file mode 100644
index 0000000..6871d31
--- /dev/null
+++ b/Sacla/tests/must-sequence.lisp
@@ -0,0 +1,10165 @@
+;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
+;; ALL RIGHTS RESERVED.
+;;
+;; $Id: must-sequence.lisp,v 1.31 2004/08/09 02:49:54 yuji Exp $
+;;
+;; 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.
+;;
+;; 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.
+
+(eql (length "abc") 3)
+(let ((str (make-array '(3) :element-type 'character
+ :initial-contents "abc"
+ :fill-pointer t)))
+ (and (eql (length str) 3)
+ (eql (setf (fill-pointer str) 2) 2)
+ (eql (length str) 2)))
+(zerop (length #*))
+(zerop (length ""))
+(zerop (length #()))
+(zerop (length ()))
+(eql (length '(0)) 1)
+(eql (length '(0 1)) 2)
+(eql (length '(0 1 2)) 3)
+(eql (length '(0 1 2 3)) 4)
+(eql (length '(0 1 2 3 4)) 5)
+(eql (length '(0 1 2 3 4 5)) 6)
+(eql (length '(0 1 2 3 4 5 6)) 7)
+(eql (length #(0)) 1)
+(eql (length #(0 1)) 2)
+(eql (length #(0 1 2)) 3)
+(eql (length #(0 1 2 3)) 4)
+(eql (length #(0 1 2 3 4)) 5)
+(eql (length #(0 1 2 3 4 5)) 6)
+(eql (length #(0 1 2 3 4 5 6)) 7)
+(eql (length (make-array 100)) 100)
+(eql (length (make-sequence 'list 20)) 20)
+(eql (length (make-sequence 'string 10)) 10)
+(eql (length (make-sequence 'bit-vector 3)) 3)
+(eql (length (make-sequence 'bit-vector 64)) 64)
+(eql (length (make-sequence 'simple-vector 64)) 64)
+
+
+
+(string= (copy-seq "love") "love")
+(equalp (copy-seq '#(a b c d)) '#(a b c d))
+(equalp (copy-seq '#*01010101) '#*01010101)
+(equal (copy-seq '(love)) '(love))
+(equal (copy-seq '(love hate war peace)) '(love hate war peace))
+(null (copy-seq nil))
+(string= (copy-seq "") "")
+(let* ((seq0 "love&peace")
+ (seq (copy-seq seq0)))
+ (and (not (eq seq0 seq))
+ (string= seq0 seq)))
+(let* ((seq0 (list 'love 'and 'peace))
+ (seq (copy-seq seq0)))
+ (and (not (eq seq0 seq))
+ (equal seq0 seq)))
+(let* ((c0 (list 'love))
+ (c1 (list 'peace))
+ (seq (copy-seq (list c0 c1))))
+ (and (equal seq '((love) (peace)))
+ (eq (car seq) c0)
+ (eq (cadr seq) c1)))
+(let* ((seq0 '#(t nil t nil))
+ (seq (copy-seq seq0)))
+ (and (not (eq seq0 seq))
+ (equalp seq seq0)))
+(vectorp (copy-seq (vector)))
+(simple-bit-vector-p (copy-seq #*))
+(simple-vector-p (copy-seq (vector)))
+(simple-vector-p (copy-seq (make-array 10
+ :fill-pointer 3
+ :initial-element nil)))
+(simple-vector-p (copy-seq (vector 0 1)))
+(simple-string-p (copy-seq "xyz"))
+(simple-string-p (copy-seq (make-array 3
+ :displaced-to "0123456789"
+ :displaced-index-offset 3
+ :element-type 'base-char)))
+(simple-string-p (copy-seq (make-array 20
+ :fill-pointer t
+ :element-type 'base-char
+ :initial-element #\Space)))
+(simple-bit-vector-p (copy-seq #*0101))
+(simple-bit-vector-p (copy-seq (make-array 30
+ :fill-pointer 3
+ :element-type 'bit
+ :initial-element 0)))
+(let* ((vec0 (make-array 10 :fill-pointer 3 :initial-contents "0123456789"))
+ (vec (copy-seq vec0)))
+ (and (simple-vector-p vec)
+ (= (length vec) 3)
+ (equalp vec #(#\0 #\1 #\2))))
+
+
+(char= (elt "0123456789" 6) #\6)
+(eq (elt #(a b c d e f g) 0) 'a)
+(eq (elt '(a b c d e f g) 4) 'e)
+(zerop (elt #*0101010 0))
+
+(dotimes (i 10 t)
+ (unless (char= (elt "0123456789" i) (digit-char i))
+ (return nil)))
+
+(let ((str (copy-seq "0123456789")))
+ (and (char= (elt str 6) #\6)
+ (setf (elt str 0) #\#)
+ (string= str "#123456789")))
+
+(let ((list (list 0 1 2 3)))
+ (and (= (elt list 2) 2)
+ (setf (elt list 1) 9)
+ (= (elt list 1) 9)
+ (equal list '(0 9 2 3))))
+
+(let ((bv #*0101010101))
+ (dotimes (i 10 t)
+ (unless (= (elt bv i) (if (evenp i) 0 1))
+ (return nil))))
+
+(let ((vec (vector 'a 'b 'c)))
+ (and (eq (elt vec 0) 'a)
+ (eq (elt vec 1) 'b)
+ (eq (elt vec 2) 'c)))
+
+
+(let ((list (list 0 1 2 3)))
+ (and (eq (fill list 'nil) list)
+ (every 'null list)))
+
+(let ((vector (vector 'x 'y 'z)))
+ (and (eq (fill vector 'a) vector)
+ (every #'(lambda (arg) (eq arg 'a)) vector)))
+
+(let ((list (list 0 1 2 3)))
+ (and (eq (fill list '9 :start 2) list)
+ (equal list '(0 1 9 9))))
+
+(let ((list (list 0 1 2 3)))
+ (and (eq (fill list '9 :start 1 :end 3) list)
+ (equal list '(0 9 9 3))))
+
+(let ((list (list 0 1 2 3)))
+ (and (eq (fill list '9 :start 1 :end nil) list)
+ (equal list '(0 9 9 9))))
+
+(let ((list (list 0 1 2 3)))
+ (and (eq (fill list '9 :end 1) list)
+ (equal list '(9 1 2 3))))
+
+(let ((vector (vector 0 1 2 3)))
+ (and (eq (fill vector 't :start 3) vector)
+ (equalp vector '#(0 1 2 t))))
+
+(let ((vector (vector 0 1 2 3)))
+ (and (eq (fill vector 't :start 2 :end 4) vector)
+ (equalp vector '#(0 1 t t))))
+
+(let ((vector (vector 0 1 2 3)))
+ (and (eq (fill vector 't :start 2 :end nil) vector)
+ (equalp vector '#(0 1 t t))))
+
+(let ((vector (vector 0 1 2 3)))
+ (and (eq (fill vector 't :end 3) vector)
+ (equalp vector '#(t t t 3))))
+
+
+
+(null (make-sequence 'list 0))
+(string= (make-sequence 'string 26 :initial-element #\.)
+ "..........................")
+(equalp (make-sequence '(vector double-float) 2
+ :initial-element 1d0)
+ #(1.0d0 1.0d0))
+
+
+(equal (make-sequence 'list 3 :initial-element 'a)
+ '(a a a))
+
+(equal (make-sequence 'cons 3 :initial-element 'a)
+ '(a a a))
+
+(null (make-sequence 'null 0 :initial-element 'a))
+
+(equalp (make-sequence 'vector 3 :initial-element 'z)
+ '#(z z z))
+
+(equalp (make-sequence '(vector * *) 3 :initial-element 'z)
+ '#(z z z))
+
+(equalp (make-sequence '(vector t *) 3 :initial-element 'z)
+ '#(z z z))
+
+(string= (make-sequence '(string 3) 3 :initial-element '#\a)
+ "aaa")
+
+(string= (make-sequence 'string 4 :initial-element '#\z)
+ "zzzz")
+
+(string= (make-sequence '(vector character 3) 3 :initial-element '#\a)
+ "aaa")
+
+(equalp (make-sequence '(array t 1) 3 :initial-element 'z)
+ '#(z z z))
+
+(equalp (make-sequence '(array t (3)) 3 :initial-element 'z)
+ '#(z z z))
+
+(vectorp (make-sequence 'vector 10))
+
+
+(string= (subseq "012345" 2) "2345")
+(string= (subseq "012345" 3 5) "34")
+(let ((str (copy-seq "012345")))
+ (and (setf (subseq str 4) "abc")
+ (string= str "0123ab")))
+(let ((str (copy-seq "012345")))
+ (setf (subseq str 0 2) "A")
+ (string= str "A12345"))
+
+(equal (subseq '(0 1 2 3) 0) '(0 1 2 3))
+(equal (subseq '(0 1 2 3) 1) '(1 2 3))
+(equal (subseq '(0 1 2 3) 2) '(2 3))
+(equal (subseq '(0 1 2 3) 3) '(3))
+(equal (subseq '(0 1 2 3) 4) '())
+(equalp (subseq #(a b c d) 0) #(a b c d))
+(equalp (subseq #(a b c d) 1) #(b c d))
+(equalp (subseq #(a b c d) 2) #(c d))
+(equalp (subseq #(a b c d) 3) #(d))
+(equalp (subseq #(a b c d) 4) #())
+(string= (subseq "0123" 0) "0123")
+(string= (subseq "0123" 1) "123")
+(string= (subseq "0123" 2) "23")
+(string= (subseq "0123" 3) "3")
+(string= (subseq "0123" 4) "")
+(equalp (subseq #*1010 0) #*1010)
+(equalp (subseq #*1010 1) #*010)
+(equalp (subseq #*1010 2) #*10)
+(equalp (subseq #*1010 3) #*0)
+(equalp (subseq #*1010 4) #*)
+
+(equal (subseq '(0 1 2 3) 0 4) '(0 1 2 3))
+(equal (subseq '(0 1 2 3) 0 nil) '(0 1 2 3))
+(let* ((list0 '(0 1 2 3))
+ (list (subseq list0 0 4)))
+ (and (not (eq list0 list))
+ (equal list0 list)))
+(let* ((list0 '(0 1 2 3))
+ (list (subseq list0 0 nil)))
+ (and (not (eq list0 list))
+ (equal list0 list)))
+(equal (subseq '(0 1 2 3) 1 3) '(1 2))
+(equal (subseq '(0 1 2 3) 2 2) '())
+(equal (subseq '(0 1 2 3) 0 0) '())
+(equal (subseq '(0 1 2 3) 1 1) '())
+(equal (subseq '(0 1 2 3) 2 2) '())
+(equal (subseq '(0 1 2 3) 3 3) '())
+(equal (subseq '(0 1 2 3) 4 4) '())
+
+(let ((list (list 0 1 2 3 4 5 6 7)))
+ (setf (subseq list 0) '(a b c d))
+ (equal list '(a b c d 4 5 6 7)))
+
+(let ((list (list 0 1 2 3)))
+ (setf (subseq list 0) '(a b c d))
+ (equal list '(a b c d)))
+
+(let ((list (list 0 1 2 3)))
+ (setf (subseq list 2) '(a b c d))
+ (equal list '(0 1 a b)))
+
+(let ((list (list 0 1 2 3)))
+ (setf (subseq list 2 nil) '(a b c d))
+ (equal list '(0 1 a b)))
+
+(let ((list (list 0 1 2 3)))
+ (setf (subseq list 1 3) '(a b c d))
+ (equal list '(0 a b 3)))
+
+(let ((list (list 0 1 2 3)))
+ (setf (subseq list 0) '())
+ (equal list '(0 1 2 3)))
+
+(let ((list '()))
+ (setf (subseq list 0) '(a b c d e))
+ (null list))
+
+(let ((list '(0 1 2 3)))
+ (setf (subseq list 0 0) '(a b c d e))
+ (equal list '(0 1 2 3)))
+
+(let ((list '(0 1 2 3)))
+ (setf (subseq list 1 1) '(a b c d e))
+ (equal list '(0 1 2 3)))
+
+(let ((list '(0 1 2 3)))
+ (setf (subseq list 2 2) '(a b c d e))
+ (equal list '(0 1 2 3)))
+
+(let ((list '(0 1 2 3)))
+ (setf (subseq list 3 3) '(a b c d e))
+ (equal list '(0 1 2 3)))
+
+(let ((list '(0 1 2 3)))
+ (setf (subseq list 4 4) '(a b c d e))
+ (equal list '(0 1 2 3)))
+
+
+
+(let ((list (list 0 1 2 3 4 5 6 7)))
+ (setf (subseq list 0) #(a b c d))
+ (equal list '(a b c d 4 5 6 7)))
+
+(let ((list (list 0 1 2 3)))
+ (setf (subseq list 0) #(a b c d))
+ (equal list '(a b c d)))
+
+(let ((list (list 0 1 2 3)))
+ (setf (subseq list 2) #(a b c d))
+ (equal list '(0 1 a b)))
+
+(let ((list (list 0 1 2 3)))
+ (setf (subseq list 2 nil) #(a b c d))
+ (equal list '(0 1 a b)))
+
+(let ((list (list 0 1 2 3)))
+ (setf (subseq list 1 3) #(a b c d))
+ (equal list '(0 a b 3)))
+
+(let ((list (list 0 1 2 3)))
+ (setf (subseq list 0) #())
+ (equal list '(0 1 2 3)))
+
+(let ((list (list 0 1 2 3 4 5 6 7)))
+ (setf (subseq list 0) "abcd")
+ (equal list '(#\a #\b #\c #\d 4 5 6 7)))
+
+(let ((list (list 0 1 2 3)))
+ (setf (subseq list 0) "abcd")
+ (equal list '(#\a #\b #\c #\d)))
+
+(let ((list (list 0 1 2 3)))
+ (setf (subseq list 2) "abcd")
+ (equal list '(0 1 #\a #\b)))
+
+(let ((list (list 0 1 2 3)))
+ (setf (subseq list 2 nil) "abcd")
+ (equal list '(0 1 #\a #\b)))
+
+(let ((list (list 0 1 2 3)))
+ (setf (subseq list 1 3) "abcd")
+ (equal list '(0 #\a #\b 3)))
+
+(let ((list (list 0 1 2 3)))
+ (setf (subseq list 0) "")
+ (equal list '(0 1 2 3)))
+
+
+(equalp (subseq #(0 1 2 3) 0 4) #(0 1 2 3))
+(equalp (subseq #(0 1 2 3) 0 nil) #(0 1 2 3))
+(let* ((vec0 #(0 1 2 3))
+ (vec (subseq vec0 0 4)))
+ (and (not (eq vec0 vec))
+ (equalp vec0 vec)))
+(let* ((vec0 #(0 1 2 3))
+ (vec (subseq vec0 0 nil)))
+ (and (not (eq vec0 vec))
+ (equalp vec0 vec)))
+(equalp (subseq #(0 1 2 3) 1 3) #(1 2))
+(equalp (subseq #(0 1 2 3) 2 2) #())
+(equalp (subseq #(0 1 2 3) 0 0) #())
+(equalp (subseq #(0 1 2 3) 1 1) #())
+(equalp (subseq #(0 1 2 3) 2 2) #())
+(equalp (subseq #(0 1 2 3) 3 3) #())
+(equalp (subseq #(0 1 2 3) 4 4) #())
+
+(let ((vec (vector 0 1 2 3 4 5 6 7)))
+ (setf (subseq vec 0) #(a b c d))
+ (equalp vec #(a b c d 4 5 6 7)))
+
+(let ((vec (vector 0 1 2 3)))
+ (setf (subseq vec 0) #(a b c d))
+ (equalp vec #(a b c d)))
+
+(let ((vec (vector 0 1 2 3)))
+ (setf (subseq vec 2) #(a b c d))
+ (equalp vec #(0 1 a b)))
+
+(let ((vec (vector 0 1 2 3)))
+ (setf (subseq vec 1 3) #(a b c d))
+ (equalp vec #(0 a b 3)))
+
+(let ((vec (vector 0 1 2 3)))
+ (setf (subseq vec 0) #())
+ (equalp vec #(0 1 2 3)))
+
+(let ((vec (vector)))
+ (setf (subseq vec 0) #(a b c d e))
+ (equalp vec #()))
+
+(let ((vec (vector 0 1 2 3)))
+ (setf (subseq vec 0 0) #(a b c d e))
+ (equalp vec #(0 1 2 3)))
+
+(let ((vec (vector 0 1 2 3)))
+ (setf (subseq vec 1 1) #(a b c d e))
+ (equalp vec #(0 1 2 3)))
+
+(let ((vec (vector 0 1 2 3)))
+ (setf (subseq vec 2 2) #(a b c d e))
+ (equalp vec #(0 1 2 3)))
+
+(let ((vec (vector 0 1 2 3)))
+ (setf (subseq vec 3 3) #(a b c d e))
+ (equalp vec #(0 1 2 3)))
+
+(let ((vec (vector 0 1 2 3)))
+ (setf (subseq vec 4 4) #(a b c d e))
+ (equalp vec #(0 1 2 3)))
+
+
+(let ((vec (vector 0 1 2 3 4 5 6 7)))
+ (setf (subseq vec 0) #(a b c d))
+ (equalp vec #(a b c d 4 5 6 7)))
+
+(let ((vec (vector 0 1 2 3)))
+ (setf (subseq vec 0) #(a b c d))
+ (equalp vec #(a b c d)))
+
+(let ((vec (vector 0 1 2 3)))
+ (setf (subseq vec 2) #(a b c d))
+ (equalp vec #(0 1 a b)))
+
+(let ((vec (vector 0 1 2 3)))
+ (setf (subseq vec 2 nil) #(a b c d))
+ (equalp vec #(0 1 a b)))
+
+(let ((vec (vector 0 1 2 3)))
+ (setf (subseq vec 1 3) #(a b c d))
+ (equalp vec #(0 a b 3)))
+
+(let ((vec (vector 0 1 2 3)))
+ (setf (subseq vec 0) #())
+ (equalp vec #(0 1 2 3)))
+
+(HANDLER-CASE (PROGN (MAP 'SYMBOL #'+ '(0 1) '(1 0)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (MAP 'HASH-TABLE #'+ '(0 1) '(1 0)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+
+(string= (map 'string #'(lambda (x y)
+ (char "01234567890ABCDEF" (mod (+ x y) 16)))
+ '(1 2 3 4)
+ '(10 9 8 7))
+ "AAAA")
+
+(let ((seq (list "lower" "UPPER" "" "123")))
+ (and (null (map nil #'nstring-upcase seq))
+ (equal seq '("LOWER" "UPPER" "" "123"))))
+
+(equal (map 'list #'- '(1 2 3 4)) '(-1 -2 -3 -4))
+
+(string= (map 'string
+ #'(lambda (x) (if (oddp x) #\1 #\0))
+ '(1 2 3 4))
+ "1010")
+
+
+
+(equal (map 'list '+ '(0 1) '(1 0)) '(1 1))
+(equal (map 'list '- '(0 1) '(1 0)) '(-1 1))
+
+(every 'null (list (map 'list #'+ '())
+ (map 'list #'+ '() '())
+ (map 'list #'+ '() '() '())
+ (map 'list #'+ '() '() '() '())
+ (map 'list #'+ '() '() '() '() '())))
+(every 'null (list (map 'list #'+ '())
+ (map 'list #'+ #() '())
+ (map 'list #'+ '() #() '())
+ (map 'list #'+ #() '() #() '())
+ (map 'list #'+ '() #() '() #() '())))
+
+(equal (map 'list #'+ '(0 1 2)) '(0 1 2))
+(equal (map 'list #'+ '(0 1 2) '(1 2 3)) '(1 3 5))
+(equal (map 'list #'+ '(0 1 2) '(1 2 3) '(2 3 4)) '(3 6 9))
+(equal (map 'list #'+ '(0 1 2) '(1 2 3) '(2 3 4) '(3 4 5)) '(6 10 14))
+
+(equal (map 'list #'+ '(1 2) '(1 2 3)) '(2 4))
+(equal (map 'list #'+ '(0 1 2) '(2 3) '(2 3 4)) '(4 7))
+(equal (map 'list #'+ '(0 1 2) '(1 2 3) '(2) '(3 4 5)) '(6))
+(equal (map 'list #'+ '(0 1 2) '(1 2 3) '(2 3 4) '(3 4 5) '()) '())
+
+(equal (map 'cons #'+ '(0 1 2) '(2 1 0)) '(2 2 2))
+(equal (map '(cons number cons) #'+ '(0 1 2) '(2 1 0)) '(2 2 2))
+(equal (map '(cons number (cons number *)) #'+ '(0 1 2) '(2 1 0)) '(2 2 2))
+(null (map 'null #'+ '()))
+
+
+(equalp (map 'vector #'+ #()) #())
+(equalp (map 'vector #'+ #() #()) #())
+(equalp (map 'vector #'+ #() #() #()) #())
+(equalp (map 'vector #'+ #() #() #() #()) #())
+(equalp (map 'vector #'+ #() #() #() #() #()) #())
+(equalp (map 'vector #'+ '() #()) #())
+(equalp (map 'vector #'+ '() #() "") #())
+
+(equalp (map 'vector #'+ '(0 1 2)) #(0 1 2))
+(equalp (map 'vector #'+ '(0 1 2) #(1 2 3)) #(1 3 5))
+(equalp (map 'vector #'+ #(0 1 2) '(1 2 3) #(2 3 4)) #(3 6 9))
+(equalp (map 'vector #'+ '(0 1 2) #(1 2 3) '(2 3 4) #(3 4 5)) #(6 10 14))
+
+(equalp (map 'vector #'+ '(1 2) '(1 2 3)) #(2 4))
+(equalp (map 'vector #'+ '(0 1 2) '(2 3) '(2 3 4)) #(4 7))
+(equalp (map 'vector #'+ '(0 1 2) '(1 2 3) '(2) '(3 4 5)) #(6))
+(equalp (map 'vector #'+ '(0 1 2) '(1 2 3) '(2 3 4) '(3 4 5) '()) #())
+
+(equalp (map 'vector #'+ #(1 2) #(1 2 3)) #(2 4))
+(equalp (map 'vector #'+ #(0 1 2) #(2 3) #(2 3 4)) #(4 7))
+(equalp (map 'vector #'+ #(0 1 2) '(1 2 3) #(2) '(3 4 5)) #(6))
+(equalp (map 'vector #'+ '(0 1 2) #(1 2 3) '(2 3 4) '(3 4 5) '()) #())
+
+(string= (map 'string #'(lambda (&rest rest) (char-upcase (car rest))) "") "")
+(string= (map 'string #'(lambda (&rest rest) (char-upcase (car rest))) "" "")
+ "")
+(string= (map 'string
+ #'(lambda (&rest rest) (char-upcase (car rest)))
+ "" "" "")
+ "")
+(string= (map 'string
+ #'(lambda (&rest rest) (char-upcase (car rest)))
+ "" "" "" "")
+ "")
+(string= (map 'string
+ #'(lambda (&rest rest) (char-upcase (car rest)))
+ "" "" "" "" "")
+ "")
+
+(string= (map 'string #'(lambda (&rest rest) (char-upcase (car rest))) "") "")
+(string= (map 'string #'(lambda (&rest rest) (char-upcase (car rest))) "" '())
+ "")
+(string= (map 'string #'(lambda (&rest rest) (char-upcase (car rest)))
+ "" #() '()) "")
+(string= (map 'string #'(lambda (&rest rest) (char-upcase (car rest)))
+ '() '() "" "") "")
+(string= (map 'string #'(lambda (&rest rest) (char-upcase (car rest)))
+ #() #() #() #() #()) "")
+
+
+(string= (map 'string
+ #'(lambda (a b) (if (char< a b) b a))
+ "axbycz"
+ "xaybzc")
+ "xxyyzz")
+
+(string= (map 'string
+ #'(lambda (a b) (if (char< a b) b a))
+ "axbycz"
+ "xayb")
+ "xxyy")
+
+(string= (map 'string
+ #'(lambda (&rest rest) (if (zerop (apply #'logand rest)) #\0 #\1))
+ '(0 1 0 1)
+ #*1010101)
+ "0000")
+
+(string= (map 'string
+ #'(lambda (&rest rest) (if (zerop (apply #'logand rest)) #\0 #\1))
+ #*1111
+ #*1010101
+ #*001)
+ "001")
+
+(string= (map 'string
+ #'(lambda (&rest rest) (if (zerop (apply #'logand rest)) #\0 #\1))
+ #*1111
+ #*1010101
+ #*0)
+ "0")
+
+(string= (map 'string
+ #'(lambda (&rest rest) (if (zerop (apply #'logand rest)) #\0 #\1))
+ #*1111
+ #*1000
+ #*1011)
+ "1000")
+
+
+(let ((list ()))
+ (and (null (map nil
+ #'(lambda (&rest rest)
+ (setq list (cons (apply #'+ rest) list)))
+ '(0 1 2 3)
+ '(1 2 3 4)))
+ (equal list '(7 5 3 1))))
+
+(let ((list ()))
+ (and (null (map nil
+ #'(lambda (&rest rest)
+ (setq list (cons (apply #'+ rest) list)))
+ '(0 1 2 3)
+ '(1 2 3 4)
+ '(2 3 4 5)))
+ (equal list (reverse '(3 6 9 12)))))
+
+(let ((list ()))
+ (and (null (map nil
+ #'(lambda (&rest rest)
+ (setq list (cons (apply #'+ rest) list)))
+ '(0 1 2 3)
+ '(1)
+ '(2 3 4 5)))
+ (equal list '(3))))
+
+
+
+(equalp (map '(vector * 2) #'+ #*01 #*10) #(1 1))
+(equalp (map '(simple-vector 2) #'+ #*01 #*10) #(1 1))
+(equalp (map '(array * 1) #'+ #*01 #*10) #(1 1))
+(equalp (map '(simple-array * 1) #'+ #*01 #*10) #(1 1))
+(equalp (map '(array * (2)) #'+ #*01 #*10) #(1 1))
+(equalp (map '(simple-array * (2)) #'+ #*01 #*10) #(1 1))
+(string= (map 'string #'char-upcase "abc") "ABC")
+(string= (map 'base-string #'char-upcase "abc") "ABC")
+(string= (map 'simple-string #'char-upcase "abc") "ABC")
+(string= (map '(string 3) #'char-upcase "abc") "ABC")
+(string= (map '(base-string 3) #'char-upcase "abc") "ABC")
+(string= (map '(simple-string 3) #'char-upcase "abc") "ABC")
+(string= (map '(vector character) #'char-upcase "abc") "ABC")
+(string= (map '(vector character 3) #'char-upcase "abc") "ABC")
+(string= (map '(vector base-char) #'char-upcase "abc") "ABC")
+(string= (map '(vector base-char 3) #'char-upcase "abc") "ABC")
+(string= (map '(vector standard-char) #'char-upcase "abc") "ABC")
+(string= (map '(vector standard-char 3) #'char-upcase "abc") "ABC")
+(string= (map '(array character 1) #'char-upcase "abc") "ABC")
+(string= (map '(array character (3)) #'char-upcase "abc") "ABC")
+(string= (map '(array base-char 1) #'char-upcase "abc") "ABC")
+(string= (map '(array base-char (3)) #'char-upcase "abc") "ABC")
+(string= (map '(array standard-char 1) #'char-upcase "abc") "ABC")
+(string= (map '(array standard-char (3)) #'char-upcase "abc") "ABC")
+(equalp (map 'bit-vector #'logand '(0 1 0 1) #*1010) #*0000)
+(equalp (map 'simple-bit-vector #'logand '(0 1 0 1) #*1010) #*0000)
+(equalp (map '(bit-vector 4) #'logand '(0 1 0 1) #*1010) #*0000)
+(equalp (map '(simple-bit-vector 4) #'logand '(0 1 0 1) #*1010) #*0000)
+(equalp (map '(array bit 1) #'logand '(0 1 0 1) #*1010) #*0000)
+(equalp (map '(array bit (4)) #'logand '(0 1 0 1) #*1010) #*0000)
+(equalp (map '(simple-array bit 1) #'logand '(0 1 0 1) #*1010) #*0000)
+(equalp (map '(simple-array bit (4)) #'logand '(0 1 0 1) #*1010) #*0000)
+(equalp (map '(vector bit) #'logand '(0 1 0 1) #*1010) #*0000)
+(equalp (map '(vector bit 4) #'logand '(0 1 0 1) #*1010) #*0000)
+
+(equal (map 'list #'+ '(0 1 2 3) #(3 2 1 0) #*0101) '(3 4 3 4))
+(equalp (map 'vector #'+ '(0 1 2 3) #(3 2 1 0) #*0101) #(3 4 3 4))
+
+
+
+(let ((a (list 1 2 3 4))
+ (b (list 10 10 10 10)))
+ (and (equal (map-into a #'+ a b) '(11 12 13 14))
+ (equal a '(11 12 13 14))
+ (equal b '(10 10 10 10))))
+(let ((a '(11 12 13 14))
+ (k '(one two three)))
+ (equal (map-into a #'cons k a) '((ONE . 11) (TWO . 12) (THREE . 13) 14)))
+
+
+(null (map-into nil 'identity))
+(null (map-into nil #'identity))
+(null (map-into nil #'identity '()))
+(null (map-into nil #'identity '(0 1 2) '(9 8 7)))
+
+
+(let ((list (list 0 1 2)))
+ (and (eq (map-into list 'identity) list)
+ (equal list '(0 1 2))))
+(let ((list (list 0 1 2)))
+ (and (eq (map-into list 'identity '()) list)
+ (equal list '(0 1 2))))
+
+(let ((vec (vector 0 1 2)))
+ (and (eq (map-into vec 'identity) vec)
+ (equalp vec #(0 1 2))))
+(let ((vec (vector 0 1 2)))
+ (and (eq (map-into vec 'identity #()) vec)
+ (equalp vec #(0 1 2))))
+(let ((vec (vector 0 1 2)))
+ (and (eq (map-into vec #'+ #() '() #()) vec)
+ (equalp vec #(0 1 2))))
+
+
+(equal (map-into (list nil nil) '+ '(0 1) '(1 0)) '(1 1))
+(equal (map-into (list nil nil) '- '(0 1) '(1 0)) '(-1 1))
+(let ((list (make-list 3 :initial-element nil)))
+ (and (eq (map-into list #'+ '(0 1 2)) list)
+ (equal list '(0 1 2))))
+(let ((list (make-list 3 :initial-element nil)))
+ (and (eq (map-into list #'+ '(0 1 2) '(1 2 3)) list)
+ (equal list '(1 3 5))))
+(let ((list (make-list 3 :initial-element nil)))
+ (and (eq (map-into list #'+ '(0 1 2) '(1 2 3) '(2 3 4)) list)
+ (equal list '(3 6 9))))
+
+(let ((list (make-list 3 :initial-element nil)))
+ (and (eq (map-into list #'+ '(1 2) '(1 2 3)) list)
+ (equal list '(2 4 nil))))
+(let ((list (make-list 1 :initial-element nil)))
+ (and (eq (map-into list #'+ '(1 2 3) '(1 2 3)) list)
+ (equal list '(2))))
+(let ((list (make-list 3 :initial-element nil)))
+ (and (eq (map-into list #'+ '(1 2 3 4) '(1 2 3) '(0)) list)
+ (equal list '(2 nil nil))))
+
+
+(let ((vec (make-sequence 'vector 3 :initial-element nil)))
+ (and (eq (map-into vec #'+ '(0 1 2)) vec)
+ (equalp vec #(0 1 2))))
+(let ((vec (make-sequence 'vector 3 :initial-element nil)))
+ (and (eq (map-into vec #'+ '(0 1 2) #(1 2 3)) vec)
+ (equalp vec #(1 3 5))))
+(let ((vec (make-sequence 'vector 3 :initial-element nil)))
+ (and (eq (map-into vec #'+ '(0 1 2) '(1 2 3) #(2 3 4)) vec)
+ (equalp vec #(3 6 9))))
+
+(let ((vec (make-sequence 'vector 3 :initial-element nil)))
+ (and (eq (map-into vec #'+ '(1 2) #(1 2 3)) vec)
+ (equalp vec #(2 4 nil))))
+(let ((vec (make-sequence 'vector 1 :initial-element nil)))
+ (and (eq (map-into vec #'+ '(1 2) #(1 2 3)) vec)
+ (equalp vec #(2))))
+(let ((vec (make-sequence 'vector 3 :initial-element nil)))
+ (and (eq (map-into vec #'+ '(1 2 3 4) #(1 2 3) '(0)) vec)
+ (equalp vec #(2 nil nil))))
+
+
+(let ((str (make-array 10
+ :element-type 'character
+ :initial-contents "0123456789"
+ :fill-pointer 3)))
+ (and (eq (map-into str #'char-upcase "abcde") str)
+ (string= str "ABCDE")
+ (= (fill-pointer str) 5)))
+
+(let ((vec (make-array 5
+ :initial-contents #(0 1 2 3 4)
+ :fill-pointer 3)))
+ (and (eq (map-into vec #'+ '(0 1 2 3 4 5 6 7 8 9) '(9 8 7 6 5 4 3 2 1 0)) vec)
+ (equalp vec #(9 9 9 9 9))))
+
+(let ((vec (make-array 5
+ :initial-contents #(0 1 2 3 4)
+ :fill-pointer 3)))
+ (and (eq (map-into vec #'+ '(0 1) '(9 8 7 6 5 4 3 2 1 0)) vec)
+ (equalp vec #(9 9))))
+
+
+(let ((vec (make-array 5
+ :element-type 'bit
+ :initial-contents #(1 1 1 1 1)
+ :fill-pointer 3)))
+ (and (eq (map-into vec #'logand '(0 1) '(1 0 1 0 1 0)) vec)
+ (equalp vec #*00)))
+
+
+(eql (reduce #'* '(1 2 3 4 5)) 120)
+(equal (reduce #'append '((1) (2)) :initial-value '(i n i t)) '(I N I T 1 2))
+(equal (reduce #'append '((1) (2))
+ :from-end t
+ :initial-value '(i n i t))
+ '(1 2 I N I T))
+(eql (reduce #'- '(1 2 3 4)) -8)
+(eql (reduce #'- '(1 2 3 4) :from-end t) -2)
+(eql (reduce #'+ '()) 0)
+(eql (reduce #'+ '(3)) 3)
+(eq (reduce #'+ '(foo)) 'foo)
+(equal (reduce #'list '(1 2 3 4)) '(((1 2) 3) 4))
+(equal (reduce #'list '(1 2 3 4) :from-end t) '(1 (2 (3 4))))
+(equal (reduce #'list '(1 2 3 4) :initial-value 'foo) '((((foo 1) 2) 3) 4))
+(equal (reduce #'list '(1 2 3 4) :from-end t :initial-value 'foo)
+ '(1 (2 (3 (4 foo)))))
+
+
+(equal (reduce #'list '(0 1 2 3)) '(((0 1) 2) 3))
+(equal (reduce #'list '(0 1 2 3) :start 1) '((1 2) 3))
+(equal (reduce #'list '(0 1 2 3) :start 1 :end nil) '((1 2) 3))
+(equal (reduce #'list '(0 1 2 3) :start 2) '(2 3))
+(eq (reduce #'list '(0 1 2 3) :start 0 :end 0) '())
+(eq (reduce #'list '(0 1 2 3) :start 0 :end 0 :initial-value 'initial-value)
+ 'initial-value)
+(eq (reduce #'list '(0 1 2 3) :start 2 :end 2) '())
+(eq (reduce #'list '(0 1 2 3) :start 2 :end 2 :initial-value 'initial-value)
+ 'initial-value)
+(eq (reduce #'list '(0 1 2 3) :start 4 :end 4) '())
+(eq (reduce #'list '(0 1 2 3) :start 4 :end 4 :initial-value 'initial-value)
+ 'initial-value)
+(eql (reduce #'list '(0 1 2 3) :start 2 :end 3) 2)
+(equal (reduce #'list '(0 1 2 3) :start 2 :end 3 :initial-value 'initial-value)
+ '(initial-value 2))
+(eql (reduce #'+ '(0 1 2 3 4 5 6 7 8 9)) 45)
+(eql (reduce #'- '(0 1 2 3 4 5 6 7 8 9)) -45)
+(eql (reduce #'- '(0 1 2 3 4 5 6 7 8 9) :from-end t) -5)
+(equal (reduce #'list '(0 1 2 3) :initial-value 'initial-value)
+ '((((initial-value 0) 1) 2) 3))
+(equal (reduce #'list '(0 1 2 3) :from-end t) '(0 (1 (2 3))))
+(equal (reduce #'list '((1) (2) (3) (4)) :key #'car) '(((1 2) 3) 4))
+(equal (reduce #'list '((1) (2) (3) (4)) :key #'car :from-end nil)
+ '(((1 2) 3) 4))
+(equal (reduce #'list '((1) (2) (3) (4)) :key #'car :initial-value 0)
+ '((((0 1) 2) 3) 4))
+(equal (reduce #'list '((1) (2) (3) (4)) :key #'car :from-end t)
+ '(1 (2 (3 4))))
+(equal (reduce #'list '((1) (2) (3) (4))
+ :key #'car :from-end t :initial-value 5)
+ '(1 (2 (3 (4 5)))))
+
+
+
+
+(equal (reduce #'list #(0 1 2 3)) '(((0 1) 2) 3))
+(equal (reduce #'list #(0 1 2 3) :start 1) '((1 2) 3))
+(equal (reduce #'list #(0 1 2 3) :start 1 :end nil) '((1 2) 3))
+(equal (reduce #'list #(0 1 2 3) :start 2) '(2 3))
+(eq (reduce #'list #(0 1 2 3) :start 0 :end 0) '())
+(eq (reduce #'list #(0 1 2 3) :start 0 :end 0 :initial-value 'initial-value)
+ 'initial-value)
+(eq (reduce #'list #(0 1 2 3) :start 2 :end 2) '())
+(eq (reduce #'list #(0 1 2 3) :start 2 :end 2 :initial-value 'initial-value)
+ 'initial-value)
+(eq (reduce #'list #(0 1 2 3) :start 4 :end 4) '())
+(eq (reduce #'list #(0 1 2 3) :start 4 :end 4 :initial-value 'initial-value)
+ 'initial-value)
+(eql (reduce #'list #(0 1 2 3) :start 2 :end 3) 2)
+(equal (reduce #'list #(0 1 2 3) :start 2 :end 3 :initial-value 'initial-value)
+ '(initial-value 2))
+(eql (reduce #'+ #(0 1 2 3 4 5 6 7 8 9)) 45)
+(eql (reduce #'- #(0 1 2 3 4 5 6 7 8 9)) -45)
+(eql (reduce #'- #(0 1 2 3 4 5 6 7 8 9) :from-end t) -5)
+(equal (reduce #'list #(0 1 2 3) :initial-value 'initial-value)
+ '((((initial-value 0) 1) 2) 3))
+(equal (reduce #'list #(0 1 2 3) :from-end t) '(0 (1 (2 3))))
+(equal (reduce #'list #((1) (2) (3) (4)) :key #'car) '(((1 2) 3) 4))
+(equal (reduce #'list #((1) (2) (3) (4)) :key #'car :from-end nil)
+ '(((1 2) 3) 4))
+(equal (reduce #'list #((1) (2) (3) (4)) :key #'car :initial-value 0)
+ '((((0 1) 2) 3) 4))
+(equal (reduce #'list #((1) (2) (3) (4)) :key #'car :from-end t)
+ '(1 (2 (3 4))))
+(equal (reduce #'list #((1) (2) (3) (4))
+ :key #'car :from-end t :initial-value 5)
+ '(1 (2 (3 (4 5)))))
+
+(string= (reduce #'(lambda (&rest rest)
+ (concatenate 'string
+ (string (car rest))
+ (string (char-upcase (cadr rest)))))
+ "abcdefg"
+ :initial-value #\Z)
+ "ZABCDEFG")
+
+
+(eql (count #\a "how many A's are there in here?") 2)
+(eql (count-if-not #'oddp '((1) (2) (3) (4)) :key #'car) 2)
+(eql (count-if #'upper-case-p "The Crying of Lot 49" :start 4) 2)
+(eql (count #\a (concatenate 'list "how many A's are there in here?")) 2)
+(eql (count-if #'alpha-char-p "-a-b-c-0-1-2-3-4-") 3)
+(eql (count-if #'alphanumericp "-a-b-c-0-1-2-3-4-") 8)
+
+(eql (count 'nil '(t nil t nil t nil)) 3)
+(eql (count 'nil #(t nil t nil t nil)) 3)
+(zerop (count 9 '(0 1 2 3 4)))
+(zerop (count 'a '(0 1 2 3 4)))
+(eql (count 0 '(0 0 0 0 0) :start 1) 4)
+(eql (count 0 '(0 0 0 0 0) :start 1 :end nil) 4)
+(eql (count 0 '(0 0 0 0 0) :start 2) 3)
+(zerop (count 0 '(0 0 0 0) :start 0 :end 0))
+(zerop (count 0 '(0 0 0 0) :start 2 :end 2))
+(zerop (count 0 '(0 0 0 0) :start 4 :end 4))
+(eql (count 0 '(0 0 0 0) :start 2 :end 3) 1)
+(eql (count #\a "abcABC" :test #'equalp) 2)
+(eql (count #\a "abcABC" :test #'char-equal) 2)
+(eql (count '(a) '((x) (y) (z) (a) (b) (c)) :test #'equalp) 1)
+(eql (count #\a "abcABC" :test-not (complement #'equalp)) 2)
+(eql (count #\a "abcABC" :test-not (complement #'char-equal)) 2)
+(eql (count '(a) '((x) (y) (z) (a) (b) (c)) :test-not (complement #'equalp)) 1)
+(eql (count 'a '((x) (y) (z) (a) (b) (c)) :key #'car :test #'eq) 1)
+(eql (count 'nil '((x . x) (y) (z . z) (a) (b . b) (c)) :key #'cdr :test #'eq)
+ 3)
+(let ((list nil))
+ (and (eql (count 'a '(a b c d)
+ :test #'(lambda (a b) (setq list (cons b list)) (eq a b)))
+ 1)
+ (equal list '(d c b a))))
+
+(let ((list nil))
+ (and (eql (count 'a '(a b c d)
+ :test #'(lambda (a b) (setq list (cons b list)) (eq a b))
+ :from-end t)
+ 1)
+ (equal list '(a b c d))))
+
+
+(zerop (count 9 #(0 1 2 3 4)))
+(zerop (count 'a #(0 1 2 3 4)))
+(eql (count 0 #(0 0 0 0 0) :start 1) 4)
+(eql (count 0 #(0 0 0 0 0) :start 1 :end nil) 4)
+(eql (count 0 #(0 0 0 0 0) :start 2) 3)
+(zerop (count 0 #(0 0 0 0) :start 0 :end 0))
+(zerop (count 0 #(0 0 0 0) :start 2 :end 2))
+(zerop (count 0 #(0 0 0 0) :start 4 :end 4))
+(eql (count 0 #(0 0 0 0) :start 2 :end 3) 1)
+(eql (count '(a) #((x) (y) (z) (a) (b) (c)) :test #'equalp) 1)
+(eql (count '(a) #((x) (y) (z) (a) (b) (c)) :test-not (complement #'equalp)) 1)
+(eql (count 'a #((x) (y) (z) (a) (b) (c)) :key #'car :test #'eq) 1)
+(eql (count 'nil #((x . x) (y) (z . z) (a) (b . b) (c)) :key #'cdr :test #'eq)
+ 3)
+(let ((list nil))
+ (and (eql (count 'a #(a b c d)
+ :test #'(lambda (a b) (setq list (cons b list)) (eq a b)))
+ 1)
+ (equal list '(d c b a))))
+
+(let ((list nil))
+ (and (eql (count 'a #(a b c d)
+ :test #'(lambda (a b) (setq list (cons b list)) (eq a b))
+ :from-end t)
+ 1)
+ (equal list '(a b c d))))
+
+
+(eql (count-if #'null '(t nil t nil t nil)) 3)
+(zerop (count-if #'(lambda (x) (eql x 9)) #(0 1 2 3 4)))
+(zerop (count-if #'(lambda (a) (eq 'x a)) #(0 1 2 3 4)))
+(eql (count-if #'zerop '(0 0 0 0 0) :start 1) 4)
+(eql (count-if #'zerop '(0 0 0 0 0) :start 1 :end nil) 4)
+(eql (count-if #'zerop '(0 0 0 0 0) :start 2) 3)
+(zerop (count-if #'zerop '(0 0 0 0) :start 0 :end 0))
+(zerop (count-if #'zerop '(0 0 0 0) :start 2 :end 2))
+(zerop (count-if #'zerop '(0 0 0 0) :start 4 :end 4))
+(eql (count-if #'zerop '(0 0 0 0) :start 2 :end 3) 1)
+(eql (count-if #'(lambda (x) (equalp #\a x)) "abcABC") 2)
+(eql (count-if #'(lambda (x) (char-equal #\a x)) "abcABC") 2)
+(eql (count-if #'(lambda (x) (equal x '(a)))
+ '((x) (y) (z) (a) (b) (c))) 1)
+(eql (count-if #'(lambda (x) (eq x 'a))
+ '((x) (y) (z) (a) (b) (c)) :key #'car)
+ 1)
+(eql (count-if 'null '((x . x) (y) (z . z) (a) (b . b) (c)) :key #'cdr)
+ 3)
+(eql (count-if #'(lambda (x) (equal x '(a)))
+ '((x) (y) (z) (a) (b) (c)))
+ 1)
+(eql (count-if #'(lambda (x) (eq x 'a)) '((x) (y) (z) (a) (b) (c)) :key #'car)
+ 1)
+(eql (count-if #'null '((x . x) (y) (z . z) (a) (b . b) (c)) :key #'cdr)
+ 3)
+(let ((list nil))
+ (and (eql (count-if #'(lambda (x) (setq list (cons x list)) (eq x 'a))
+ '(a b c d))
+ 1)
+ (equal list '(d c b a))))
+(let ((list nil))
+ (and (eql (count-if #'(lambda (x) (setq list (cons x list)) (eq x 'a))
+ '(a b c d)
+ :from-end t)
+ 1)
+ (equal list '(a b c d))))
+(eql (count-if #'null #(t nil t nil t nil)) 3)
+(eql (count-if #'zerop #(0 0 0 0 0) :start 1) 4)
+(eql (count-if #'zerop #(0 0 0 0 0) :start 1 :end nil) 4)
+(eql (count-if #'zerop #(0 0 0 0 0) :start 2) 3)
+(zerop (count-if #'zerop #(0 0 0 0) :start 0 :end 0))
+(zerop (count-if #'zerop #(0 0 0 0) :start 2 :end 2))
+(zerop (count-if #'zerop #(0 0 0 0) :start 4 :end 4))
+(eql (count-if #'zerop #(0 0 0 0) :start 2 :end 3) 1)
+(eql (count-if #'(lambda (x) (equal x '(a)))
+ #((x) (y) (z) (a) (b) (c))) 1)
+(eql (count-if #'(lambda (x) (eq x 'a))
+ #((x) (y) (z) (a) (b) (c)) :key #'car)
+ 1)
+(eql (count-if #'null #((x . x) (y) (z . z) (a) (b . b) (c)) :key #'cdr)
+ 3)
+(eql (count-if #'(lambda (x) (equal x '(a)))
+ #((x) (y) (z) (a) (b) (c)))
+ 1)
+(eql (count-if #'(lambda (x) (eq x 'a)) #((x) (y) (z) (a) (b) (c)) :key #'car)
+ 1)
+(eql (count-if #'null #((x . x) (y) (z . z) (a) (b . b) (c)) :key #'cdr)
+ 3)
+(let ((list nil))
+ (and (eql (count-if #'(lambda (x) (setq list (cons x list)) (eq x 'a))
+ #(a b c d))
+ 1)
+ (equal list '(d c b a))))
+(let ((list nil))
+ (and (eql (count-if #'(lambda (x) (setq list (cons x list)) (eq x 'a))
+ #(a b c d)
+ :from-end t)
+ 1)
+ (equal list '(a b c d))))
+
+
+
+(eql (count-if-not (complement #'null) '(t nil t nil t nil)) 3)
+(zerop (count-if-not #'(lambda (x) (not (eql x 9))) #(0 1 2 3 4)))
+(zerop (count-if-not #'(lambda (a) (not (eq 'x a))) #(0 1 2 3 4)))
+(eql (count-if-not (complement #'zerop) '(0 0 0 0 0) :start 1) 4)
+(eql (count-if-not (complement #'zerop) '(0 0 0 0 0) :start 1 :end nil) 4)
+(eql (count-if-not (complement #'zerop) '(0 0 0 0 0) :start 2) 3)
+(zerop (count-if-not (complement #'zerop) '(0 0 0 0) :start 0 :end 0))
+(zerop (count-if-not (complement #'zerop) '(0 0 0 0) :start 2 :end 2))
+(zerop (count-if-not (complement #'zerop) '(0 0 0 0) :start 4 :end 4))
+(eql (count-if-not (complement #'zerop) '(0 0 0 0) :start 2 :end 3) 1)
+(eql (count-if-not #'(lambda (x) (not (equalp #\a x))) "abcABC") 2)
+(eql (count-if-not #'(lambda (x) (not (char-equal #\a x))) "abcABC") 2)
+(eql (count-if-not #'(lambda (x) (not (equal x '(a))))
+ '((x) (y) (z) (a) (b) (c))) 1)
+(eql (count-if-not #'(lambda (x) (not (eq x 'a)))
+ '((x) (y) (z) (a) (b) (c)) :key #'car)
+ 1)
+(eql (count-if-not (complement #'null)
+ '((x . x) (y) (z . z) (a) (b . b) (c)) :key #'cdr)
+ 3)
+(eql (count-if-not #'(lambda (x) (not (equal x '(a))))
+ '((x) (y) (z) (a) (b) (c)))
+ 1)
+(eql (count-if-not #'(lambda (x) (not (eq x 'a)))
+ '((x) (y) (z) (a) (b) (c)) :key #'car)
+ 1)
+(eql (count-if-not (complement #'null)
+ '((x . x) (y) (z . z) (a) (b . b) (c)) :key #'cdr)
+ 3)
+(let ((list nil))
+ (and (eql (count-if-not #'(lambda (x)
+ (setq list (cons x list))
+ (not (eq x 'a)))
+ '(a b c d))
+ 1)
+ (equal list '(d c b a))))
+(let ((list nil))
+ (and (eql (count-if-not #'(lambda (x)
+ (setq list (cons x list))
+ (not (eq x 'a)))
+ '(a b c d)
+ :from-end t)
+ 1)
+ (equal list '(a b c d))))
+(eql (count-if-not (complement #'null) #(t nil t nil t nil)) 3)
+(eql (count-if-not (complement #'zerop) #(0 0 0 0 0) :start 1) 4)
+(eql (count-if-not (complement #'zerop) #(0 0 0 0 0) :start 1 :end nil) 4)
+(eql (count-if-not (complement #'zerop) #(0 0 0 0 0) :start 2) 3)
+(zerop (count-if-not (complement #'zerop) #(0 0 0 0) :start 0 :end 0))
+(zerop (count-if-not (complement #'zerop) #(0 0 0 0) :start 2 :end 2))
+(zerop (count-if-not (complement #'zerop) #(0 0 0 0) :start 4 :end 4))
+(eql (count-if-not (complement #'zerop) #(0 0 0 0) :start 2 :end 3) 1)
+(eql (count-if-not #'(lambda (x) (not (equal x '(a))))
+ #((x) (y) (z) (a) (b) (c))) 1)
+(eql (count-if-not #'(lambda (x) (not (eq x 'a)))
+ #((x) (y) (z) (a) (b) (c)) :key #'car)
+ 1)
+(eql (count-if-not (complement #'null)
+ #((x . x) (y) (z . z) (a) (b . b) (c)) :key #'cdr)
+ 3)
+(eql (count-if-not #'(lambda (x) (not (equal x '(a))))
+ #((x) (y) (z) (a) (b) (c)))
+ 1)
+(eql (count-if-not #'(lambda (x) (not (eq x 'a)))
+ #((x) (y) (z) (a) (b) (c)) :key #'car)
+ 1)
+(eql (count-if-not (complement #'null)
+ #((x . x) (y) (z . z) (a) (b . b) (c)) :key #'cdr)
+ 3)
+(let ((list nil))
+ (and (eql (count-if-not #'(lambda (x)
+ (setq list (cons x list))
+ (not (eq x 'a)))
+ #(a b c d))
+ 1)
+ (equal list '(d c b a))))
+(let ((list nil))
+ (and (eql (count-if-not #'(lambda (x)
+ (setq list (cons x list))
+ (not (eq x 'a)))
+ #(a b c d)
+ :from-end t)
+ 1)
+ (equal list '(a b c d))))
+
+
+(null (reverse nil))
+(string= (reverse "") "")
+(equalp (reverse #*) #*)
+(equalp (reverse #()) #())
+(equal (reverse '(0 1 2 3)) '(3 2 1 0))
+(string= (reverse "0123") "3210")
+(equalp (reverse #*1100) #*0011)
+(equalp (reverse #(a b c d)) #(d c b a))
+
+(null (nreverse nil))
+(string= (nreverse (copy-seq "")) "")
+(equalp (nreverse (copy-seq #*)) #*)
+(equalp (nreverse (copy-seq #())) #())
+(equal (nreverse (list 0 1 2 3)) '(3 2 1 0))
+(string= (nreverse (copy-seq "0123")) "3210")
+(equalp (reverse (copy-seq #*1100)) #*0011)
+(equalp (reverse (copy-seq #(a b c d))) #(d c b a))
+
+
+
+(char= (find #\d "edcba" :test #'char>) #\c)
+(eql (find-if #'oddp '(1 2 3 4 5) :end 3 :from-end t) 3)
+(null (find-if-not #'complexp
+ '#(3.5 2 #C(1.0 0.0) #C(0.0 1.0))
+ :start 2))
+
+
+(eq (find 'a '(a b c)) 'a)
+(eq (find 'b '(a b c)) 'b)
+(eq (find 'c '(a b c)) 'c)
+(null (find 'x '(a b c)))
+(null (find 'a '(a b c) :start 1))
+(null (find 'b '(a b c) :start 2))
+(null (find 'c '(a b c) :start 3))
+(null (find 'a '(a b c) :start 0 :end 0))
+(null (find 'a '(a b c) :start 0 :end 0 :from-end t))
+(null (find 'a '(a b c) :start 1 :end 1))
+(null (find 'a '(a b c) :start 1 :end 1 :from-end t))
+(null (find 'a '(a b c) :start 2 :end 2))
+(null (find 'a '(a b c) :start 2 :end 2 :from-end t))
+(null (find 'a '(a b c) :start 3 :end 3))
+(null (find 'a '(a b c) :start 3 :end 3 :from-end t))
+(eq (find 'a '(a b c) :end nil) 'a)
+(eq (find 'b '(a b c) :end nil) 'b)
+(eq (find 'c '(a b c) :end nil) 'c)
+(eq (find 'a '(a b c) :end 1) 'a)
+(eq (find 'b '(a b c) :end 2) 'b)
+(eq (find 'c '(a b c) :end 3) 'c)
+(null (find 'a '(a b c) :end 0))
+(null (find 'b '(a b c) :end 1))
+(null (find 'c '(a b c) :end 2))
+
+(null (find 'a '((a) (b) (c))))
+(equal (find 'a '((a) (b) (c)) :key #'car) '(a))
+(equal (find 'b '((a) (b) (c)) :key #'car) '(b))
+(equal (find 'c '((a) (b) (c)) :key #'car) '(c))
+(null (find 'z '((a) (b) (c)) :key #'car))
+(let ((list '((a) (b) (c))))
+ (and (eq (find 'a list :key #'car) (car list))
+ (eq (find 'b list :key #'car) (cadr list))
+ (eq (find 'c list :key #'car) (caddr list))
+ (null (find 'z list :key #'car))))
+(null (find '(a) '((a) (b) (c))))
+(equal (find '(a) '((a) (b) (c)) :test #'equal) '(a))
+(null (find '("a") '(("a") ("b") ("c"))))
+(null (find '("a") '(("A") ("B") ("c")) :test #'equal))
+(equal (find '("a") '(("A") ("B") ("c")) :test #'equalp) '("A"))
+(eq (find 'nil '(first second third) :test (constantly t)) 'first)
+(eql (find 3 '(0 1 2 3 4 5)) 3)
+(eql (find 3 '(0 1 2 3 4 5) :test #'<) 4)
+(eql (find 3 '(0 1 2 3 4 5) :test #'>) 0)
+
+(equal (find '(a) '((a) (b) (c)) :test-not (complement #'equal)) '(a))
+(null (find '("a") '(("A") ("B") ("c")) :test-not (complement #'equal)))
+(equal (find '("a") '(("A") ("B") ("c")) :test-not (complement #'equalp))
+ '("A"))
+(eq (find 'nil '(first second third) :test-not (constantly nil)) 'first)
+(eql (find 3 '(0 1 2 3 4 5) :test-not #'>=) 4)
+(eql (find 3 '(0 1 2 3 4 5) :test-not #'<=) 0)
+
+(equal (find 'a '((a) (b) (c) (a a) (b b) (c c)) :key #'car)
+ '(a))
+(equal (find 'a '((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t)
+ '(a a))
+(equal (find 'b '((a) (b) (c) (a a) (b b) (c c)) :key #'car)
+ '(b))
+(equal (find 'b '((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t)
+ '(b b))
+(equal (find 'c '((a) (b) (c) (a a) (b b) (c c)) :key #'car)
+ '(c))
+(equal (find 'c '((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t)
+ '(c c))
+(null (find 'z '((a) (b) (c) (a a) (b b) (c c)) :key #'car))
+(null (find 'z '((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t))
+
+(equal (find 'a '((a) (b) (c) (a a) (b b) (c c) (a a a))
+ :key #'car
+ :from-end t)
+ '(a a a))
+(equal (find 'a '((a) (b) (c) (a a) (b b) (c c) (a a a))
+ :key #'car
+ :from-end t
+ :end nil)
+ '(a a a))
+(equal (find 'a '((a) (b) (c) (a a) (b b) (c c) (a a a))
+ :key #'car
+ :from-end t
+ :end 6)
+ '(a a))
+(null (find 'a '((a) (b) (c) (a a) (b b) (c c) (a a a))
+ :key #'car
+ :from-end t
+ :start 1
+ :end 3))
+(null (find #\c '("abc" "bcd" "cde")))
+(string= (find #\c '("abc" "bcd" "cde")
+ :key #'(lambda (arg) (char arg 0))
+ :test #'char=)
+ "cde")
+(string= (find #\c '("abc" "bcd" "cde")
+ :key #'(lambda (arg) (char arg 0))
+ :test #'char>)
+ "abc")
+(string= (find #\c '("abc" "bcd" "cde")
+ :start 1
+ :key #'(lambda (arg) (char arg 0))
+ :test #'char>)
+ "bcd")
+
+
+(eq (find 'a #(a b c)) 'a)
+(eq (find 'b #(a b c)) 'b)
+(eq (find 'c #(a b c)) 'c)
+(null (find 'x #(a b c)))
+(null (find 'a #(a b c) :start 1))
+(null (find 'b #(a b c) :start 2))
+(null (find 'c #(a b c) :start 3))
+(null (find 'a #(a b c) :start 0 :end 0))
+(null (find 'a #(a b c) :start 0 :end 0 :from-end t))
+(null (find 'a #(a b c) :start 1 :end 1))
+(null (find 'a #(a b c) :start 1 :end 1 :from-end t))
+(null (find 'a #(a b c) :start 2 :end 2))
+(null (find 'a #(a b c) :start 2 :end 2 :from-end t))
+(null (find 'a #(a b c) :start 3 :end 3))
+(null (find 'a #(a b c) :start 3 :end 3 :from-end t))
+(eq (find 'a #(a b c) :end nil) 'a)
+(eq (find 'b #(a b c) :end nil) 'b)
+(eq (find 'c #(a b c) :end nil) 'c)
+(eq (find 'a #(a b c) :end 1) 'a)
+(eq (find 'b #(a b c) :end 2) 'b)
+(eq (find 'c #(a b c) :end 3) 'c)
+(null (find 'a #(a b c) :end 0))
+(null (find 'b #(a b c) :end 1))
+(null (find 'c #(a b c) :end 2))
+(null (find 'a #((a) (b) (c))))
+(equal (find 'a #((a) (b) (c)) :key #'car) '(a))
+(equal (find 'b #((a) (b) (c)) :key #'car) '(b))
+(equal (find 'c #((a) (b) (c)) :key #'car) '(c))
+(null (find 'z #((a) (b) (c)) :key #'car))
+(let ((vector #((a) (b) (c))))
+ (and (eq (find 'a vector :key #'car) (aref vector 0))
+ (eq (find 'b vector :key #'car) (aref vector 1))
+ (eq (find 'c vector :key #'car) (aref vector 2))
+ (null (find 'z vector :key #'car))))
+(null (find '(a) #((a) (b) (c))))
+(equal (find '(a) #((a) (b) (c)) :test #'equal) '(a))
+(null (find '("a") #(("a") ("b") ("c"))))
+(null (find '("a") #(("A") ("B") ("c")) :test #'equal))
+(equal (find '("a") #(("A") ("B") ("c")) :test #'equalp) '("A"))
+(eq (find 'nil #(first second third) :test (constantly t)) 'first)
+(eql (find 3 #(0 1 2 3 4 5)) 3)
+(eql (find 3 #(0 1 2 3 4 5) :test #'<) 4)
+(eql (find 3 #(0 1 2 3 4 5) :test #'>) 0)
+(equal (find '(a) #((a) (b) (c)) :test-not (complement #'equal)) '(a))
+(null (find '("a") #(("A") ("B") ("c")) :test-not (complement #'equal)))
+(equal (find '("a") #(("A") ("B") ("c")) :test-not (complement #'equalp))
+ '("A"))
+(eq (find 'nil #(first second third) :test-not (constantly nil)) 'first)
+(eql (find 3 #(0 1 2 3 4 5) :test-not #'>=) 4)
+(eql (find 3 #(0 1 2 3 4 5) :test-not #'<=) 0)
+(equal (find 'a #((a) (b) (c) (a a) (b b) (c c)) :key #'car)
+ '(a))
+(equal (find 'a #((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t)
+ '(a a))
+(equal (find 'b #((a) (b) (c) (a a) (b b) (c c)) :key #'car)
+ '(b))
+(equal (find 'b #((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t)
+ '(b b))
+(equal (find 'c #((a) (b) (c) (a a) (b b) (c c)) :key #'car)
+ '(c))
+(equal (find 'c #((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t)
+ '(c c))
+(null (find 'z #((a) (b) (c) (a a) (b b) (c c)) :key #'car))
+(null (find 'z #((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t))
+
+(equal (find 'a #((a) (b) (c) (a a) (b b) (c c) (a a a))
+ :key #'car
+ :from-end t)
+ '(a a a))
+(equal (find 'a #((a) (b) (c) (a a) (b b) (c c) (a a a))
+ :key #'car
+ :from-end t
+ :end nil)
+ '(a a a))
+(equal (find 'a #((a) (b) (c) (a a) (b b) (c c) (a a a))
+ :key #'car
+ :from-end t
+ :end 6)
+ '(a a))
+(null (find 'a #((a) (b) (c) (a a) (b b) (c c) (a a a))
+ :key #'car
+ :from-end t
+ :start 1
+ :end 3))
+(null (find #\c #("abc" "bcd" "cde")))
+(string= (find #\c #("abc" "bcd" "cde")
+ :key #'(lambda (arg) (char arg 0))
+ :test #'char=)
+ "cde")
+(string= (find #\c #("abc" "bcd" "cde")
+ :key #'(lambda (arg) (char arg 0))
+ :test #'char>)
+ "abc")
+(string= (find #\c #("abc" "bcd" "cde")
+ :start 1
+ :key #'(lambda (arg) (char arg 0))
+ :test #'char>)
+ "bcd")
+(null (find #\z "abcABC"))
+(eql (find #\a "abcABC") #\a)
+(eql (find #\A "abcABC") #\A)
+(eql (find #\A "abcABC" :test #'char-equal) #\a)
+(eql (find #\A "abcABC" :test #'char-equal :from-end t) #\A)
+(eql (find #\a "abcABC" :test #'char-equal :from-end t) #\A)
+(eql (find #\a "abcABC" :test #'char-equal :from-end t :end 4) #\A)
+(eql (find #\a "abcABC" :test #'char-equal :from-end t :end 3) #\a)
+(zerop (find 0 #*01))
+(eql (find 1 #*01) 1)
+(null (find 0 #*01 :start 1))
+(null (find 1 #*01 :end 0))
+(null (find 0 #*000001 :start 5))
+
+
+
+(eq (find-if #'(lambda (x) (eq x 'a)) '(a b c)) 'a)
+(eq (find-if #'(lambda (x) (eq x 'b)) '(a b c)) 'b)
+(eq (find-if #'(lambda (x) (eq x 'c)) '(a b c)) 'c)
+(null (find-if #'(lambda (arg) (eq arg 'x)) '(a b c)))
+(null (find-if #'(lambda (x) (eq x 'a)) '(a b c) :start 1))
+(null (find-if #'(lambda (x) (eq x 'b)) '(a b c) :start 2))
+(null (find-if #'(lambda (x) (eq x 'c)) '(a b c) :start 3))
+(null (find-if #'(lambda (x) (eq x 'a)) '(a b c) :start 0 :end 0))
+(null (find-if #'(lambda (x) (eq x 'a)) '(a b c) :start 0 :end 0 :from-end t))
+(null (find-if #'(lambda (x) (eq x 'a)) '(a b c) :start 1 :end 1))
+(null (find-if #'(lambda (x) (eq x 'a)) '(a b c) :start 1 :end 1 :from-end t))
+(null (find-if #'(lambda (x) (eq x 'a)) '(a b c) :start 2 :end 2))
+(null (find-if #'(lambda (x) (eq x 'a)) '(a b c) :start 2 :end 2 :from-end t))
+(null (find-if #'(lambda (x) (eq x 'a)) '(a b c) :start 3 :end 3))
+(null (find-if #'(lambda (x) (eq x 'a)) '(a b c) :start 3 :end 3 :from-end t))
+(eq (find-if #'(lambda (x) (eq x 'a)) '(a b c) :end nil) 'a)
+(eq (find-if #'(lambda (x) (eq x 'b)) '(a b c) :end nil) 'b)
+(eq (find-if #'(lambda (x) (eq x 'c)) '(a b c) :end nil) 'c)
+(eq (find-if #'(lambda (x) (eq x 'a)) '(a b c) :end 1) 'a)
+(eq (find-if #'(lambda (x) (eq x 'b)) '(a b c) :end 2) 'b)
+(eq (find-if #'(lambda (x) (eq x 'c)) '(a b c) :end 3) 'c)
+(null (find-if #'(lambda (x) (eq x 'a)) '(a b c) :end 0))
+(null (find-if #'(lambda (x) (eq x 'b)) '(a b c) :end 1))
+(null (find-if #'(lambda (x) (eq x 'c)) '(a b c) :end 2))
+(null (find-if #'(lambda (x) (eq x 'a)) '((a) (b) (c))))
+(equal (find-if #'(lambda (x) (eq x 'a)) '((a) (b) (c)) :key #'car) '(a))
+(equal (find-if #'(lambda (x) (eq x 'b)) '((a) (b) (c)) :key #'car) '(b))
+(equal (find-if #'(lambda (x) (eq x 'c)) '((a) (b) (c)) :key #'car) '(c))
+(null (find-if #'(lambda (x) (eq x 'z)) '((a) (b) (c)) :key #'car))
+(let ((list '((a) (b) (c))))
+ (and (eq (find-if #'(lambda (x) (eq x 'a)) list :key #'car) (car list))
+ (eq (find-if #'(lambda (x) (eq x 'b)) list :key #'car) (cadr list))
+ (eq (find-if #'(lambda (x) (eq x 'c)) list :key #'car) (caddr list))
+ (null (find-if #'(lambda (x) (eq x 'z)) list :key #'car))))
+(equal (find-if #'(lambda (x) (eq x 'a))
+ '((a) (b) (c) (a a) (b b) (c c)) :key #'car)
+ '(a))
+(equal (find-if #'(lambda (x) (eq x 'a))
+ '((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t)
+ '(a a))
+(equal (find-if #'(lambda (x) (eq x 'b))
+ '((a) (b) (c) (a a) (b b) (c c)) :key #'car)
+ '(b))
+(equal (find-if #'(lambda (x) (eq x 'b))
+ '((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t)
+ '(b b))
+(equal (find-if #'(lambda (x) (eq x 'c))
+ '((a) (b) (c) (a a) (b b) (c c)) :key #'car)
+ '(c))
+(equal (find-if #'(lambda (x) (eq x 'c))
+ '((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t)
+ '(c c))
+(null (find-if #'(lambda (x) (eq x 'z))
+ '((a) (b) (c) (a a) (b b) (c c)) :key #'car))
+(null (find-if #'(lambda (x) (eq x 'z))
+ '((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t))
+(equal (find-if #'(lambda (x) (eq x 'a))
+ '((a) (b) (c) (a a) (b b) (c c) (a a a))
+ :key #'car
+ :from-end t)
+ '(a a a))
+(equal (find-if #'(lambda (x) (eq x 'a))
+ '((a) (b) (c) (a a) (b b) (c c) (a a a))
+ :key #'car
+ :from-end t
+ :end nil)
+ '(a a a))
+(equal (find-if #'(lambda (x) (eq x 'a))
+ '((a) (b) (c) (a a) (b b) (c c) (a a a))
+ :key #'car
+ :from-end t
+ :end 6)
+ '(a a))
+(null (find-if #'(lambda (x) (eq x 'a))
+ '((a) (b) (c) (a a) (b b) (c c) (a a a))
+ :key #'car
+ :from-end t
+ :start 1
+ :end 3))
+(null (find-if #'(lambda (x) (eql x #\c)) '("abc" "bcd" "cde")))
+(string= (find-if #'(lambda (x) (eql x #\c)) '("abc" "bcd" "cde")
+ :key #'(lambda (arg) (char arg 0)))
+ "cde")
+(string= (find-if #'(lambda (x) (char> #\c x)) '("abc" "bcd" "cde")
+ :key #'(lambda (arg) (char arg 0)))
+ "abc")
+(string= (find-if #'(lambda (x) (char> #\c x)) '("abc" "bcd" "cde")
+ :start 1
+ :key #'(lambda (arg) (char arg 0)))
+ "bcd")
+
+
+(eq (find-if #'(lambda (x) (eq x 'a)) #(a b c)) 'a)
+(eq (find-if #'(lambda (x) (eq x 'b)) #(a b c)) 'b)
+(eq (find-if #'(lambda (x) (eq x 'c)) #(a b c)) 'c)
+(null (find-if #'(lambda (arg) (eq arg 'x)) #(a b c)))
+(null (find-if #'(lambda (x) (eq x 'a)) #(a b c) :start 1))
+(null (find-if #'(lambda (x) (eq x 'b)) #(a b c) :start 2))
+(null (find-if #'(lambda (x) (eq x 'c)) #(a b c) :start 3))
+(null (find-if #'(lambda (x) (eq x 'a)) #(a b c) :start 0 :end 0))
+(null (find-if #'(lambda (x) (eq x 'a)) #(a b c) :start 0 :end 0 :from-end t))
+(null (find-if #'(lambda (x) (eq x 'a)) #(a b c) :start 1 :end 1))
+(null (find-if #'(lambda (x) (eq x 'a)) #(a b c) :start 1 :end 1 :from-end t))
+(null (find-if #'(lambda (x) (eq x 'a)) #(a b c) :start 2 :end 2))
+(null (find-if #'(lambda (x) (eq x 'a)) #(a b c) :start 2 :end 2 :from-end t))
+(null (find-if #'(lambda (x) (eq x 'a)) #(a b c) :start 3 :end 3))
+(null (find-if #'(lambda (x) (eq x 'a)) #(a b c) :start 3 :end 3 :from-end t))
+(eq (find-if #'(lambda (x) (eq x 'a)) #(a b c) :end nil) 'a)
+(eq (find-if #'(lambda (x) (eq x 'b)) #(a b c) :end nil) 'b)
+(eq (find-if #'(lambda (x) (eq x 'c)) #(a b c) :end nil) 'c)
+(eq (find-if #'(lambda (x) (eq x 'a)) #(a b c) :end 1) 'a)
+(eq (find-if #'(lambda (x) (eq x 'b)) #(a b c) :end 2) 'b)
+(eq (find-if #'(lambda (x) (eq x 'c)) #(a b c) :end 3) 'c)
+(null (find-if #'(lambda (x) (eq x 'a)) #(a b c) :end 0))
+(null (find-if #'(lambda (x) (eq x 'b)) #(a b c) :end 1))
+(null (find-if #'(lambda (x) (eq x 'c)) #(a b c) :end 2))
+(null (find-if #'(lambda (x) (eq x 'a)) #((a) (b) (c))))
+(equal (find-if #'(lambda (x) (eq x 'a)) #((a) (b) (c)) :key #'car) '(a))
+(equal (find-if #'(lambda (x) (eq x 'b)) #((a) (b) (c)) :key #'car) '(b))
+(equal (find-if #'(lambda (x) (eq x 'c)) #((a) (b) (c)) :key #'car) '(c))
+(null (find-if #'(lambda (x) (eq x 'z)) #((a) (b) (c)) :key #'car))
+(let ((vector #((a) (b) (c))))
+ (and (eq (find-if #'(lambda (x) (eq x 'a)) vector :key #'car) (aref vector 0))
+ (eq (find-if #'(lambda (x) (eq x 'b)) vector :key #'car) (aref vector 1))
+ (eq (find-if #'(lambda (x) (eq x 'c)) vector :key #'car) (aref vector 2))
+ (null (find-if #'(lambda (x) (eq x 'z)) vector :key #'car))))
+(equal (find-if #'(lambda (x) (eq x 'a))
+ #((a) (b) (c) (a a) (b b) (c c)) :key #'car)
+ '(a))
+(equal (find-if #'(lambda (x) (eq x 'a))
+ #((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t)
+ '(a a))
+(equal (find-if #'(lambda (x) (eq x 'b))
+ #((a) (b) (c) (a a) (b b) (c c)) :key #'car)
+ '(b))
+(equal (find-if #'(lambda (x) (eq x 'b))
+ #((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t)
+ '(b b))
+(equal (find-if #'(lambda (x) (eq x 'c))
+ #((a) (b) (c) (a a) (b b) (c c)) :key #'car)
+ '(c))
+(equal (find-if #'(lambda (x) (eq x 'c))
+ #((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t)
+ '(c c))
+(null (find-if #'(lambda (x) (eq x 'z))
+ #((a) (b) (c) (a a) (b b) (c c)) :key #'car))
+(null (find-if #'(lambda (x) (eq x 'z))
+ #((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t))
+(equal (find-if #'(lambda (x) (eq x 'a))
+ #((a) (b) (c) (a a) (b b) (c c) (a a a))
+ :key #'car
+ :from-end t)
+ '(a a a))
+(equal (find-if #'(lambda (x) (eq x 'a))
+ #((a) (b) (c) (a a) (b b) (c c) (a a a))
+ :key #'car
+ :from-end t
+ :end nil)
+ '(a a a))
+(equal (find-if #'(lambda (x) (eq x 'a))
+ #((a) (b) (c) (a a) (b b) (c c) (a a a))
+ :key #'car
+ :from-end t
+ :end 6)
+ '(a a))
+(null (find-if #'(lambda (x) (eq x 'a))
+ #((a) (b) (c) (a a) (b b) (c c) (a a a))
+ :key #'car
+ :from-end t
+ :start 1
+ :end 3))
+(null (find-if #'(lambda (x) (eql x #\c)) #("abc" "bcd" "cde")))
+(string= (find-if #'(lambda (x) (eql x #\c)) #("abc" "bcd" "cde")
+ :key #'(lambda (arg) (char arg 0)))
+ "cde")
+(string= (find-if #'(lambda (x) (char> #\c x)) #("abc" "bcd" "cde")
+ :key #'(lambda (arg) (char arg 0)))
+ "abc")
+(string= (find-if #'(lambda (x) (char> #\c x)) #("abc" "bcd" "cde")
+ :start 1
+ :key #'(lambda (arg) (char arg 0)))
+ "bcd")
+
+
+(eq (find-if-not #'(lambda (x) (not (eq x 'a))) '(a b c)) 'a)
+(eq (find-if-not #'(lambda (x) (not (eq x 'b))) '(a b c)) 'b)
+(eq (find-if-not #'(lambda (x) (not (eq x 'c))) '(a b c)) 'c)
+(null (find-if-not #'(lambda (arg) (not (eq arg 'x))) '(a b c)))
+(null (find-if-not #'(lambda (x) (not (eq x 'a))) '(a b c) :start 1))
+(null (find-if-not #'(lambda (x) (not (eq x 'b))) '(a b c) :start 2))
+(null (find-if-not #'(lambda (x) (not (eq x 'c))) '(a b c) :start 3))
+(null (find-if-not #'(lambda (x) (not (eq x 'a))) '(a b c) :start 0 :end 0))
+(null (find-if-not #'(lambda (x) (not (eq x 'a))) '(a b c)
+ :start 0 :end 0 :from-end t))
+(null (find-if-not #'(lambda (x) (not (eq x 'a))) '(a b c) :start 1 :end 1))
+(null (find-if-not #'(lambda (x) (not (eq x 'a))) '(a b c)
+ :start 1 :end 1 :from-end t))
+(null (find-if-not #'(lambda (x) (not (eq x 'a))) '(a b c) :start 2 :end 2))
+(null (find-if-not #'(lambda (x) (not (eq x 'a))) '(a b c)
+ :start 2 :end 2 :from-end t))
+(null (find-if-not #'(lambda (x) (not (eq x 'a))) '(a b c) :start 3 :end 3))
+(null (find-if-not #'(lambda (x) (not (eq x 'a))) '(a b c)
+ :start 3 :end 3 :from-end t))
+(eq (find-if-not #'(lambda (x) (not (eq x 'a))) '(a b c) :end nil) 'a)
+(eq (find-if-not #'(lambda (x) (not (eq x 'b))) '(a b c) :end nil) 'b)
+(eq (find-if-not #'(lambda (x) (not (eq x 'c))) '(a b c) :end nil) 'c)
+(eq (find-if-not #'(lambda (x) (not (eq x 'a))) '(a b c) :end 1) 'a)
+(eq (find-if-not #'(lambda (x) (not (eq x 'b))) '(a b c) :end 2) 'b)
+(eq (find-if-not #'(lambda (x) (not (eq x 'c))) '(a b c) :end 3) 'c)
+(null (find-if-not #'(lambda (x) (not (eq x 'a))) '(a b c) :end 0))
+(null (find-if-not #'(lambda (x) (not (eq x 'b))) '(a b c) :end 1))
+(null (find-if-not #'(lambda (x) (not (eq x 'c))) '(a b c) :end 2))
+(null (find-if-not #'(lambda (x) (not (eq x 'a))) '((a) (b) (c))))
+(equal (find-if-not #'(lambda (x) (not (eq x 'a))) '((a) (b) (c)) :key #'car)
+ '(a))
+(equal (find-if-not #'(lambda (x) (not (eq x 'b))) '((a) (b) (c)) :key #'car)
+ '(b))
+(equal (find-if-not #'(lambda (x) (not (eq x 'c))) '((a) (b) (c)) :key #'car)
+ '(c))
+(null (find-if-not #'(lambda (x) (not (eq x 'z))) '((a) (b) (c)) :key #'car))
+(let ((list '((a) (b) (c))))
+ (and (eq (find-if-not #'(lambda (x) (not (eq x 'a))) list :key #'car)
+ (car list))
+ (eq (find-if-not #'(lambda (x) (not (eq x 'b))) list :key #'car)
+ (cadr list))
+ (eq (find-if-not #'(lambda (x) (not (eq x 'c))) list :key #'car)
+ (caddr list))
+ (null (find-if-not #'(lambda (x) (not (eq x 'z))) list :key #'car))))
+(equal (find-if-not #'(lambda (x) (not (eq x 'a)))
+ '((a) (b) (c) (a a) (b b) (c c)) :key #'car)
+ '(a))
+(equal (find-if-not #'(lambda (x) (not (eq x 'a)))
+ '((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t)
+ '(a a))
+(equal (find-if-not #'(lambda (x) (not (eq x 'b)))
+ '((a) (b) (c) (a a) (b b) (c c)) :key #'car)
+ '(b))
+(equal (find-if-not #'(lambda (x) (not (eq x 'b)))
+ '((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t)
+ '(b b))
+(equal (find-if-not #'(lambda (x) (not (eq x 'c)))
+ '((a) (b) (c) (a a) (b b) (c c)) :key #'car)
+ '(c))
+(equal (find-if-not #'(lambda (x) (not (eq x 'c)))
+ '((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t)
+ '(c c))
+(null (find-if-not #'(lambda (x) (not (eq x 'z)))
+ '((a) (b) (c) (a a) (b b) (c c)) :key #'car))
+(null (find-if-not #'(lambda (x) (not (eq x 'z)))
+ '((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t))
+(equal (find-if-not #'(lambda (x) (not (eq x 'a)))
+ '((a) (b) (c) (a a) (b b) (c c) (a a a))
+ :key #'car
+ :from-end t)
+ '(a a a))
+(equal (find-if-not #'(lambda (x) (not (eq x 'a)))
+ '((a) (b) (c) (a a) (b b) (c c) (a a a))
+ :key #'car
+ :from-end t
+ :end nil)
+ '(a a a))
+(equal (find-if-not #'(lambda (x) (not (eq x 'a)))
+ '((a) (b) (c) (a a) (b b) (c c) (a a a))
+ :key #'car
+ :from-end t
+ :end 6)
+ '(a a))
+(null (find-if-not #'(lambda (x) (not (eq x 'a)))
+ '((a) (b) (c) (a a) (b b) (c c) (a a a))
+ :key #'car
+ :from-end t
+ :start 1
+ :end 3))
+(null (find-if-not #'(lambda (x) (not (eql x #\c))) '("abc" "bcd" "cde")))
+(string= (find-if-not #'(lambda (x) (not (eql x #\c))) '("abc" "bcd" "cde")
+ :key #'(lambda (arg) (char arg 0)))
+ "cde")
+(string= (find-if-not #'(lambda (x) (not (char> #\c x))) '("abc" "bcd" "cde")
+ :key #'(lambda (arg) (char arg 0)))
+ "abc")
+(string= (find-if-not #'(lambda (x) (not (char> #\c x))) '("abc" "bcd" "cde")
+ :start 1
+ :key #'(lambda (arg) (char arg 0)))
+ "bcd")
+
+(eq (find-if-not #'(lambda (x) (not (eq x 'a))) #(a b c)) 'a)
+(eq (find-if-not #'(lambda (x) (not (eq x 'b))) #(a b c)) 'b)
+(eq (find-if-not #'(lambda (x) (not (eq x 'c))) #(a b c)) 'c)
+(null (find-if-not #'(lambda (arg) (not (eq arg 'x))) #(a b c)))
+(null (find-if-not #'(lambda (x) (not (eq x 'a))) #(a b c) :start 1))
+(null (find-if-not #'(lambda (x) (not (eq x 'b))) #(a b c) :start 2))
+(null (find-if-not #'(lambda (x) (not (eq x 'c))) #(a b c) :start 3))
+(null (find-if-not #'(lambda (x) (not (eq x 'a))) #(a b c) :start 0 :end 0))
+(null (find-if-not #'(lambda (x) (not (eq x 'a))) #(a b c) :start 0 :end 0
+ :from-end t))
+(null (find-if-not #'(lambda (x) (not (eq x 'a))) #(a b c) :start 1 :end 1))
+(null (find-if-not #'(lambda (x) (not (eq x 'a))) #(a b c) :start 1 :end 1
+ :from-end t))
+(null (find-if-not #'(lambda (x) (not (eq x 'a))) #(a b c) :start 2 :end 2))
+(null (find-if-not #'(lambda (x) (not (eq x 'a))) #(a b c) :start 2 :end 2
+ :from-end t))
+(null (find-if-not #'(lambda (x) (not (eq x 'a))) #(a b c) :start 3 :end 3))
+(null (find-if-not #'(lambda (x) (not (eq x 'a))) #(a b c) :start 3 :end 3
+ :from-end t))
+(eq (find-if-not #'(lambda (x) (not (eq x 'a))) #(a b c) :end nil) 'a)
+(eq (find-if-not #'(lambda (x) (not (eq x 'b))) #(a b c) :end nil) 'b)
+(eq (find-if-not #'(lambda (x) (not (eq x 'c))) #(a b c) :end nil) 'c)
+(eq (find-if-not #'(lambda (x) (not (eq x 'a))) #(a b c) :end 1) 'a)
+(eq (find-if-not #'(lambda (x) (not (eq x 'b))) #(a b c) :end 2) 'b)
+(eq (find-if-not #'(lambda (x) (not (eq x 'c))) #(a b c) :end 3) 'c)
+(null (find-if-not #'(lambda (x) (not (eq x 'a))) #(a b c) :end 0))
+(null (find-if-not #'(lambda (x) (not (eq x 'b))) #(a b c) :end 1))
+(null (find-if-not #'(lambda (x) (not (eq x 'c))) #(a b c) :end 2))
+(null (find-if-not #'(lambda (x) (not (eq x 'a))) #((a) (b) (c))))
+(equal (find-if-not #'(lambda (x) (not (eq x 'a))) #((a) (b) (c)) :key #'car)
+ '(a))
+(equal (find-if-not #'(lambda (x) (not (eq x 'b))) #((a) (b) (c)) :key #'car)
+ '(b))
+(equal (find-if-not #'(lambda (x) (not (eq x 'c))) #((a) (b) (c)) :key #'car)
+ '(c))
+(null (find-if-not #'(lambda (x) (not (eq x 'z))) #((a) (b) (c)) :key #'car))
+(let ((vector #((a) (b) (c))))
+ (and (eq (find-if-not #'(lambda (x) (not (eq x 'a))) vector :key #'car)
+ (aref vector 0))
+ (eq (find-if-not #'(lambda (x) (not (eq x 'b))) vector :key #'car)
+ (aref vector 1))
+ (eq (find-if-not #'(lambda (x) (not (eq x 'c))) vector :key #'car)
+ (aref vector 2))
+ (null (find-if-not #'(lambda (x) (not (eq x 'z))) vector :key #'car))))
+(equal (find-if-not #'(lambda (x) (not (eq x 'a)))
+ #((a) (b) (c) (a a) (b b) (c c)) :key #'car)
+ '(a))
+(equal (find-if-not #'(lambda (x) (not (eq x 'a)))
+ #((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t)
+ '(a a))
+(equal (find-if-not #'(lambda (x) (not (eq x 'b)))
+ #((a) (b) (c) (a a) (b b) (c c)) :key #'car)
+ '(b))
+(equal (find-if-not #'(lambda (x) (not (eq x 'b)))
+ #((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t)
+ '(b b))
+(equal (find-if-not #'(lambda (x) (not (eq x 'c)))
+ #((a) (b) (c) (a a) (b b) (c c)) :key #'car)
+ '(c))
+(equal (find-if-not #'(lambda (x) (not (eq x 'c)))
+ #((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t)
+ '(c c))
+(null (find-if-not #'(lambda (x) (not (eq x 'z)))
+ #((a) (b) (c) (a a) (b b) (c c)) :key #'car))
+(null (find-if-not #'(lambda (x) (not (eq x 'z)))
+ #((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t))
+(equal (find-if-not #'(lambda (x) (not (eq x 'a)))
+ #((a) (b) (c) (a a) (b b) (c c) (a a a))
+ :key #'car
+ :from-end t)
+ '(a a a))
+(equal (find-if-not #'(lambda (x) (not (eq x 'a)))
+ #((a) (b) (c) (a a) (b b) (c c) (a a a))
+ :key #'car
+ :from-end t
+ :end nil)
+ '(a a a))
+(equal (find-if-not #'(lambda (x) (not (eq x 'a)))
+ #((a) (b) (c) (a a) (b b) (c c) (a a a))
+ :key #'car
+ :from-end t
+ :end 6)
+ '(a a))
+(null (find-if-not #'(lambda (x) (not (eq x 'a)))
+ #((a) (b) (c) (a a) (b b) (c c) (a a a))
+ :key #'car
+ :from-end t
+ :start 1
+ :end 3))
+(string= (find-if-not #'(lambda (x) (not (eql x #\c))) #("abc" "bcd" "cde")
+ :key #'(lambda (arg) (char arg 0)))
+ "cde")
+(string= (find-if-not #'(lambda (x) (not (char> #\c x))) #("abc" "bcd" "cde")
+ :key #'(lambda (arg) (char arg 0)))
+ "abc")
+(string= (find-if-not #'(lambda (x) (not (char> #\c x))) #("abc" "bcd" "cde")
+ :start 1
+ :key #'(lambda (arg) (char arg 0)))
+ "bcd")
+
+
+
+
+(eql (position #\a "baobab" :from-end t) 4)
+(eql (position-if #'oddp '((1) (2) (3) (4)) :start 1 :key #'car) 2)
+(null (position 595 '()))
+(eql (position-if-not #'integerp '(1 2 3 4 5.0)) 4)
+
+(eql (position 'a '(a b c)) 0)
+(eql (position 'b '(a b c)) 1)
+(eql (position 'c '(a b c)) 2)
+(null (position 'x '(a b c)))
+(null (position 'a '(a b c) :start 1))
+(null (position 'b '(a b c) :start 2))
+(null (position 'c '(a b c) :start 3))
+(null (position 'a '(a b c) :start 0 :end 0))
+(null (position 'a '(a b c) :start 0 :end 0 :from-end t))
+(null (position 'a '(a b c) :start 1 :end 1))
+(null (position 'a '(a b c) :start 1 :end 1 :from-end t))
+(null (position 'a '(a b c) :start 2 :end 2))
+(null (position 'a '(a b c) :start 2 :end 2 :from-end t))
+(null (position 'a '(a b c) :start 3 :end 3))
+(null (position 'a '(a b c) :start 3 :end 3 :from-end t))
+(eql (position 'a '(a b c) :end nil) '0)
+(eql (position 'b '(a b c) :end nil) '1)
+(eql (position 'c '(a b c) :end nil) '2)
+(eql (position 'a '(a b c) :end 1) '0)
+(eql (position 'b '(a b c) :end 2) '1)
+(eql (position 'c '(a b c) :end 3) '2)
+(null (position 'a '(a b c) :end 0))
+(null (position 'b '(a b c) :end 1))
+(null (position 'c '(a b c) :end 2))
+(null (position 'a '((a) (b) (c))))
+(eql (position 'a '((a) (b) (c)) :key #'car) 0)
+(eql (position 'b '((a) (b) (c)) :key #'car) 1)
+(eql (position 'c '((a) (b) (c)) :key #'car) 2)
+(null (position 'z '((a) (b) (c)) :key #'car))
+(null (position '(a) '((a) (b) (c))))
+(eql (position '(a) '((a) (b) (c)) :test #'equal) 0)
+(null (position '("a") '(("a") ("b") ("c"))))
+(null (position '("a") '(("A") ("B") ("c")) :test #'equal))
+(eql (position '("a") '(("A") ("B") ("c")) :test #'equalp) 0)
+(eql (position 'nil '(first second third) :test (constantly t)) 0)
+(eql (position 3 '(0 1 2 3 4 5)) 3)
+(eql (position 3 '(0 1 2 3 4 5) :test #'<) 4)
+(eql (position 3 '(0 1 2 3 4 5) :test #'>) 0)
+(eql (position '(a) '((a) (b) (c)) :test-not (complement #'equal)) 0)
+(null (position '("a") '(("A") ("B") ("c")) :test-not (complement #'equal)))
+(eql (position '("a") '(("A") ("B") ("c")) :test-not (complement #'equalp))
+ 0)
+(eql (position 'nil '(first second third) :test-not (constantly nil)) 0)
+(eql (position 3 '(0 1 2 3 4 5) :test-not #'>=) 4)
+(eql (position 3 '(0 1 2 3 4 5) :test-not #'<=) 0)
+(eql (position 'a '((a) (b) (c) (a a) (b b) (c c)) :key #'car) 0)
+(eql (position 'a '((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t) 3)
+(eql (position 'b '((a) (b) (c) (a a) (b b) (c c)) :key #'car) 1)
+(eql (position 'b '((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t) 4)
+(eql (position 'c '((a) (b) (c) (a a) (b b) (c c)) :key #'car) 2)
+(eql (position 'c '((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t) 5)
+(null (position 'z '((a) (b) (c) (a a) (b b) (c c)) :key #'car))
+(null (position 'z '((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t))
+(eql (position 'a '((a) (b) (c) (a a) (b b) (c c) (a a a))
+ :key #'car
+ :from-end t)
+ 6)
+(eql (position 'a '((a) (b) (c) (a a) (b b) (c c) (a a a))
+ :key #'car
+ :from-end t
+ :end nil)
+ 6)
+(eql (position 'a '((a) (b) (c) (a a) (b b) (c c) (a a a))
+ :key #'car
+ :from-end t
+ :end 6)
+ 3)
+(null (position 'a '((a) (b) (c) (a a) (b b) (c c) (a a a))
+ :key #'car
+ :from-end t
+ :start 1
+ :end 3))
+(null (position #\c '("abc" "bcd" "cde")))
+(eql (position #\c '("abc" "bcd" "cde")
+ :key #'(lambda (arg) (char arg 0))
+ :test #'char=)
+ 2)
+(eql (position #\c '("abc" "bcd" "cde")
+ :key #'(lambda (arg) (char arg 0))
+ :test #'char>)
+ 0)
+(eql (position #\c '("abc" "bcd" "cde")
+ :start 1
+ :key #'(lambda (arg) (char arg 0))
+ :test #'char>)
+ 1)
+(eql (position 'a #(a b c)) 0)
+(eql (position 'b #(a b c)) 1)
+(eql (position 'c #(a b c)) 2)
+(null (position 'x #(a b c)))
+(null (position 'a #(a b c) :start 1))
+(null (position 'b #(a b c) :start 2))
+(null (position 'c #(a b c) :start 3))
+(null (position 'a #(a b c) :start 0 :end 0))
+(null (position 'a #(a b c) :start 0 :end 0 :from-end t))
+(null (position 'a #(a b c) :start 1 :end 1))
+(null (position 'a #(a b c) :start 1 :end 1 :from-end t))
+(null (position 'a #(a b c) :start 2 :end 2))
+(null (position 'a #(a b c) :start 2 :end 2 :from-end t))
+(null (position 'a #(a b c) :start 3 :end 3))
+(null (position 'a #(a b c) :start 3 :end 3 :from-end t))
+(eql (position 'a #(a b c) :end nil) 0)
+(eql (position 'b #(a b c) :end nil) 1)
+(eql (position 'c #(a b c) :end nil) 2)
+(eql (position 'a #(a b c) :end 1) 0)
+(eql (position 'b #(a b c) :end 2) 1)
+(eql (position 'c #(a b c) :end 3) 2)
+(null (position 'a #(a b c) :end 0))
+(null (position 'b #(a b c) :end 1))
+(null (position 'c #(a b c) :end 2))
+(null (position 'a #((a) (b) (c))))
+(eql (position 'a #((a) (b) (c)) :key #'car) 0)
+(eql (position 'b #((a) (b) (c)) :key #'car) 1)
+(eql (position 'c #((a) (b) (c)) :key #'car) 2)
+(null (position 'z #((a) (b) (c)) :key #'car))
+(null (position '(a) #((a) (b) (c))))
+(eql (position '(a) #((a) (b) (c)) :test #'equal) 0)
+(null (position '("a") #(("a") ("b") ("c"))))
+(null (position '("a") #(("A") ("B") ("c")) :test #'equal))
+(eql (position '("a") #(("A") ("B") ("c")) :test #'equalp) 0)
+(eql (position 'nil #(first second third) :test (constantly t)) 0)
+(eql (position 'nil #(first second third) :test (constantly t) :from-end t) 2)
+(eql (position 3 #(0 1 2 3 4 5)) 3)
+(eql (position 3 #(0 1 2 3 4 5) :test #'<) 4)
+(eql (position 3 #(0 1 2 3 4 5) :test #'>) 0)
+(eql (position '(a) #((a) (b) (c)) :test-not (complement #'equal)) 0)
+(null (position '("a") #(("A") ("B") ("c")) :test-not (complement #'equal)))
+(eql (position '("a") #(("A") ("B") ("c")) :test-not (complement #'equalp))
+ 0)
+(eql (position 'nil #(first second third) :test-not (constantly nil)) 0)
+(eql (position 3 #(0 1 2 3 4 5) :test-not #'>=) 4)
+(eql (position 3 #(0 1 2 3 4 5) :test-not #'<=) 0)
+(eql (position 'a #((a) (b) (c) (a a) (b b) (c c)) :key #'car) 0)
+(eql (position 'a #((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t) 3)
+(eql (position 'b #((a) (b) (c) (a a) (b b) (c c)) :key #'car) 1)
+(eql (position 'b #((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t) 4)
+(eql (position 'c #((a) (b) (c) (a a) (b b) (c c)) :key #'car) 2)
+(eql (position 'c #((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t) 5)
+(null (position 'z #((a) (b) (c) (a a) (b b) (c c)) :key #'car))
+(null (position 'z #((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t))
+(eql (position 'a #((a) (b) (c) (a a) (b b) (c c) (a a a))
+ :key #'car
+ :from-end t)
+ 6)
+(eql (position 'a #((a) (b) (c) (a a) (b b) (c c) (a a a))
+ :key #'car
+ :from-end t
+ :end nil)
+ 6)
+(eql (position 'a #((a) (b) (c) (a a) (b b) (c c) (a a a))
+ :key #'car
+ :from-end t
+ :end 6)
+ 3)
+(null (position 'a #((a) (b) (c) (a a) (b b) (c c) (a a a))
+ :key #'car
+ :from-end t
+ :start 1
+ :end 3))
+(null (position #\c #("abc" "bcd" "cde")))
+(eql (position #\c #("abc" "bcd" "cde")
+ :key #'(lambda (arg) (char arg 0))
+ :test #'char=)
+ 2)
+(eql (position #\c #("abc" "bcd" "cde")
+ :key #'(lambda (arg) (char arg 0))
+ :test #'char>)
+ 0)
+(eql (position #\c #("abc" "bcd" "cde")
+ :start 1
+ :key #'(lambda (arg) (char arg 0))
+ :test #'char>)
+ 1)
+(null (position #\z "abcABC"))
+(eql (position #\a "abcABC") 0)
+(eql (position #\A "abcABC") 3)
+(eql (position #\A "abcABC" :test #'char-equal) 0)
+(eql (position #\A "abcABC" :test #'char-equal :from-end t) 3)
+(eql (position #\a "abcABC" :test #'char-equal :from-end t) 3)
+(eql (position #\a "abcABC" :test #'char-equal :from-end t :end 4) 3)
+(eql (position #\a "abcABC" :test #'char-equal :from-end t :end 3) 0)
+(zerop (position 0 #*01))
+(eql (position 1 #*01) 1)
+(null (position 0 #*01 :start 1))
+(null (position 1 #*01 :end 0))
+(null (position 0 #*000001 :start 5))
+
+
+(eql (position-if #'(lambda (x) (eq x 'a)) '(a b c)) 0)
+(eql (position-if #'(lambda (x) (eq x 'b)) '(a b c)) 1)
+(eql (position-if #'(lambda (x) (eq x 'c)) '(a b c)) 2)
+(null (position-if #'(lambda (arg) (eq arg 'x)) '(a b c)))
+(null (position-if #'(lambda (x) (eq x 'a)) '(a b c) :start 1))
+(null (position-if #'(lambda (x) (eq x 'b)) '(a b c) :start 2))
+(null (position-if #'(lambda (x) (eq x 'c)) '(a b c) :start 3))
+(null (position-if #'(lambda (x) (eq x 'a)) '(a b c) :start 0 :end 0))
+(null (position-if #'(lambda (x) (eq x 'a)) '(a b c) :start 0 :end 0
+ :from-end t))
+(null (position-if #'(lambda (x) (eq x 'a)) '(a b c) :start 1 :end 1))
+(null (position-if #'(lambda (x) (eq x 'a)) '(a b c) :start 1 :end 1
+ :from-end t))
+(null (position-if #'(lambda (x) (eq x 'a)) '(a b c) :start 2 :end 2))
+(null (position-if #'(lambda (x) (eq x 'a)) '(a b c) :start 2 :end 2
+ :from-end t))
+(null (position-if #'(lambda (x) (eq x 'a)) '(a b c) :start 3 :end 3))
+(null (position-if #'(lambda (x) (eq x 'a)) '(a b c) :start 3 :end 3
+ :from-end t))
+(eql (position-if #'(lambda (x) (eq x 'a)) '(a b c) :end nil) 0)
+(eql (position-if #'(lambda (x) (eq x 'b)) '(a b c) :end nil) 1)
+(eql (position-if #'(lambda (x) (eq x 'c)) '(a b c) :end nil) 2)
+(eql (position-if #'(lambda (x) (eq x 'a)) '(a b c) :end 1) 0)
+(eql (position-if #'(lambda (x) (eq x 'b)) '(a b c) :end 2) 1)
+(eql (position-if #'(lambda (x) (eq x 'c)) '(a b c) :end 3) 2)
+(null (position-if #'(lambda (x) (eq x 'a)) '(a b c) :end 0))
+(null (position-if #'(lambda (x) (eq x 'b)) '(a b c) :end 1))
+(null (position-if #'(lambda (x) (eq x 'c)) '(a b c) :end 2))
+(null (position-if #'(lambda (x) (eq x 'a)) '((a) (b) (c))))
+(eql (position-if #'(lambda (x) (eq x 'a)) '((a) (b) (c)) :key #'car) 0)
+(eql (position-if #'(lambda (x) (eq x 'b)) '((a) (b) (c)) :key #'car) 1)
+(eql (position-if #'(lambda (x) (eq x 'c)) '((a) (b) (c)) :key #'car) 2)
+(null (position-if #'(lambda (x) (eq x 'z)) '((a) (b) (c)) :key #'car))
+(eql (position-if #'(lambda (x) (eq x 'a))
+ '((a) (b) (c) (a a) (b b) (c c)) :key #'car)
+ 0)
+(eql (position-if #'(lambda (x) (eq x 'a))
+ '((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t)
+ 3)
+(eql (position-if #'(lambda (x) (eq x 'b))
+ '((a) (b) (c) (a a) (b b) (c c)) :key #'car)
+ 1)
+(eql (position-if #'(lambda (x) (eq x 'b))
+ '((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t)
+ 4)
+(eql (position-if #'(lambda (x) (eq x 'c))
+ '((a) (b) (c) (a a) (b b) (c c)) :key #'car)
+ 2)
+(eql (position-if #'(lambda (x) (eq x 'c))
+ '((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t)
+ 5)
+(null (position-if #'(lambda (x) (eq x 'z))
+ '((a) (b) (c) (a a) (b b) (c c)) :key #'car))
+(null (position-if #'(lambda (x) (eq x 'z))
+ '((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t))
+(eql (position-if #'(lambda (x) (eq x 'a))
+ '((a) (b) (c) (a a) (b b) (c c) (a a a))
+ :key #'car
+ :from-end t)
+ 6)
+(eql (position-if #'(lambda (x) (eq x 'a))
+ '((a) (b) (c) (a a) (b b) (c c) (a a a))
+ :key #'car
+ :from-end t
+ :end nil)
+ 6)
+(eql (position-if #'(lambda (x) (eq x 'a))
+ '((a) (b) (c) (a a) (b b) (c c) (a a a))
+ :key #'car
+ :from-end t
+ :end 6)
+ 3)
+(null (position-if #'(lambda (x) (eq x 'a))
+ '((a) (b) (c) (a a) (b b) (c c) (a a a))
+ :key #'car
+ :from-end t
+ :start 1
+ :end 3))
+(null (position-if #'(lambda (x) (eql x #\c)) '("abc" "bcd" "cde")))
+(eql (position-if #'(lambda (x) (eql x #\c)) '("abc" "bcd" "cde")
+ :key #'(lambda (arg) (char arg 0)))
+ 2)
+(eql (position-if #'(lambda (x) (char> #\c x)) '("abc" "bcd" "cde")
+ :key #'(lambda (arg) (char arg 0)))
+ 0)
+(eql (position-if #'(lambda (x) (char> #\c x)) '("abc" "bcd" "cde")
+ :start 1
+ :key #'(lambda (arg) (char arg 0)))
+ 1)
+(eql (position-if #'(lambda (x) (eq x 'a)) #(a b c)) 0)
+(eql (position-if #'(lambda (x) (eq x 'b)) #(a b c)) 1)
+(eql (position-if #'(lambda (x) (eq x 'c)) #(a b c)) 2)
+(null (position-if #'(lambda (arg) (eq arg 'x)) #(a b c)))
+(null (position-if #'(lambda (x) (eq x 'a)) #(a b c) :start 1))
+(null (position-if #'(lambda (x) (eq x 'b)) #(a b c) :start 2))
+(null (position-if #'(lambda (x) (eq x 'c)) #(a b c) :start 3))
+(null (position-if #'(lambda (x) (eq x 'a)) #(a b c) :start 0 :end 0))
+(null (position-if #'(lambda (x) (eq x 'a)) #(a b c) :start 0 :end 0
+ :from-end t))
+(null (position-if #'(lambda (x) (eq x 'a)) #(a b c) :start 1 :end 1))
+(null (position-if #'(lambda (x) (eq x 'a)) #(a b c) :start 1 :end 1
+ :from-end t))
+(null (position-if #'(lambda (x) (eq x 'a)) #(a b c) :start 2 :end 2))
+(null (position-if #'(lambda (x) (eq x 'a)) #(a b c) :start 2 :end 2
+ :from-end t))
+(null (position-if #'(lambda (x) (eq x 'a)) #(a b c) :start 3 :end 3))
+(null (position-if #'(lambda (x) (eq x 'a)) #(a b c) :start 3 :end 3
+ :from-end t))
+(eql (position-if #'(lambda (x) (eq x 'a)) #(a b c) :end nil) 0)
+(eql (position-if #'(lambda (x) (eq x 'b)) #(a b c) :end nil) 1)
+(eql (position-if #'(lambda (x) (eq x 'c)) #(a b c) :end nil) 2)
+(eql (position-if #'(lambda (x) (eq x 'a)) #(a b c) :end 1) 0)
+(eql (position-if #'(lambda (x) (eq x 'b)) #(a b c) :end 2) 1)
+(eql (position-if #'(lambda (x) (eq x 'c)) #(a b c) :end 3) 2)
+(null (position-if #'(lambda (x) (eq x 'a)) #(a b c) :end 0))
+(null (position-if #'(lambda (x) (eq x 'b)) #(a b c) :end 1))
+(null (position-if #'(lambda (x) (eq x 'c)) #(a b c) :end 2))
+(null (position-if #'(lambda (x) (eq x 'a)) #((a) (b) (c))))
+(eql (position-if #'(lambda (x) (eq x 'a)) #((a) (b) (c)) :key #'car) 0)
+(eql (position-if #'(lambda (x) (eq x 'b)) #((a) (b) (c)) :key #'car) 1)
+(eql (position-if #'(lambda (x) (eq x 'c)) #((a) (b) (c)) :key #'car) 2)
+(null (position-if #'(lambda (x) (eq x 'z)) #((a) (b) (c)) :key #'car))
+(eql (position-if #'(lambda (x) (eq x 'a))
+ #((a) (b) (c) (a a) (b b) (c c)) :key #'car)
+ 0)
+(eql (position-if #'(lambda (x) (eq x 'a))
+ #((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t)
+ 3)
+(eql (position-if #'(lambda (x) (eq x 'b))
+ #((a) (b) (c) (a a) (b b) (c c)) :key #'car)
+ 1)
+(eql (position-if #'(lambda (x) (eq x 'b))
+ #((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t)
+ 4)
+(eql (position-if #'(lambda (x) (eq x 'c))
+ #((a) (b) (c) (a a) (b b) (c c)) :key #'car)
+ 2)
+(eql (position-if #'(lambda (x) (eq x 'c))
+ #((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t)
+ 5)
+(null (position-if #'(lambda (x) (eq x 'z))
+ #((a) (b) (c) (a a) (b b) (c c)) :key #'car))
+(null (position-if #'(lambda (x) (eq x 'z))
+ #((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t))
+(eql (position-if #'(lambda (x) (eq x 'a))
+ #((a) (b) (c) (a a) (b b) (c c) (a a a))
+ :key #'car
+ :from-end t)
+ 6)
+(eql (position-if #'(lambda (x) (eq x 'a))
+ #((a) (b) (c) (a a) (b b) (c c) (a a a))
+ :key #'car
+ :from-end t
+ :end nil)
+ 6)
+(eql (position-if #'(lambda (x) (eq x 'a))
+ #((a) (b) (c) (a a) (b b) (c c) (a a a))
+ :key #'car
+ :from-end t
+ :end 6)
+ 3)
+(null (position-if #'(lambda (x) (eq x 'a))
+ #((a) (b) (c) (a a) (b b) (c c) (a a a))
+ :key #'car
+ :from-end t
+ :start 1
+ :end 3))
+(null (position-if #'(lambda (x) (eql x #\c)) #("abc" "bcd" "cde")))
+(eql (position-if #'(lambda (x) (eql x #\c)) #("abc" "bcd" "cde")
+ :key #'(lambda (arg) (char arg 0)))
+ 2)
+(eql (position-if #'(lambda (x) (char> #\c x)) #("abc" "bcd" "cde")
+ :key #'(lambda (arg) (char arg 0)))
+ 0)
+(eql (position-if #'(lambda (x) (char> #\c x)) #("abc" "bcd" "cde")
+ :start 1
+ :key #'(lambda (arg) (char arg 0)))
+ 1)
+
+
+(eql (position-if-not #'(lambda (x) (not (eq x 'a))) '(a b c)) 0)
+(eql (position-if-not #'(lambda (x) (not (eq x 'b))) '(a b c)) 1)
+(eql (position-if-not #'(lambda (x) (not (eq x 'c))) '(a b c)) 2)
+(null (position-if-not #'(lambda (arg) (not (eq arg 'x))) '(a b c)))
+(null (position-if-not #'(lambda (x) (not (eq x 'a))) '(a b c) :start 1))
+(null (position-if-not #'(lambda (x) (not (eq x 'b))) '(a b c) :start 2))
+(null (position-if-not #'(lambda (x) (not (eq x 'c))) '(a b c) :start 3))
+(null (position-if-not #'(lambda (x) (not (eq x 'a))) '(a b c) :start 0 :end 0))
+(null (position-if-not #'(lambda (x) (not (eq x 'a))) '(a b c)
+ :start 0 :end 0 :from-end t))
+(null (position-if-not #'(lambda (x) (not (eq x 'a))) '(a b c) :start 1 :end 1))
+(null (position-if-not #'(lambda (x) (not (eq x 'a))) '(a b c)
+ :start 1 :end 1 :from-end t))
+(null (position-if-not #'(lambda (x) (not (eq x 'a))) '(a b c) :start 2 :end 2))
+(null (position-if-not #'(lambda (x) (not (eq x 'a))) '(a b c)
+ :start 2 :end 2 :from-end t))
+(null (position-if-not #'(lambda (x) (not (eq x 'a))) '(a b c) :start 3 :end 3))
+(null (position-if-not #'(lambda (x) (not (eq x 'a))) '(a b c)
+ :start 3 :end 3 :from-end t))
+(eql (position-if-not #'(lambda (x) (not (eq x 'a))) '(a b c) :end nil) 0)
+(eql (position-if-not #'(lambda (x) (not (eq x 'b))) '(a b c) :end nil) 1)
+(eql (position-if-not #'(lambda (x) (not (eq x 'c))) '(a b c) :end nil) 2)
+(eql (position-if-not #'(lambda (x) (not (eq x 'a))) '(a b c) :end 1) 0)
+(eql (position-if-not #'(lambda (x) (not (eq x 'b))) '(a b c) :end 2) 1)
+(eql (position-if-not #'(lambda (x) (not (eq x 'c))) '(a b c) :end 3) 2)
+(null (position-if-not #'(lambda (x) (not (eq x 'a))) '(a b c) :end 0))
+(null (position-if-not #'(lambda (x) (not (eq x 'b))) '(a b c) :end 1))
+(null (position-if-not #'(lambda (x) (not (eq x 'c))) '(a b c) :end 2))
+(null (position-if-not #'(lambda (x) (not (eq x 'a))) '((a) (b) (c))))
+(eql (position-if-not #'(lambda (x) (not (eq x 'a))) '((a) (b) (c)) :key #'car)
+ 0)
+(eql (position-if-not #'(lambda (x) (not (eq x 'b))) '((a) (b) (c)) :key #'car)
+ 1)
+(eql (position-if-not #'(lambda (x) (not (eq x 'c))) '((a) (b) (c)) :key #'car)
+ 2)
+(null (position-if-not #'(lambda (x) (not (eq x 'z))) '((a) (b) (c))
+ :key #'car))
+(eql (position-if-not #'(lambda (x) (not (eq x 'a)))
+ '((a) (b) (c) (a a) (b b) (c c)) :key #'car)
+ 0)
+(eql (position-if-not #'(lambda (x) (not (eq x 'a)))
+ '((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t)
+ 3)
+(eql (position-if-not #'(lambda (x) (not (eq x 'b)))
+ '((a) (b) (c) (a a) (b b) (c c)) :key #'car)
+ 1)
+(eql (position-if-not #'(lambda (x) (not (eq x 'b)))
+ '((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t)
+ 4)
+(eql (position-if-not #'(lambda (x) (not (eq x 'c)))
+ '((a) (b) (c) (a a) (b b) (c c)) :key #'car)
+ 2)
+(eql (position-if-not #'(lambda (x) (not (eq x 'c)))
+ '((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t)
+ 5)
+(null (position-if-not #'(lambda (x) (not (eq x 'z)))
+ '((a) (b) (c) (a a) (b b) (c c)) :key #'car))
+(null (position-if-not #'(lambda (x) (not (eq x 'z)))
+ '((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t))
+(eql (position-if-not #'(lambda (x) (not (eq x 'a)))
+ '((a) (b) (c) (a a) (b b) (c c) (a a a))
+ :key #'car
+ :from-end t)
+ 6)
+(eql (position-if-not #'(lambda (x) (not (eq x 'a)))
+ '((a) (b) (c) (a a) (b b) (c c) (a a a))
+ :key #'car
+ :from-end t
+ :end nil)
+ 6)
+(eql (position-if-not #'(lambda (x) (not (eq x 'a)))
+ '((a) (b) (c) (a a) (b b) (c c) (a a a))
+ :key #'car
+ :from-end t
+ :end 6)
+ 3)
+(null (position-if-not #'(lambda (x) (not (eq x 'a)))
+ '((a) (b) (c) (a a) (b b) (c c) (a a a))
+ :key #'car
+ :from-end t
+ :start 1
+ :end 3))
+(null (position-if-not #'(lambda (x) (not (eql x #\c))) '("abc" "bcd" "cde")))
+(eql (position-if-not #'(lambda (x) (not (eql x #\c))) '("abc" "bcd" "cde")
+ :key #'(lambda (arg) (char arg 0)))
+ 2)
+(eql (position-if-not #'(lambda (x) (not (char> #\c x))) '("abc" "bcd" "cde")
+ :key #'(lambda (arg) (char arg 0)))
+ 0)
+(eql (position-if-not #'(lambda (x) (not (char> #\c x))) '("abc" "bcd" "cde")
+ :start 1
+ :key #'(lambda (arg) (char arg 0)))
+ 1)
+
+(eql (position-if-not #'(lambda (x) (not (eq x 'a))) #(a b c)) 0)
+(eql (position-if-not #'(lambda (x) (not (eq x 'b))) #(a b c)) 1)
+(eql (position-if-not #'(lambda (x) (not (eq x 'c))) #(a b c)) 2)
+(null (position-if-not #'(lambda (arg) (not (eq arg 'x))) #(a b c)))
+(null (position-if-not #'(lambda (x) (not (eq x 'a))) #(a b c) :start 1))
+(null (position-if-not #'(lambda (x) (not (eq x 'b))) #(a b c) :start 2))
+(null (position-if-not #'(lambda (x) (not (eq x 'c))) #(a b c) :start 3))
+(null (position-if-not #'(lambda (x) (not (eq x 'a))) #(a b c) :start 0 :end 0))
+(null (position-if-not #'(lambda (x) (not (eq x 'a))) #(a b c) :start 0 :end 0
+ :from-end t))
+(null (position-if-not #'(lambda (x) (not (eq x 'a))) #(a b c) :start 1 :end 1))
+(null (position-if-not #'(lambda (x) (not (eq x 'a))) #(a b c) :start 1 :end 1
+ :from-end t))
+(null (position-if-not #'(lambda (x) (not (eq x 'a))) #(a b c) :start 2 :end 2))
+(null (position-if-not #'(lambda (x) (not (eq x 'a))) #(a b c) :start 2 :end 2
+ :from-end t))
+(null (position-if-not #'(lambda (x) (not (eq x 'a))) #(a b c) :start 3 :end 3))
+(null (position-if-not #'(lambda (x) (not (eq x 'a))) #(a b c) :start 3 :end 3
+ :from-end t))
+(eql (position-if-not #'(lambda (x) (not (eq x 'a))) #(a b c) :end nil) 0)
+(eql (position-if-not #'(lambda (x) (not (eq x 'b))) #(a b c) :end nil) 1)
+(eql (position-if-not #'(lambda (x) (not (eq x 'c))) #(a b c) :end nil) 2)
+(eql (position-if-not #'(lambda (x) (not (eq x 'a))) #(a b c) :end 1) 0)
+(eql (position-if-not #'(lambda (x) (not (eq x 'b))) #(a b c) :end 2) 1)
+(eql (position-if-not #'(lambda (x) (not (eq x 'c))) #(a b c) :end 3) 2)
+(null (position-if-not #'(lambda (x) (not (eq x 'a))) #(a b c) :end 0))
+(null (position-if-not #'(lambda (x) (not (eq x 'b))) #(a b c) :end 1))
+(null (position-if-not #'(lambda (x) (not (eq x 'c))) #(a b c) :end 2))
+(null (position-if-not #'(lambda (x) (not (eq x 'a))) #((a) (b) (c))))
+(eql (position-if-not #'(lambda (x) (not (eq x 'a))) #((a) (b) (c)) :key #'car)
+ 0)
+(eql (position-if-not #'(lambda (x) (not (eq x 'b))) #((a) (b) (c)) :key #'car)
+ 1)
+(eql (position-if-not #'(lambda (x) (not (eq x 'c))) #((a) (b) (c)) :key #'car)
+ 2)
+(null (position-if-not #'(lambda (x) (not (eq x 'z))) #((a) (b) (c))
+ :key #'car))
+(eql (position-if-not #'(lambda (x) (not (eq x 'a)))
+ #((a) (b) (c) (a a) (b b) (c c)) :key #'car)
+ 0)
+(eql (position-if-not #'(lambda (x) (not (eq x 'a)))
+ #((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t)
+ 3)
+(eql (position-if-not #'(lambda (x) (not (eq x 'b)))
+ #((a) (b) (c) (a a) (b b) (c c)) :key #'car)
+ 1)
+(eql (position-if-not #'(lambda (x) (not (eq x 'b)))
+ #((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t)
+ 4)
+(eql (position-if-not #'(lambda (x) (not (eq x 'c)))
+ #((a) (b) (c) (a a) (b b) (c c)) :key #'car)
+ 2)
+(eql (position-if-not #'(lambda (x) (not (eq x 'c)))
+ #((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t)
+ 5)
+(null (position-if-not #'(lambda (x) (not (eq x 'z)))
+ #((a) (b) (c) (a a) (b b) (c c)) :key #'car))
+(null (position-if-not #'(lambda (x) (not (eq x 'z)))
+ #((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t))
+(eql (position-if-not #'(lambda (x) (not (eq x 'a)))
+ #((a) (b) (c) (a a) (b b) (c c) (a a a))
+ :key #'car
+ :from-end t)
+ 6)
+(eql (position-if-not #'(lambda (x) (not (eq x 'a)))
+ #((a) (b) (c) (a a) (b b) (c c) (a a a))
+ :key #'car
+ :from-end t
+ :end nil)
+ 6)
+(eql (position-if-not #'(lambda (x) (not (eq x 'a)))
+ #((a) (b) (c) (a a) (b b) (c c) (a a a))
+ :key #'car
+ :from-end t
+ :end 6)
+ 3)
+(null (position-if-not #'(lambda (x) (not (eq x 'a)))
+ #((a) (b) (c) (a a) (b b) (c c) (a a a))
+ :key #'car
+ :from-end t
+ :start 1
+ :end 3))
+(eql (position-if-not #'(lambda (x) (not (eql x #\c))) #("abc" "bcd" "cde")
+ :key #'(lambda (arg) (char arg 0)))
+ 2)
+(eql (position-if-not #'(lambda (x) (not (char> #\c x))) #("abc" "bcd" "cde")
+ :key #'(lambda (arg) (char arg 0)))
+ 0)
+(eql (position-if-not #'(lambda (x) (not (char> #\c x))) #("abc" "bcd" "cde")
+ :start 1
+ :key #'(lambda (arg) (char arg 0)))
+ 1)
+
+
+
+(eql (search "dog" "it's a dog's life") 7)
+(eql (search '(0 1) '(2 4 6 1 3 5) :key #'oddp) 2)
+
+
+(eql (search '() '()) 0)
+(null (search '(a b c) '(x y z)))
+(eql (search '() '(x y z)) 0)
+(eql (search '(a) '(a)) 0)
+(eql (search '(a b c) '(a b c x y z)) 0)
+(eql (search '(a b c) '(x a b c y z)) 1)
+(eql (search '(a b c) '(x y a b c z)) 2)
+(eql (search '(a b c) '(x y z a b c)) 3)
+(eql (search '(a b c) '(a b c a b c) :start2 1) 3)
+(eql (search '(a b c) '(a b c a b c) :start2 1 :end2 nil) 3)
+(eql (search '(a b c) '(a b c a b c) :start1 1 :start2 1 :end2 nil) 1)
+(eql (search '(a b c) '(a b c a b c) :start1 1 :end1 nil :start2 1 :end2 nil) 1)
+(null (search '(a b c) '(a b c a b c) :start2 0 :end2 0))
+(null (search '(a b c) '(a b c a b c) :start2 1 :end2 1))
+(null (search '(a b c) '(a b c a b c) :start2 2 :end2 2))
+(null (search '(a b c) '(a b c a b c) :start2 3 :end2 3))
+(null (search '(a b c) '(a b c a b c) :start2 4 :end2 4))
+(null (search '(a b c) '(a b c a b c) :start2 5 :end2 5))
+(null (search '(a b c) '(a b c a b c) :start2 6 :end2 6))
+(eql (search '(a b c) '(a b c a b c)) 0)
+(eql (search '(a b c) '(a b c a b c) :from-end t) 3)
+(eql (search '(a b c) '(a b c a b c) :start2 3 :end2 6) 3)
+(eql (search '(a b c) '(a b c a b c) :start2 3 :end2 6 :from-end t) 3)
+(eql (search '(a b c) '(a b c a b c)
+ :start1 0 :end1 2 :start2 0 :end2 6)
+ 0)
+(eql (search '(a b c) '(a b c a b c)
+ :start1 0 :end1 2 :start2 0 :end2 6 :from-end t)
+ 3)
+(eql (search '(a b c) '(a b c a b c) :start1 0 :end1 0 :start2 0 :end2 0) 0)
+(eql (search '(a b c) '(a b c a b c) :start1 1 :end1 1 :start2 0 :end2 0) 0)
+(eql (search '(a b c) '(a b c a b c) :start1 2 :end1 2 :start2 0 :end2 0) 0)
+(eql (search '(a b c) '(a b c a b c) :start1 3 :end1 3 :start2 0 :end2 0) 0)
+(eql (search '(a b c) '(a b c a b c) :start1 0 :end1 0 :start2 1 :end2 1) 1)
+(eql (search '(a b c) '(a b c a b c) :start1 1 :end1 1 :start2 1 :end2 1) 1)
+(eql (search '(a b c) '(a b c a b c) :start1 2 :end1 2 :start2 1 :end2 1) 1)
+(eql (search '(a b c) '(a b c a b c) :start1 3 :end1 3 :start2 1 :end2 1) 1)
+(eql (search '(a b c) '(a b c a b c) :start1 0 :end1 0 :start2 6 :end2 6) 6)
+(eql (search '(a b c) '(a b c a b c) :start1 1 :end1 1 :start2 6 :end2 6) 6)
+(eql (search '(a b c) '(a b c a b c) :start1 2 :end1 2 :start2 6 :end2 6) 6)
+(eql (search '(a b c) '(a b c a b c) :start1 3 :end1 3 :start2 6 :end2 6) 6)
+
+(eql (search '(a b c) '(a b c a b c) :start1 0 :end1 0 :start2 0 :end2 0
+ :from-end t) 0)
+(eql (search '(a b c) '(a b c a b c) :start1 1 :end1 1 :start2 0 :end2 0
+ :from-end t) 0)
+(eql (search '(a b c) '(a b c a b c) :start1 2 :end1 2 :start2 0 :end2 0
+ :from-end t) 0)
+(eql (search '(a b c) '(a b c a b c) :start1 3 :end1 3 :start2 0 :end2 0
+ :from-end t) 0)
+(eql (search '(a b c) '(a b c a b c) :start1 0 :end1 0 :start2 1 :end2 1
+ :from-end t) 1)
+(eql (search '(a b c) '(a b c a b c) :start1 1 :end1 1 :start2 1 :end2 1
+ :from-end t) 1)
+(eql (search '(a b c) '(a b c a b c) :start1 2 :end1 2 :start2 1 :end2 1
+ :from-end t) 1)
+(eql (search '(a b c) '(a b c a b c) :start1 3 :end1 3 :start2 1 :end2 1
+ :from-end t) 1)
+(eql (search '(a b c) '(a b c a b c) :start1 0 :end1 0 :start2 6 :end2 6
+ :from-end t) 6)
+(eql (search '(a b c) '(a b c a b c) :start1 1 :end1 1 :start2 6 :end2 6
+ :from-end t) 6)
+(eql (search '(a b c) '(a b c a b c) :start1 2 :end1 2 :start2 6 :end2 6
+ :from-end t) 6)
+(eql (search '(a b c) '(a b c a b c) :start1 3 :end1 3 :start2 6 :end2 6
+ :from-end t) 6)
+
+(null (search '(#\a #\b #\c) '(#\A #\B #\C)))
+(eql (search '(#\a #\b #\c) '(#\A #\B #\C) :test #'char-equal) 0)
+(eql (search '(#\a #\b #\c) '(#\A #\B #\C) :test-not (complement #'char-equal))
+ 0)
+(eql (search '(#\a #\b) '(#\a #\b #\x #\y #\z)) 0)
+(eql (search '(#\a #\b) '(#\a #\b #\x #\y #\z) :test #'char<) 1)
+(eql (search '(#\a #\b) '(#\a #\b #\x #\y #\z) :test-not (complement #'char<))
+ 1)
+(eql (search '(#\a #\b) '(#\a #\b #\x #\y #\z)
+ :test-not (complement #'char<)
+ :from-end t)
+ 3)
+
+(null (search '((a) (b)) '((x) (y) (z) (a) (b) (c))))
+(eql (search '((a) (b)) '((x) (y) (z) (a) (b) (c)) :key #'car) 3)
+(eql (search '((a) (b)) '((a) (b) (c) (x) (y) (z) (a) (b) (c)) :key #'car)
+ 0)
+(eql (search '((a) (b)) '((a) (b) (c) (x) (y) (z) (a) (b) (c))
+ :key #'car
+ :from-end t)
+ 6)
+
+(eql (search '((a a) (b b)) '((a) (b) (c) (x) (y) (z) (a) (b) (c)) :key #'car)
+ 0)
+(eql (search '((a a) (b b))
+ '((a nil) (b t) (c nil) (x) (y) (z) (a 0) (b 1) (c 2))
+ :key #'car
+ :from-end t)
+ 6)
+
+(eql (search '(("a" a) ("b" b))
+ '(("a" nil) ("b" t) ("c" nil) ("x") ("y") ("z")
+ ("A" 0) ("B" 1) ("C" 2))
+ :start1 1
+ :end1 2
+ :start2 3
+ :end2 nil
+ :key #'car
+ :test #'string-equal
+ :from-end t)
+ 7)
+
+
+(eql (search #() '()) 0)
+(null (search #(a b c) '(x y z)))
+(eql (search #() '(x y z)) 0)
+(eql (search #(a) '(a)) 0)
+(eql (search #(a b c) '(a b c x y z)) 0)
+(eql (search #(a b c) '(x a b c y z)) 1)
+(eql (search #(a b c) '(x y a b c z)) 2)
+(eql (search #(a b c) '(x y z a b c)) 3)
+(eql (search #(a b c) '(a b c a b c) :start2 1) 3)
+(eql (search #(a b c) '(a b c a b c) :start2 1 :end2 nil) 3)
+(eql (search #(a b c) '(a b c a b c) :start1 1 :start2 1 :end2 nil) 1)
+(eql (search #(a b c) '(a b c a b c) :start1 1 :end1 nil :start2 1 :end2 nil) 1)
+(null (search #(a b c) '(a b c a b c) :start2 0 :end2 0))
+(null (search #(a b c) '(a b c a b c) :start2 1 :end2 1))
+(null (search #(a b c) '(a b c a b c) :start2 2 :end2 2))
+(null (search #(a b c) '(a b c a b c) :start2 3 :end2 3))
+(null (search #(a b c) '(a b c a b c) :start2 4 :end2 4))
+(null (search #(a b c) '(a b c a b c) :start2 5 :end2 5))
+(null (search #(a b c) '(a b c a b c) :start2 6 :end2 6))
+(eql (search #(a b c) '(a b c a b c)) 0)
+(eql (search #(a b c) '(a b c a b c) :from-end t) 3)
+(eql (search #(a b c) '(a b c a b c) :start2 3 :end2 6) 3)
+(eql (search #(a b c) '(a b c a b c) :start2 3 :end2 6 :from-end t) 3)
+(eql (search #(a b c) '(a b c a b c)
+ :start1 0 :end1 2 :start2 0 :end2 6)
+ 0)
+(eql (search #(a b c) '(a b c a b c)
+ :start1 0 :end1 2 :start2 0 :end2 6 :from-end t)
+ 3)
+(eql (search #(a b c) '(a b c a b c) :start1 0 :end1 0 :start2 0 :end2 0) 0)
+(eql (search #(a b c) '(a b c a b c) :start1 1 :end1 1 :start2 0 :end2 0) 0)
+(eql (search #(a b c) '(a b c a b c) :start1 2 :end1 2 :start2 0 :end2 0) 0)
+(eql (search #(a b c) '(a b c a b c) :start1 3 :end1 3 :start2 0 :end2 0) 0)
+(eql (search #(a b c) '(a b c a b c) :start1 0 :end1 0 :start2 1 :end2 1) 1)
+(eql (search #(a b c) '(a b c a b c) :start1 1 :end1 1 :start2 1 :end2 1) 1)
+(eql (search #(a b c) '(a b c a b c) :start1 2 :end1 2 :start2 1 :end2 1) 1)
+(eql (search #(a b c) '(a b c a b c) :start1 3 :end1 3 :start2 1 :end2 1) 1)
+(eql (search #(a b c) '(a b c a b c) :start1 0 :end1 0 :start2 6 :end2 6) 6)
+(eql (search #(a b c) '(a b c a b c) :start1 1 :end1 1 :start2 6 :end2 6) 6)
+(eql (search #(a b c) '(a b c a b c) :start1 2 :end1 2 :start2 6 :end2 6) 6)
+(eql (search #(a b c) '(a b c a b c) :start1 3 :end1 3 :start2 6 :end2 6) 6)
+
+(eql (search #(a b c) '(a b c a b c) :start1 0 :end1 0 :start2 0 :end2 0
+ :from-end t) 0)
+(eql (search #(a b c) '(a b c a b c) :start1 1 :end1 1 :start2 0 :end2 0
+ :from-end t) 0)
+(eql (search #(a b c) '(a b c a b c) :start1 2 :end1 2 :start2 0 :end2 0
+ :from-end t) 0)
+(eql (search #(a b c) '(a b c a b c) :start1 3 :end1 3 :start2 0 :end2 0
+ :from-end t) 0)
+(eql (search #(a b c) '(a b c a b c) :start1 0 :end1 0 :start2 1 :end2 1
+ :from-end t) 1)
+(eql (search #(a b c) '(a b c a b c) :start1 1 :end1 1 :start2 1 :end2 1
+ :from-end t) 1)
+(eql (search #(a b c) '(a b c a b c) :start1 2 :end1 2 :start2 1 :end2 1
+ :from-end t) 1)
+(eql (search #(a b c) '(a b c a b c) :start1 3 :end1 3 :start2 1 :end2 1
+ :from-end t) 1)
+(eql (search #(a b c) '(a b c a b c) :start1 0 :end1 0 :start2 6 :end2 6
+ :from-end t) 6)
+(eql (search #(a b c) '(a b c a b c) :start1 1 :end1 1 :start2 6 :end2 6
+ :from-end t) 6)
+(eql (search #(a b c) '(a b c a b c) :start1 2 :end1 2 :start2 6 :end2 6
+ :from-end t) 6)
+(eql (search #(a b c) '(a b c a b c) :start1 3 :end1 3 :start2 6 :end2 6
+ :from-end t) 6)
+
+(null (search #(#\a #\b #\c) '(#\A #\B #\C)))
+(eql (search #(#\a #\b #\c) '(#\A #\B #\C) :test #'char-equal) 0)
+(eql (search #(#\a #\b #\c) '(#\A #\B #\C) :test-not (complement #'char-equal))
+ 0)
+(eql (search #(#\a #\b) '(#\a #\b #\x #\y #\z)) 0)
+(eql (search #(#\a #\b) '(#\a #\b #\x #\y #\z) :test #'char<) 1)
+(eql (search #(#\a #\b) '(#\a #\b #\x #\y #\z) :test-not (complement #'char<))
+ 1)
+(eql (search #(#\a #\b) '(#\a #\b #\x #\y #\z)
+ :test-not (complement #'char<)
+ :from-end t)
+ 3)
+
+(null (search #((a) (b)) '((x) (y) (z) (a) (b) (c))))
+(eql (search #((a) (b)) '((x) (y) (z) (a) (b) (c)) :key #'car) 3)
+(eql (search #((a) (b)) '((a) (b) (c) (x) (y) (z) (a) (b) (c)) :key #'car)
+ 0)
+(eql (search #((a) (b)) '((a) (b) (c) (x) (y) (z) (a) (b) (c))
+ :key #'car
+ :from-end t)
+ 6)
+
+(eql (search #((a a) (b b)) '((a) (b) (c) (x) (y) (z) (a) (b) (c)) :key #'car)
+ 0)
+(eql (search #((a a) (b b))
+ '((a nil) (b t) (c nil) (x) (y) (z) (a 0) (b 1) (c 2))
+ :key #'car
+ :from-end t)
+ 6)
+
+(eql (search #(("a" a) ("b" b))
+ '(("a" nil) ("b" t) ("c" nil) ("x") ("y") ("z")
+ ("A" 0) ("B" 1) ("C" 2))
+ :start1 1
+ :end1 2
+ :start2 3
+ :end2 nil
+ :key #'car
+ :test #'string-equal
+ :from-end t)
+ 7)
+
+
+(eql (search '() #()) 0)
+(null (search '(a b c) #(x y z)))
+(eql (search '() #(x y z)) 0)
+(eql (search '(a) #(a)) 0)
+(eql (search '(a b c) #(a b c x y z)) 0)
+(eql (search '(a b c) #(x a b c y z)) 1)
+(eql (search '(a b c) #(x y a b c z)) 2)
+(eql (search '(a b c) #(x y z a b c)) 3)
+(eql (search '(a b c) #(a b c a b c) :start2 1) 3)
+(eql (search '(a b c) #(a b c a b c) :start2 1 :end2 nil) 3)
+(eql (search '(a b c) #(a b c a b c) :start1 1 :start2 1 :end2 nil) 1)
+(eql (search '(a b c) #(a b c a b c) :start1 1 :end1 nil :start2 1 :end2 nil) 1)
+(null (search '(a b c) #(a b c a b c) :start2 0 :end2 0))
+(null (search '(a b c) #(a b c a b c) :start2 1 :end2 1))
+(null (search '(a b c) #(a b c a b c) :start2 2 :end2 2))
+(null (search '(a b c) #(a b c a b c) :start2 3 :end2 3))
+(null (search '(a b c) #(a b c a b c) :start2 4 :end2 4))
+(null (search '(a b c) #(a b c a b c) :start2 5 :end2 5))
+(null (search '(a b c) #(a b c a b c) :start2 6 :end2 6))
+(eql (search '(a b c) #(a b c a b c)) 0)
+(eql (search '(a b c) #(a b c a b c) :from-end t) 3)
+(eql (search '(a b c) #(a b c a b c) :start2 3 :end2 6) 3)
+(eql (search '(a b c) #(a b c a b c) :start2 3 :end2 6 :from-end t) 3)
+(eql (search '(a b c) #(a b c a b c)
+ :start1 0 :end1 2 :start2 0 :end2 6)
+ 0)
+(eql (search '(a b c) #(a b c a b c)
+ :start1 0 :end1 2 :start2 0 :end2 6 :from-end t)
+ 3)
+(eql (search '(a b c) #(a b c a b c) :start1 0 :end1 0 :start2 0 :end2 0) 0)
+(eql (search '(a b c) #(a b c a b c) :start1 1 :end1 1 :start2 0 :end2 0) 0)
+(eql (search '(a b c) #(a b c a b c) :start1 2 :end1 2 :start2 0 :end2 0) 0)
+(eql (search '(a b c) #(a b c a b c) :start1 3 :end1 3 :start2 0 :end2 0) 0)
+(eql (search '(a b c) #(a b c a b c) :start1 0 :end1 0 :start2 1 :end2 1) 1)
+(eql (search '(a b c) #(a b c a b c) :start1 1 :end1 1 :start2 1 :end2 1) 1)
+(eql (search '(a b c) #(a b c a b c) :start1 2 :end1 2 :start2 1 :end2 1) 1)
+(eql (search '(a b c) #(a b c a b c) :start1 3 :end1 3 :start2 1 :end2 1) 1)
+(eql (search '(a b c) #(a b c a b c) :start1 0 :end1 0 :start2 6 :end2 6) 6)
+(eql (search '(a b c) #(a b c a b c) :start1 1 :end1 1 :start2 6 :end2 6) 6)
+(eql (search '(a b c) #(a b c a b c) :start1 2 :end1 2 :start2 6 :end2 6) 6)
+(eql (search '(a b c) #(a b c a b c) :start1 3 :end1 3 :start2 6 :end2 6) 6)
+
+(eql (search '(a b c) #(a b c a b c) :start1 0 :end1 0 :start2 0 :end2 0
+ :from-end t) 0)
+(eql (search '(a b c) #(a b c a b c) :start1 1 :end1 1 :start2 0 :end2 0
+ :from-end t) 0)
+(eql (search '(a b c) #(a b c a b c) :start1 2 :end1 2 :start2 0 :end2 0
+ :from-end t) 0)
+(eql (search '(a b c) #(a b c a b c) :start1 3 :end1 3 :start2 0 :end2 0
+ :from-end t) 0)
+(eql (search '(a b c) #(a b c a b c) :start1 0 :end1 0 :start2 1 :end2 1
+ :from-end t) 1)
+(eql (search '(a b c) #(a b c a b c) :start1 1 :end1 1 :start2 1 :end2 1
+ :from-end t) 1)
+(eql (search '(a b c) #(a b c a b c) :start1 2 :end1 2 :start2 1 :end2 1
+ :from-end t) 1)
+(eql (search '(a b c) #(a b c a b c) :start1 3 :end1 3 :start2 1 :end2 1
+ :from-end t) 1)
+(eql (search '(a b c) #(a b c a b c) :start1 0 :end1 0 :start2 6 :end2 6
+ :from-end t) 6)
+(eql (search '(a b c) #(a b c a b c) :start1 1 :end1 1 :start2 6 :end2 6
+ :from-end t) 6)
+(eql (search '(a b c) #(a b c a b c) :start1 2 :end1 2 :start2 6 :end2 6
+ :from-end t) 6)
+(eql (search '(a b c) #(a b c a b c) :start1 3 :end1 3 :start2 6 :end2 6
+ :from-end t) 6)
+
+(null (search '(#\a #\b #\c) #(#\A #\B #\C)))
+(eql (search '(#\a #\b #\c) #(#\A #\B #\C) :test #'char-equal) 0)
+(eql (search '(#\a #\b #\c) #(#\A #\B #\C) :test-not (complement #'char-equal))
+ 0)
+(eql (search '(#\a #\b) #(#\a #\b #\x #\y #\z)) 0)
+(eql (search '(#\a #\b) #(#\a #\b #\x #\y #\z) :test #'char<) 1)
+(eql (search '(#\a #\b) #(#\a #\b #\x #\y #\z) :test-not (complement #'char<))
+ 1)
+(eql (search '(#\a #\b) #(#\a #\b #\x #\y #\z)
+ :test-not (complement #'char<)
+ :from-end t)
+ 3)
+
+(null (search '((a) (b)) #((x) (y) (z) (a) (b) (c))))
+(eql (search '((a) (b)) #((x) (y) (z) (a) (b) (c)) :key #'car) 3)
+(eql (search '((a) (b)) #((a) (b) (c) (x) (y) (z) (a) (b) (c)) :key #'car)
+ 0)
+(eql (search '((a) (b)) #((a) (b) (c) (x) (y) (z) (a) (b) (c))
+ :key #'car
+ :from-end t)
+ 6)
+
+(eql (search '((a a) (b b)) #((a) (b) (c) (x) (y) (z) (a) (b) (c)) :key #'car)
+ 0)
+(eql (search '((a a) (b b))
+ #((a nil) (b t) (c nil) (x) (y) (z) (a 0) (b 1) (c 2))
+ :key #'car
+ :from-end t)
+ 6)
+
+(eql (search '(("a" a) ("b" b))
+ #(("a" nil) ("b" t) ("c" nil) ("x") ("y") ("z")
+ ("A" 0) ("B" 1) ("C" 2))
+ :start1 1
+ :end1 2
+ :start2 3
+ :end2 nil
+ :key #'car
+ :test #'string-equal
+ :from-end t)
+ 7)
+
+
+(eql (search #() #()) 0)
+(null (search #(a b c) #(x y z)))
+(eql (search #() #(x y z)) 0)
+(eql (search #(a) #(a)) 0)
+(eql (search #(a b c) #(a b c x y z)) 0)
+(eql (search #(a b c) #(x a b c y z)) 1)
+(eql (search #(a b c) #(x y a b c z)) 2)
+(eql (search #(a b c) #(x y z a b c)) 3)
+(eql (search #(a b c) #(a b c a b c) :start2 1) 3)
+(eql (search #(a b c) #(a b c a b c) :start2 1 :end2 nil) 3)
+(eql (search #(a b c) #(a b c a b c) :start1 1 :start2 1 :end2 nil) 1)
+(eql (search #(a b c) #(a b c a b c) :start1 1 :end1 nil :start2 1 :end2 nil) 1)
+(null (search #(a b c) #(a b c a b c) :start2 0 :end2 0))
+(null (search #(a b c) #(a b c a b c) :start2 1 :end2 1))
+(null (search #(a b c) #(a b c a b c) :start2 2 :end2 2))
+(null (search #(a b c) #(a b c a b c) :start2 3 :end2 3))
+(null (search #(a b c) #(a b c a b c) :start2 4 :end2 4))
+(null (search #(a b c) #(a b c a b c) :start2 5 :end2 5))
+(null (search #(a b c) #(a b c a b c) :start2 6 :end2 6))
+(eql (search #(a b c) #(a b c a b c)) 0)
+(eql (search #(a b c) #(a b c a b c) :from-end t) 3)
+(eql (search #(a b c) #(a b c a b c) :start2 3 :end2 6) 3)
+(eql (search #(a b c) #(a b c a b c) :start2 3 :end2 6 :from-end t) 3)
+(eql (search #(a b c) #(a b c a b c)
+ :start1 0 :end1 2 :start2 0 :end2 6)
+ 0)
+(eql (search #(a b c) #(a b c a b c)
+ :start1 0 :end1 2 :start2 0 :end2 6 :from-end t)
+ 3)
+(eql (search #(a b c) #(a b c a b c) :start1 0 :end1 0 :start2 0 :end2 0) 0)
+(eql (search #(a b c) #(a b c a b c) :start1 1 :end1 1 :start2 0 :end2 0) 0)
+(eql (search #(a b c) #(a b c a b c) :start1 2 :end1 2 :start2 0 :end2 0) 0)
+(eql (search #(a b c) #(a b c a b c) :start1 3 :end1 3 :start2 0 :end2 0) 0)
+(eql (search #(a b c) #(a b c a b c) :start1 0 :end1 0 :start2 1 :end2 1) 1)
+(eql (search #(a b c) #(a b c a b c) :start1 1 :end1 1 :start2 1 :end2 1) 1)
+(eql (search #(a b c) #(a b c a b c) :start1 2 :end1 2 :start2 1 :end2 1) 1)
+(eql (search #(a b c) #(a b c a b c) :start1 3 :end1 3 :start2 1 :end2 1) 1)
+(eql (search #(a b c) #(a b c a b c) :start1 0 :end1 0 :start2 6 :end2 6) 6)
+(eql (search #(a b c) #(a b c a b c) :start1 1 :end1 1 :start2 6 :end2 6) 6)
+(eql (search #(a b c) #(a b c a b c) :start1 2 :end1 2 :start2 6 :end2 6) 6)
+(eql (search #(a b c) #(a b c a b c) :start1 3 :end1 3 :start2 6 :end2 6) 6)
+
+(eql (search #(a b c) #(a b c a b c) :start1 0 :end1 0 :start2 0 :end2 0
+ :from-end t) 0)
+(eql (search #(a b c) #(a b c a b c) :start1 1 :end1 1 :start2 0 :end2 0
+ :from-end t) 0)
+(eql (search #(a b c) #(a b c a b c) :start1 2 :end1 2 :start2 0 :end2 0
+ :from-end t) 0)
+(eql (search #(a b c) #(a b c a b c) :start1 3 :end1 3 :start2 0 :end2 0
+ :from-end t) 0)
+(eql (search #(a b c) #(a b c a b c) :start1 0 :end1 0 :start2 1 :end2 1
+ :from-end t) 1)
+(eql (search #(a b c) #(a b c a b c) :start1 1 :end1 1 :start2 1 :end2 1
+ :from-end t) 1)
+(eql (search #(a b c) #(a b c a b c) :start1 2 :end1 2 :start2 1 :end2 1
+ :from-end t) 1)
+(eql (search #(a b c) #(a b c a b c) :start1 3 :end1 3 :start2 1 :end2 1
+ :from-end t) 1)
+(eql (search #(a b c) #(a b c a b c) :start1 0 :end1 0 :start2 6 :end2 6
+ :from-end t) 6)
+(eql (search #(a b c) #(a b c a b c) :start1 1 :end1 1 :start2 6 :end2 6
+ :from-end t) 6)
+(eql (search #(a b c) #(a b c a b c) :start1 2 :end1 2 :start2 6 :end2 6
+ :from-end t) 6)
+(eql (search #(a b c) #(a b c a b c) :start1 3 :end1 3 :start2 6 :end2 6
+ :from-end t) 6)
+
+(null (search #(#\a #\b #\c) #(#\A #\B #\C)))
+(eql (search #(#\a #\b #\c) #(#\A #\B #\C) :test #'char-equal) 0)
+(eql (search #(#\a #\b #\c) #(#\A #\B #\C) :test-not (complement #'char-equal))
+ 0)
+(eql (search #(#\a #\b) #(#\a #\b #\x #\y #\z)) 0)
+(eql (search #(#\a #\b) #(#\a #\b #\x #\y #\z) :test #'char<) 1)
+(eql (search #(#\a #\b) #(#\a #\b #\x #\y #\z) :test-not (complement #'char<))
+ 1)
+(eql (search #(#\a #\b) #(#\a #\b #\x #\y #\z)
+ :test-not (complement #'char<)
+ :from-end t)
+ 3)
+
+(null (search #((a) (b)) #((x) (y) (z) (a) (b) (c))))
+(eql (search #((a) (b)) #((x) (y) (z) (a) (b) (c)) :key #'car) 3)
+(eql (search #((a) (b)) #((a) (b) (c) (x) (y) (z) (a) (b) (c)) :key #'car)
+ 0)
+(eql (search #((a) (b)) #((a) (b) (c) (x) (y) (z) (a) (b) (c))
+ :key #'car
+ :from-end t)
+ 6)
+
+(eql (search #((a a) (b b)) #((a) (b) (c) (x) (y) (z) (a) (b) (c)) :key #'car)
+ 0)
+(eql (search #((a a) (b b))
+ #((a nil) (b t) (c nil) (x) (y) (z) (a 0) (b 1) (c 2))
+ :key #'car
+ :from-end t)
+ 6)
+
+(eql (search #(("a" a) ("b" b))
+ #(("a" nil) ("b" t) ("c" nil) ("x") ("y") ("z")
+ ("A" 0) ("B" 1) ("C" 2))
+ :start1 1
+ :end1 2
+ :start2 3
+ :end2 nil
+ :key #'car
+ :test #'string-equal
+ :from-end t)
+ 7)
+
+
+(null (search "peace" "LOVE&PEACE"))
+(eql (search "peace" "LOVE&PEACE" :test #'char-equal) 5)
+(eql (search (concatenate 'simple-vector "peace")
+ (concatenate 'list "LOVE&PEACE") :test #'char-equal)
+ 5)
+(eql (search (concatenate 'list "peace")
+ (concatenate 'vector "LOVE&PEACE") :test #'char-equal)
+ 5)
+(eql (search (concatenate 'vector "peace")
+ (concatenate 'vector "LOVE&PEACE") :test #'char-equal)
+ 5)
+
+(eql (search #*10 #*010101) 1)
+(eql (search #*10 #*010101 :from-end t) 3)
+
+
+(null (search "PeAcE" "LoVe&pEaCe"))
+(eql (search "PeAcE" "LoVe&pEaCe" :key #'char-upcase) 5)
+(eql (search "abc" "abc xyz abc" :from-end t) 8)
+(eql (search "abc" "abc xyz abc xyz abc xyz abc"
+ :start2 8
+ :end2 19)
+ 8)
+(eql (search "abc" "abc xyz abc xyz abc xyz abc"
+ :from-end t
+ :start2 8
+ :end2 19)
+ 16)
+
+
+
+(eql (mismatch "abcd" "ABCDE" :test #'char-equal) 4)
+(eql (mismatch '(3 2 1 1 2 3) '(1 2 3) :from-end t) 3)
+(null (mismatch '(1 2 3) '(2 3 4) :test-not #'eq :key #'oddp))
+(null (mismatch '(1 2 3 4 5 6) '(3 4 5 6 7) :start1 2 :end2 4))
+
+
+(null (mismatch '() '()))
+(eql (mismatch '(a b c) '(x y z)) 0)
+(eql (mismatch '() '(x y z)) 0)
+(eql (mismatch '(x y z) '()) 0)
+(null (mismatch '(a) '(a)))
+(eql (mismatch '(a b c x y z) '(a b c)) 3)
+(null (mismatch '(a b c) '(a b c)))
+(eql (mismatch '(a b c d e f) '(a b c)) 3)
+(eql (mismatch '(a b c) '(a b c d e f)) 3)
+(eql (mismatch '(a b c) '(a b x)) 2)
+(eql (mismatch '(a b c) '(a x c)) 1)
+(eql (mismatch '(a b c) '(x b c)) 0)
+(eql (mismatch '(x y z a b c x y z) '(a b c) :start1 3) 6)
+(eql (mismatch '(x y z a b c x y z) '(a b c) :start1 3 :end1 nil) 6)
+(eql (mismatch '(x y z a b c x y z) '(a b c) :start1 3 :end1 4) 4)
+(eql (mismatch '(x y z a b c x y z) '(a b c) :start1 3 :end1 3) 3)
+(null (mismatch '(x y z) '() :start1 0 :end1 0))
+(null (mismatch '(x y z) '() :start1 1 :end1 1))
+(null (mismatch '(x y z) '() :start1 2 :end1 2))
+(null (mismatch '(x y z) '() :start1 3 :end1 3))
+(null (mismatch '(x y z) '() :start1 0 :end1 0 :start2 0 :end2 0))
+(null (mismatch '(x y z) '() :start1 1 :end1 1 :start2 1 :end2 1))
+(null (mismatch '(x y z) '() :start1 2 :end1 2 :start2 2 :end2 2))
+(null (mismatch '(x y z) '() :start1 3 :end1 3 :start2 3 :end2 3))
+(null (mismatch '(x y z) '() :start1 0 :end1 0 :start2 3 :end2 3))
+(null (mismatch '(x y z) '() :start1 1 :end1 1 :start2 2 :end2 2))
+(null (mismatch '(x y z) '() :start1 2 :end1 2 :start2 1 :end2 1))
+(null (mismatch '(x y z) '() :start1 3 :end1 3 :start2 0 :end2 0))
+(eql (mismatch '(x y z) '(a b c) :start1 0 :end1 0) 0)
+(eql (mismatch '(x y z) '(a b c) :start1 1 :end1 1) 1)
+(eql (mismatch '(x y z) '(a b c) :start1 2 :end1 2) 2)
+(eql (mismatch '(x y z) '(a b c) :start1 3 :end1 3) 3)
+(eql (mismatch '(x y z) '(x y z) :start1 0 :end1 1) 1)
+(eql (mismatch '(x y z) '(x y z) :start1 0 :end1 2) 2)
+(eql (mismatch '(x y z) '(x y z Z) :start1 0 :end1 3) 3)
+(null (mismatch '(x y z) '(x y z) :start1 0 :end1 3))
+(eql (mismatch '(a b c x y z) '(x y z a b c)) 0)
+(eql (mismatch '(a b c x y z) '(x y z a b c) :start1 3) 6)
+(eql (mismatch '(a b c x y z a b c) '(x y z a b c x y z) :start1 3) 9)
+(eql (mismatch '(a b c x y z a b c) '(x y z a b c x y z) :start1 6) 6)
+(eql (mismatch '(a b c x y z a b c) '(x y z a b c x y z) :start1 6 :start2 3)
+ 9)
+(eql (mismatch '(a b c x y z a b c) '(x y z a b c x y z) :start1 0 :start2 3)
+ 6)
+(eql (mismatch '(a b c) '(a b c x y z)) 3)
+(eql (mismatch '(a b c) '(x a b c y z)) 0)
+(eql (mismatch '(a b c) '(x a b c y z) :start2 1) 3)
+(eql (mismatch '(a b c) '(x a b c y z) :start2 1 :end2 nil) 3)
+(null (mismatch '(a b c) '(x a b c y z) :start2 1 :end2 4))
+
+(eql (mismatch '(a b c d e) '(c d)) 0)
+(eql (mismatch '(a b c d e) '(c d) :start1 2) 4)
+(eql (mismatch '(a b c d e) '(c d) :start1 2 :end1 3) 3)
+(eql (mismatch '(a b c d e) '(c d) :start1 2 :start2 1) 2)
+(eql (mismatch '(a b c d e) '(c d) :start1 3 :start2 1) 4)
+(eql (mismatch '(a b c d e) '(c d) :start1 2 :end2 1) 3)
+(null (mismatch '(a b c d) '(a b c d) :start1 1 :end1 2 :start2 1 :end2 2))
+(null (mismatch '(a b c d) '(a b c d) :start1 1 :end1 3 :start2 1 :end2 3))
+(null (mismatch '(a b c d) '(a b c d) :start1 1 :end1 4 :start2 1 :end2 4))
+(eql (mismatch '(a b c d) '(a b c d) :start1 1 :end1 nil :start2 1 :end2 1) 1)
+(eql (mismatch '(a b c d) '(a b c d) :start1 1 :end1 nil :start2 1 :end2 2) 2)
+(eql (mismatch '(a b c d) '(a b c d) :start1 1 :end1 nil :start2 1 :end2 3) 3)
+(null (mismatch '(a b c d) '(a b c d) :start1 1 :end1 nil :start2 1 :end2 4))
+(eql (mismatch '(a b c d) '(a b c d) :start1 1 :end1 1 :start2 1) 1)
+(eql (mismatch '(a b c d) '(a b c d) :start1 1 :end1 2 :start2 1) 2)
+(eql (mismatch '(a b c d) '(a b c d) :start1 1 :end1 3 :start2 1) 3)
+(null (mismatch '(a b c d) '(a b c d) :start1 1 :end1 4 :start2 1))
+
+(null (mismatch '(a b c) '(a b c) :from-end t))
+(eql (mismatch '(a b c d) '(a b c) :from-end t) 4)
+(eql (mismatch '(a b c) '(c) :from-end t) 2)
+(eql (mismatch '(a b c) '(z a b c) :from-end t) 0)
+(eql (mismatch '(a b c) '(x y z a b c) :from-end t) 0)
+(eql (mismatch '(x y z a b c) '(a b c) :from-end t) 3)
+(eql (mismatch '(x y z a b c) '(a b c) :end1 3 :from-end t) 3)
+(eql (mismatch '(x y z a b c) '(a b c) :end1 5 :from-end t) 5)
+(eql (mismatch '(x y z a b c x y z) '(a b c) :end1 6 :from-end t) 3)
+(eql (mismatch '(x y z a b c x y z) '(a b c) :start1 2 :end1 6 :from-end t) 3)
+(eql (mismatch '(x y z a b c x y z) '(a b c)
+ :from-end t
+ :start1 2 :end1 5
+ :start2 1 :end2 2
+ ) 4)
+(eql (mismatch '(x y z a b c x y z) '(a b c)
+ :start1 2 :end1 5
+ :start2 1 :end2 2
+ ) 2)
+(eql (mismatch '((a) (b) (c)) '((a) (b) (c))) 0)
+(null (mismatch '((a) (b) (c)) '((a) (b) (c)) :key #'car))
+(null (mismatch '((a) (b) (c)) '((a) (b) (c)) :test #'equal))
+(eql (mismatch '(#(a) #(b) #(c)) '(#(a) #(b) #(c))) 0)
+(null (mismatch '(#(a) #(b) #(c)) '(#(a) #(b) #(c)) :test #'equalp))
+(eql (mismatch '((a) (b) (c) (d)) '((a) (b) (c)) :key #'car) 3)
+(eql (mismatch '((a) (b) (c)) '((a) (b) (c) (d)) :key #'car) 3)
+(eql (mismatch '(#\a #\b #\c) '(#\A #\B #\C)) 0)
+(null (mismatch '(#\a #\b #\c) '(#\A #\B #\C) :key #'char-upcase))
+(null (mismatch '(#\a #\b #\c) '(#\A #\B #\C) :key #'char-downcase))
+(null (mismatch '(#\a #\b #\c) '(#\A #\B #\C)
+ :key #'char-upcase
+ :start1 1 :end1 2
+ :start2 1 :end2 2))
+(null (mismatch '(#\a #\b #\c) '(#\A #\B #\C)
+ :key #'char-upcase
+ :start1 2
+ :start2 2))
+(eql (mismatch '((a b c) (b c d) (d e f))
+ '((b b c) (c c d) (e e f)))
+ 0)
+(eql (mismatch '((a b c) (b c d) (d e f))
+ '((b b c) (c c d) (e e f))
+ :key #'cdr)
+ 0)
+(null (mismatch '((a b c) (b c d) (d e f))
+ '((b b c) (c c d) (e e f))
+ :key #'cdr
+ :test #'equal))
+(eql (mismatch '((a b c) (b c d) (d e f) (e f g))
+ '((b b c) (c c d) (e e f))
+ :key #'cdr
+ :test #'equal)
+ 3)
+(eql (mismatch '((a b c) (b c d) (d e f) (e f g))
+ '((b b c) (c c d) (e e f))
+ :key #'cdr
+ :test #'equal
+ :from-end t)
+ 4)
+(eql (mismatch '((a a a) (a b c) (b c d) (d e f))
+ '((b b c) (c c d) (e e f))
+ :key #'cdr
+ :test #'equal
+ :from-end t)
+ 1)
+(null (mismatch '((a a a) (a b c) (b c d) (d e f) (e f g))
+ '((b b c) (c c d) (e e f))
+ :key #'cdr
+ :test #'equal
+ :from-end t
+ :start1 1
+ :end1 4))
+(eql (mismatch '((a a a) (a b c) (b c d) (d e f) (e f g))
+ '((b b c) (c c d) (e e f))
+ :key #'cdr
+ :test #'equal
+ :from-end t
+ :start1 1)
+ 5)
+(eql (mismatch '((a a a) (a b c) (b c d) (d e f) (e f g))
+ '((b b c) (c c d) (e e f))
+ :key #'cdr
+ :test #'equal
+ :from-end t
+ :end1 3
+ :start2 1
+ :end2 2)
+
+ 2)
+
+
+(null (mismatch #() '()))
+(eql (mismatch #(a b c) '(x y z)) 0)
+(eql (mismatch #() '(x y z)) 0)
+(eql (mismatch #(x y z) '()) 0)
+(null (mismatch #(a) '(a)))
+(eql (mismatch #(a b c x y z) '(a b c)) 3)
+(null (mismatch #(a b c) '(a b c)))
+(eql (mismatch #(a b c d e f) '(a b c)) 3)
+(eql (mismatch #(a b c) '(a b c d e f)) 3)
+(eql (mismatch #(a b c) '(a b x)) 2)
+(eql (mismatch #(a b c) '(a x c)) 1)
+(eql (mismatch #(a b c) '(x b c)) 0)
+(eql (mismatch #(x y z a b c x y z) '(a b c) :start1 3) 6)
+(eql (mismatch #(x y z a b c x y z) '(a b c) :start1 3 :end1 nil) 6)
+(eql (mismatch #(x y z a b c x y z) '(a b c) :start1 3 :end1 4) 4)
+(eql (mismatch #(x y z a b c x y z) '(a b c) :start1 3 :end1 3) 3)
+(null (mismatch #(x y z) '() :start1 0 :end1 0))
+(null (mismatch #(x y z) '() :start1 1 :end1 1))
+(null (mismatch #(x y z) '() :start1 2 :end1 2))
+(null (mismatch #(x y z) '() :start1 3 :end1 3))
+(null (mismatch #(x y z) '() :start1 0 :end1 0 :start2 0 :end2 0))
+(null (mismatch #(x y z) '() :start1 1 :end1 1 :start2 1 :end2 1))
+(null (mismatch #(x y z) '() :start1 2 :end1 2 :start2 2 :end2 2))
+(null (mismatch #(x y z) '() :start1 3 :end1 3 :start2 3 :end2 3))
+(null (mismatch #(x y z) '() :start1 0 :end1 0 :start2 3 :end2 3))
+(null (mismatch #(x y z) '() :start1 1 :end1 1 :start2 2 :end2 2))
+(null (mismatch #(x y z) '() :start1 2 :end1 2 :start2 1 :end2 1))
+(null (mismatch #(x y z) '() :start1 3 :end1 3 :start2 0 :end2 0))
+(eql (mismatch #(x y z) '(a b c) :start1 0 :end1 0) 0)
+(eql (mismatch #(x y z) '(a b c) :start1 1 :end1 1) 1)
+(eql (mismatch #(x y z) '(a b c) :start1 2 :end1 2) 2)
+(eql (mismatch #(x y z) '(a b c) :start1 3 :end1 3) 3)
+(eql (mismatch #(x y z) '(x y z) :start1 0 :end1 1) 1)
+(eql (mismatch #(x y z) '(x y z) :start1 0 :end1 2) 2)
+(eql (mismatch #(x y z) '(x y z Z) :start1 0 :end1 3) 3)
+(null (mismatch #(x y z) '(x y z) :start1 0 :end1 3))
+(eql (mismatch #(a b c x y z) '(x y z a b c)) 0)
+(eql (mismatch #(a b c x y z) '(x y z a b c) :start1 3) 6)
+(eql (mismatch #(a b c x y z a b c) '(x y z a b c x y z) :start1 3) 9)
+(eql (mismatch #(a b c x y z a b c) '(x y z a b c x y z) :start1 6) 6)
+(eql (mismatch #(a b c x y z a b c) '(x y z a b c x y z) :start1 6 :start2 3)
+ 9)
+(eql (mismatch #(a b c x y z a b c) '(x y z a b c x y z) :start1 0 :start2 3)
+ 6)
+(eql (mismatch #(a b c) '(a b c x y z)) 3)
+(eql (mismatch #(a b c) '(x a b c y z)) 0)
+(eql (mismatch #(a b c) '(x a b c y z) :start2 1) 3)
+(eql (mismatch #(a b c) '(x a b c y z) :start2 1 :end2 nil) 3)
+(null (mismatch #(a b c) '(x a b c y z) :start2 1 :end2 4))
+(eql (mismatch #(a b c d e) '(c d)) 0)
+(eql (mismatch #(a b c d e) '(c d) :start1 2) 4)
+(eql (mismatch #(a b c d e) '(c d) :start1 2 :end1 3) 3)
+(eql (mismatch #(a b c d e) '(c d) :start1 2 :start2 1) 2)
+(eql (mismatch #(a b c d e) '(c d) :start1 3 :start2 1) 4)
+(eql (mismatch #(a b c d e) '(c d) :start1 2 :end2 1) 3)
+(null (mismatch #(a b c d) '(a b c d) :start1 1 :end1 2 :start2 1 :end2 2))
+(null (mismatch #(a b c d) '(a b c d) :start1 1 :end1 3 :start2 1 :end2 3))
+(null (mismatch #(a b c d) '(a b c d) :start1 1 :end1 4 :start2 1 :end2 4))
+(eql (mismatch #(a b c d) '(a b c d) :start1 1 :end1 nil :start2 1 :end2 1) 1)
+(eql (mismatch #(a b c d) '(a b c d) :start1 1 :end1 nil :start2 1 :end2 2) 2)
+(eql (mismatch #(a b c d) '(a b c d) :start1 1 :end1 nil :start2 1 :end2 3) 3)
+(null (mismatch #(a b c d) '(a b c d) :start1 1 :end1 nil :start2 1 :end2 4))
+(eql (mismatch #(a b c d) '(a b c d) :start1 1 :end1 1 :start2 1) 1)
+(eql (mismatch #(a b c d) '(a b c d) :start1 1 :end1 2 :start2 1) 2)
+(eql (mismatch #(a b c d) '(a b c d) :start1 1 :end1 3 :start2 1) 3)
+(null (mismatch #(a b c d) '(a b c d) :start1 1 :end1 4 :start2 1))
+(null (mismatch #(a b c) '(a b c) :from-end t))
+(eql (mismatch #(a b c d) '(a b c) :from-end t) 4)
+(eql (mismatch #(a b c) '(c) :from-end t) 2)
+(eql (mismatch #(a b c) '(z a b c) :from-end t) 0)
+(eql (mismatch #(a b c) '(x y z a b c) :from-end t) 0)
+(eql (mismatch #(x y z a b c) '(a b c) :from-end t) 3)
+(eql (mismatch #(x y z a b c) '(a b c) :end1 3 :from-end t) 3)
+(eql (mismatch #(x y z a b c) '(a b c) :end1 5 :from-end t) 5)
+(eql (mismatch #(x y z a b c x y z) '(a b c) :end1 6 :from-end t) 3)
+(eql (mismatch #(x y z a b c x y z) '(a b c) :start1 2 :end1 6 :from-end t) 3)
+(eql (mismatch #(x y z a b c x y z) '(a b c)
+ :from-end t
+ :start1 2 :end1 5
+ :start2 1 :end2 2
+ ) 4)
+(eql (mismatch #(x y z a b c x y z) '(a b c)
+ :start1 2 :end1 5
+ :start2 1 :end2 2
+ ) 2)
+(eql (mismatch #((a) (b) (c)) '((a) (b) (c))) 0)
+(null (mismatch #((a) (b) (c)) '((a) (b) (c)) :key #'car))
+(null (mismatch #((a) (b) (c)) '((a) (b) (c)) :test #'equal))
+(eql (mismatch #(#(a) #(b) #(c)) '(#(a) #(b) #(c))) 0)
+(null (mismatch #(#(a) #(b) #(c)) '(#(a) #(b) #(c)) :test #'equalp))
+(eql (mismatch #((a) (b) (c) (d)) '((a) (b) (c)) :key #'car) 3)
+(eql (mismatch #((a) (b) (c)) '((a) (b) (c) (d)) :key #'car) 3)
+(eql (mismatch #(#\a #\b #\c) '(#\A #\B #\C)) 0)
+(null (mismatch #(#\a #\b #\c) '(#\A #\B #\C) :key #'char-upcase))
+(null (mismatch #(#\a #\b #\c) '(#\A #\B #\C) :key #'char-downcase))
+(null (mismatch #(#\a #\b #\c) '(#\A #\B #\C)
+ :key #'char-upcase
+ :start1 1 :end1 2
+ :start2 1 :end2 2))
+(null (mismatch #(#\a #\b #\c) '(#\A #\B #\C)
+ :key #'char-upcase
+ :start1 2
+ :start2 2))
+(eql (mismatch #((a b c) (b c d) (d e f))
+ '((b b c) (c c d) (e e f)))
+ 0)
+(eql (mismatch #((a b c) (b c d) (d e f))
+ '((b b c) (c c d) (e e f))
+ :key #'cdr)
+ 0)
+(null (mismatch #((a b c) (b c d) (d e f))
+ '((b b c) (c c d) (e e f))
+ :key #'cdr
+ :test #'equal))
+(eql (mismatch #((a b c) (b c d) (d e f) (e f g))
+ '((b b c) (c c d) (e e f))
+ :key #'cdr
+ :test #'equal)
+ 3)
+(eql (mismatch #((a b c) (b c d) (d e f) (e f g))
+ '((b b c) (c c d) (e e f))
+ :key #'cdr
+ :test #'equal
+ :from-end t)
+ 4)
+(eql (mismatch #((a a a) (a b c) (b c d) (d e f))
+ '((b b c) (c c d) (e e f))
+ :key #'cdr
+ :test #'equal
+ :from-end t)
+ 1)
+(null (mismatch #((a a a) (a b c) (b c d) (d e f) (e f g))
+ '((b b c) (c c d) (e e f))
+ :key #'cdr
+ :test #'equal
+ :from-end t
+ :start1 1
+ :end1 4))
+(eql (mismatch #((a a a) (a b c) (b c d) (d e f) (e f g))
+ '((b b c) (c c d) (e e f))
+ :key #'cdr
+ :test #'equal
+ :from-end t
+ :start1 1)
+ 5)
+(eql (mismatch #((a a a) (a b c) (b c d) (d e f) (e f g))
+ '((b b c) (c c d) (e e f))
+ :key #'cdr
+ :test #'equal
+ :from-end t
+ :end1 3
+ :start2 1
+ :end2 2)
+
+ 2)
+
+
+(null (mismatch '() #()))
+(eql (mismatch '(a b c) #(x y z)) 0)
+(eql (mismatch '() #(x y z)) 0)
+(eql (mismatch '(x y z) #()) 0)
+(null (mismatch '(a) #(a)))
+(eql (mismatch '(a b c x y z) #(a b c)) 3)
+(null (mismatch '(a b c) #(a b c)))
+(eql (mismatch '(a b c d e f) #(a b c)) 3)
+(eql (mismatch '(a b c) #(a b c d e f)) 3)
+(eql (mismatch '(a b c) #(a b x)) 2)
+(eql (mismatch '(a b c) #(a x c)) 1)
+(eql (mismatch '(a b c) #(x b c)) 0)
+(eql (mismatch '(x y z a b c x y z) #(a b c) :start1 3) 6)
+(eql (mismatch '(x y z a b c x y z) #(a b c) :start1 3 :end1 nil) 6)
+(eql (mismatch '(x y z a b c x y z) #(a b c) :start1 3 :end1 4) 4)
+(eql (mismatch '(x y z a b c x y z) #(a b c) :start1 3 :end1 3) 3)
+(null (mismatch '(x y z) #() :start1 0 :end1 0))
+(null (mismatch '(x y z) #() :start1 1 :end1 1))
+(null (mismatch '(x y z) #() :start1 2 :end1 2))
+(null (mismatch '(x y z) #() :start1 3 :end1 3))
+(null (mismatch '(x y z) #() :start1 0 :end1 0 :start2 0 :end2 0))
+(null (mismatch '(x y z) #() :start1 1 :end1 1 :start2 1 :end2 1))
+(null (mismatch '(x y z) #() :start1 2 :end1 2 :start2 2 :end2 2))
+(null (mismatch '(x y z) #() :start1 3 :end1 3 :start2 3 :end2 3))
+(null (mismatch '(x y z) #() :start1 0 :end1 0 :start2 3 :end2 3))
+(null (mismatch '(x y z) #() :start1 1 :end1 1 :start2 2 :end2 2))
+(null (mismatch '(x y z) #() :start1 2 :end1 2 :start2 1 :end2 1))
+(null (mismatch '(x y z) #() :start1 3 :end1 3 :start2 0 :end2 0))
+(eql (mismatch '(x y z) #(a b c) :start1 0 :end1 0) 0)
+(eql (mismatch '(x y z) #(a b c) :start1 1 :end1 1) 1)
+(eql (mismatch '(x y z) #(a b c) :start1 2 :end1 2) 2)
+(eql (mismatch '(x y z) #(a b c) :start1 3 :end1 3) 3)
+(eql (mismatch '(x y z) #(x y z) :start1 0 :end1 1) 1)
+(eql (mismatch '(x y z) #(x y z) :start1 0 :end1 2) 2)
+(eql (mismatch '(x y z) #(x y z Z) :start1 0 :end1 3) 3)
+(null (mismatch '(x y z) #(x y z) :start1 0 :end1 3))
+(eql (mismatch '(a b c x y z) #(x y z a b c)) 0)
+(eql (mismatch '(a b c x y z) #(x y z a b c) :start1 3) 6)
+(eql (mismatch '(a b c x y z a b c) #(x y z a b c x y z) :start1 3) 9)
+(eql (mismatch '(a b c x y z a b c) #(x y z a b c x y z) :start1 6) 6)
+(eql (mismatch '(a b c x y z a b c) #(x y z a b c x y z) :start1 6 :start2 3)
+ 9)
+(eql (mismatch '(a b c x y z a b c) #(x y z a b c x y z) :start1 0 :start2 3)
+ 6)
+(eql (mismatch '(a b c) #(a b c x y z)) 3)
+(eql (mismatch '(a b c) #(x a b c y z)) 0)
+(eql (mismatch '(a b c) #(x a b c y z) :start2 1) 3)
+(eql (mismatch '(a b c) #(x a b c y z) :start2 1 :end2 nil) 3)
+(null (mismatch '(a b c) #(x a b c y z) :start2 1 :end2 4))
+(eql (mismatch '(a b c d e) #(c d)) 0)
+(eql (mismatch '(a b c d e) #(c d) :start1 2) 4)
+(eql (mismatch '(a b c d e) #(c d) :start1 2 :end1 3) 3)
+(eql (mismatch '(a b c d e) #(c d) :start1 2 :start2 1) 2)
+(eql (mismatch '(a b c d e) #(c d) :start1 3 :start2 1) 4)
+(eql (mismatch '(a b c d e) #(c d) :start1 2 :end2 1) 3)
+(null (mismatch '(a b c d) #(a b c d) :start1 1 :end1 2 :start2 1 :end2 2))
+(null (mismatch '(a b c d) #(a b c d) :start1 1 :end1 3 :start2 1 :end2 3))
+(null (mismatch '(a b c d) #(a b c d) :start1 1 :end1 4 :start2 1 :end2 4))
+(eql (mismatch '(a b c d) #(a b c d) :start1 1 :end1 nil :start2 1 :end2 1) 1)
+(eql (mismatch '(a b c d) #(a b c d) :start1 1 :end1 nil :start2 1 :end2 2) 2)
+(eql (mismatch '(a b c d) #(a b c d) :start1 1 :end1 nil :start2 1 :end2 3) 3)
+(null (mismatch '(a b c d) #(a b c d) :start1 1 :end1 nil :start2 1 :end2 4))
+(eql (mismatch '(a b c d) #(a b c d) :start1 1 :end1 1 :start2 1) 1)
+(eql (mismatch '(a b c d) #(a b c d) :start1 1 :end1 2 :start2 1) 2)
+(eql (mismatch '(a b c d) #(a b c d) :start1 1 :end1 3 :start2 1) 3)
+(null (mismatch '(a b c d) #(a b c d) :start1 1 :end1 4 :start2 1))
+(null (mismatch '(a b c) #(a b c) :from-end t))
+(eql (mismatch '(a b c d) #(a b c) :from-end t) 4)
+(eql (mismatch '(a b c) #(c) :from-end t) 2)
+(eql (mismatch '(a b c) #(z a b c) :from-end t) 0)
+(eql (mismatch '(a b c) #(x y z a b c) :from-end t) 0)
+(eql (mismatch '(x y z a b c) #(a b c) :from-end t) 3)
+(eql (mismatch '(x y z a b c) #(a b c) :end1 3 :from-end t) 3)
+(eql (mismatch '(x y z a b c) #(a b c) :end1 5 :from-end t) 5)
+(eql (mismatch '(x y z a b c x y z) #(a b c) :end1 6 :from-end t) 3)
+(eql (mismatch '(x y z a b c x y z) #(a b c) :start1 2 :end1 6 :from-end t) 3)
+(eql (mismatch '(x y z a b c x y z) #(a b c)
+ :from-end t
+ :start1 2 :end1 5
+ :start2 1 :end2 2
+ ) 4)
+(eql (mismatch '(x y z a b c x y z) #(a b c)
+ :start1 2 :end1 5
+ :start2 1 :end2 2
+ ) 2)
+(eql (mismatch '((a) (b) (c)) #((a) (b) (c))) 0)
+(null (mismatch '((a) (b) (c)) #((a) (b) (c)) :key #'car))
+(null (mismatch '((a) (b) (c)) #((a) (b) (c)) :test #'equal))
+(eql (mismatch '(#(a) #(b) #(c)) #(#(a) #(b) #(c))) 0)
+(null (mismatch '(#(a) #(b) #(c)) #(#(a) #(b) #(c)) :test #'equalp))
+(eql (mismatch '((a) (b) (c) (d)) #((a) (b) (c)) :key #'car) 3)
+(eql (mismatch '((a) (b) (c)) #((a) (b) (c) (d)) :key #'car) 3)
+(eql (mismatch '(#\a #\b #\c) #(#\A #\B #\C)) 0)
+(null (mismatch '(#\a #\b #\c) #(#\A #\B #\C) :key #'char-upcase))
+(null (mismatch '(#\a #\b #\c) #(#\A #\B #\C) :key #'char-downcase))
+(null (mismatch '(#\a #\b #\c) #(#\A #\B #\C)
+ :key #'char-upcase
+ :start1 1 :end1 2
+ :start2 1 :end2 2))
+(null (mismatch '(#\a #\b #\c) #(#\A #\B #\C)
+ :key #'char-upcase
+ :start1 2
+ :start2 2))
+(eql (mismatch '((a b c) (b c d) (d e f))
+ #((b b c) (c c d) (e e f)))
+ 0)
+(eql (mismatch '((a b c) (b c d) (d e f))
+ #((b b c) (c c d) (e e f))
+ :key #'cdr)
+ 0)
+(null (mismatch '((a b c) (b c d) (d e f))
+ #((b b c) (c c d) (e e f))
+ :key #'cdr
+ :test #'equal))
+(eql (mismatch '((a b c) (b c d) (d e f) (e f g))
+ #((b b c) (c c d) (e e f))
+ :key #'cdr
+ :test #'equal)
+ 3)
+(eql (mismatch '((a b c) (b c d) (d e f) (e f g))
+ #((b b c) (c c d) (e e f))
+ :key #'cdr
+ :test #'equal
+ :from-end t)
+ 4)
+(eql (mismatch '((a a a) (a b c) (b c d) (d e f))
+ #((b b c) (c c d) (e e f))
+ :key #'cdr
+ :test #'equal
+ :from-end t)
+ 1)
+(null (mismatch '((a a a) (a b c) (b c d) (d e f) (e f g))
+ #((b b c) (c c d) (e e f))
+ :key #'cdr
+ :test #'equal
+ :from-end t
+ :start1 1
+ :end1 4))
+(eql (mismatch '((a a a) (a b c) (b c d) (d e f) (e f g))
+ #((b b c) (c c d) (e e f))
+ :key #'cdr
+ :test #'equal
+ :from-end t
+ :start1 1)
+ 5)
+(eql (mismatch '((a a a) (a b c) (b c d) (d e f) (e f g))
+ #((b b c) (c c d) (e e f))
+ :key #'cdr
+ :test #'equal
+ :from-end t
+ :end1 3
+ :start2 1
+ :end2 2)
+
+ 2)
+
+
+(null (mismatch #() #()))
+(eql (mismatch #(a b c) #(x y z)) 0)
+(eql (mismatch #() #(x y z)) 0)
+(eql (mismatch #(x y z) #()) 0)
+(null (mismatch #(a) #(a)))
+(eql (mismatch #(a b c x y z) #(a b c)) 3)
+(null (mismatch #(a b c) #(a b c)))
+(eql (mismatch #(a b c d e f) #(a b c)) 3)
+(eql (mismatch #(a b c) #(a b c d e f)) 3)
+(eql (mismatch #(a b c) #(a b x)) 2)
+(eql (mismatch #(a b c) #(a x c)) 1)
+(eql (mismatch #(a b c) #(x b c)) 0)
+(eql (mismatch #(x y z a b c x y z) #(a b c) :start1 3) 6)
+(eql (mismatch #(x y z a b c x y z) #(a b c) :start1 3 :end1 nil) 6)
+(eql (mismatch #(x y z a b c x y z) #(a b c) :start1 3 :end1 4) 4)
+(eql (mismatch #(x y z a b c x y z) #(a b c) :start1 3 :end1 3) 3)
+(null (mismatch #(x y z) #() :start1 0 :end1 0))
+(null (mismatch #(x y z) #() :start1 1 :end1 1))
+(null (mismatch #(x y z) #() :start1 2 :end1 2))
+(null (mismatch #(x y z) #() :start1 3 :end1 3))
+(null (mismatch #(x y z) #() :start1 0 :end1 0 :start2 0 :end2 0))
+(null (mismatch #(x y z) #() :start1 1 :end1 1 :start2 1 :end2 1))
+(null (mismatch #(x y z) #() :start1 2 :end1 2 :start2 2 :end2 2))
+(null (mismatch #(x y z) #() :start1 3 :end1 3 :start2 3 :end2 3))
+(null (mismatch #(x y z) #() :start1 0 :end1 0 :start2 3 :end2 3))
+(null (mismatch #(x y z) #() :start1 1 :end1 1 :start2 2 :end2 2))
+(null (mismatch #(x y z) #() :start1 2 :end1 2 :start2 1 :end2 1))
+(null (mismatch #(x y z) #() :start1 3 :end1 3 :start2 0 :end2 0))
+(eql (mismatch #(x y z) #(a b c) :start1 0 :end1 0) 0)
+(eql (mismatch #(x y z) #(a b c) :start1 1 :end1 1) 1)
+(eql (mismatch #(x y z) #(a b c) :start1 2 :end1 2) 2)
+(eql (mismatch #(x y z) #(a b c) :start1 3 :end1 3) 3)
+(eql (mismatch #(x y z) #(x y z) :start1 0 :end1 1) 1)
+(eql (mismatch #(x y z) #(x y z) :start1 0 :end1 2) 2)
+(eql (mismatch #(x y z) #(x y z Z) :start1 0 :end1 3) 3)
+(null (mismatch #(x y z) #(x y z) :start1 0 :end1 3))
+(eql (mismatch #(a b c x y z) #(x y z a b c)) 0)
+(eql (mismatch #(a b c x y z) #(x y z a b c) :start1 3) 6)
+(eql (mismatch #(a b c x y z a b c) #(x y z a b c x y z) :start1 3) 9)
+(eql (mismatch #(a b c x y z a b c) #(x y z a b c x y z) :start1 6) 6)
+(eql (mismatch #(a b c x y z a b c) #(x y z a b c x y z) :start1 6 :start2 3)
+ 9)
+(eql (mismatch #(a b c x y z a b c) #(x y z a b c x y z) :start1 0 :start2 3)
+ 6)
+(eql (mismatch #(a b c) #(a b c x y z)) 3)
+(eql (mismatch #(a b c) #(x a b c y z)) 0)
+(eql (mismatch #(a b c) #(x a b c y z) :start2 1) 3)
+(eql (mismatch #(a b c) #(x a b c y z) :start2 1 :end2 nil) 3)
+(null (mismatch #(a b c) #(x a b c y z) :start2 1 :end2 4))
+(eql (mismatch #(a b c d e) #(c d)) 0)
+(eql (mismatch #(a b c d e) #(c d) :start1 2) 4)
+(eql (mismatch #(a b c d e) #(c d) :start1 2 :end1 3) 3)
+(eql (mismatch #(a b c d e) #(c d) :start1 2 :start2 1) 2)
+(eql (mismatch #(a b c d e) #(c d) :start1 3 :start2 1) 4)
+(eql (mismatch #(a b c d e) #(c d) :start1 2 :end2 1) 3)
+(null (mismatch #(a b c d) #(a b c d) :start1 1 :end1 2 :start2 1 :end2 2))
+(null (mismatch #(a b c d) #(a b c d) :start1 1 :end1 3 :start2 1 :end2 3))
+(null (mismatch #(a b c d) #(a b c d) :start1 1 :end1 4 :start2 1 :end2 4))
+(eql (mismatch #(a b c d) #(a b c d) :start1 1 :end1 nil :start2 1 :end2 1) 1)
+(eql (mismatch #(a b c d) #(a b c d) :start1 1 :end1 nil :start2 1 :end2 2) 2)
+(eql (mismatch #(a b c d) #(a b c d) :start1 1 :end1 nil :start2 1 :end2 3) 3)
+(null (mismatch #(a b c d) #(a b c d) :start1 1 :end1 nil :start2 1 :end2 4))
+(eql (mismatch #(a b c d) #(a b c d) :start1 1 :end1 1 :start2 1) 1)
+(eql (mismatch #(a b c d) #(a b c d) :start1 1 :end1 2 :start2 1) 2)
+(eql (mismatch #(a b c d) #(a b c d) :start1 1 :end1 3 :start2 1) 3)
+(null (mismatch #(a b c d) #(a b c d) :start1 1 :end1 4 :start2 1))
+(null (mismatch #(a b c) #(a b c) :from-end t))
+(eql (mismatch #(a b c d) #(a b c) :from-end t) 4)
+(eql (mismatch #(a b c) #(c) :from-end t) 2)
+(eql (mismatch #(a b c) #(z a b c) :from-end t) 0)
+(eql (mismatch #(a b c) #(x y z a b c) :from-end t) 0)
+(eql (mismatch #(x y z a b c) #(a b c) :from-end t) 3)
+(eql (mismatch #(x y z a b c) #(a b c) :end1 3 :from-end t) 3)
+(eql (mismatch #(x y z a b c) #(a b c) :end1 5 :from-end t) 5)
+(eql (mismatch #(x y z a b c x y z) #(a b c) :end1 6 :from-end t) 3)
+(eql (mismatch #(x y z a b c x y z) #(a b c) :start1 2 :end1 6 :from-end t) 3)
+(eql (mismatch #(x y z a b c x y z) #(a b c)
+ :from-end t
+ :start1 2 :end1 5
+ :start2 1 :end2 2
+ ) 4)
+(eql (mismatch #(x y z a b c x y z) #(a b c)
+ :start1 2 :end1 5
+ :start2 1 :end2 2
+ ) 2)
+(eql (mismatch #((a) (b) (c)) #((a) (b) (c))) 0)
+(null (mismatch #((a) (b) (c)) #((a) (b) (c)) :key #'car))
+(null (mismatch #((a) (b) (c)) #((a) (b) (c)) :test #'equal))
+(eql (mismatch #(#(a) #(b) #(c)) #(#(a) #(b) #(c))) 0)
+(null (mismatch #(#(a) #(b) #(c)) #(#(a) #(b) #(c)) :test #'equalp))
+(eql (mismatch #((a) (b) (c) (d)) #((a) (b) (c)) :key #'car) 3)
+(eql (mismatch #((a) (b) (c)) #((a) (b) (c) (d)) :key #'car) 3)
+(eql (mismatch #(#\a #\b #\c) #(#\A #\B #\C)) 0)
+(null (mismatch #(#\a #\b #\c) #(#\A #\B #\C) :key #'char-upcase))
+(null (mismatch #(#\a #\b #\c) #(#\A #\B #\C) :key #'char-downcase))
+(null (mismatch #(#\a #\b #\c) #(#\A #\B #\C)
+ :key #'char-upcase
+ :start1 1 :end1 2
+ :start2 1 :end2 2))
+(null (mismatch #(#\a #\b #\c) #(#\A #\B #\C)
+ :key #'char-upcase
+ :start1 2
+ :start2 2))
+(eql (mismatch #((a b c) (b c d) (d e f))
+ #((b b c) (c c d) (e e f)))
+ 0)
+(eql (mismatch #((a b c) (b c d) (d e f))
+ #((b b c) (c c d) (e e f))
+ :key #'cdr)
+ 0)
+(null (mismatch #((a b c) (b c d) (d e f))
+ #((b b c) (c c d) (e e f))
+ :key #'cdr
+ :test #'equal))
+(eql (mismatch #((a b c) (b c d) (d e f) (e f g))
+ #((b b c) (c c d) (e e f))
+ :key #'cdr
+ :test #'equal)
+ 3)
+(eql (mismatch #((a b c) (b c d) (d e f) (e f g))
+ #((b b c) (c c d) (e e f))
+ :key #'cdr
+ :test #'equal
+ :from-end t)
+ 4)
+(eql (mismatch #((a a a) (a b c) (b c d) (d e f))
+ #((b b c) (c c d) (e e f))
+ :key #'cdr
+ :test #'equal
+ :from-end t)
+ 1)
+(null (mismatch #((a a a) (a b c) (b c d) (d e f) (e f g))
+ #((b b c) (c c d) (e e f))
+ :key #'cdr
+ :test #'equal
+ :from-end t
+ :start1 1
+ :end1 4))
+(eql (mismatch #((a a a) (a b c) (b c d) (d e f) (e f g))
+ #((b b c) (c c d) (e e f))
+ :key #'cdr
+ :test #'equal
+ :from-end t
+ :start1 1)
+ 5)
+(eql (mismatch #((a a a) (a b c) (b c d) (d e f) (e f g))
+ #((b b c) (c c d) (e e f))
+ :key #'cdr
+ :test #'equal
+ :from-end t
+ :end1 3
+ :start2 1
+ :end2 2)
+
+ 2)
+
+
+(eql (mismatch "abc" "xyz") 0)
+(null (mismatch "" ""))
+(null (mismatch "a" "a"))
+(null (mismatch "abc" "abc"))
+(null (mismatch "abc" "ABC" :key #'char-downcase))
+(null (mismatch "abc" "ABC" :test #'char-equal))
+(eql (mismatch "abcde" "abc") 3)
+(eql (mismatch "abc" "abcde") 3)
+(eql (mismatch "abc" "abxyz") 2)
+(eql (mismatch "abcde" "abx") 2)
+(null (mismatch "abc" "abc" :from-end t))
+(eql (mismatch "abcxyz" "xyzxyz" :from-end t) 3)
+(eql (mismatch "abcxyz" "xyz" :from-end t) 3)
+(eql (mismatch "xyz" "abcxyz" :from-end t) 0)
+(eql (mismatch "ayz" "abcxyz" :from-end t) 1)
+(null (mismatch "abc" "xyz" :test #'char<))
+(eql (mismatch "abc" "xyz" :test #'char>) 0)
+(eql (mismatch "abcxyz" "abcdefg") 3)
+(eql (mismatch "1xyz" "22xyz" :from-end t) 1)
+
+(null (mismatch #*010101 #*010101))
+(eql (mismatch #*010 #*101) 0)
+(eql (mismatch #*010 #*101 :from-end t) 3)
+(eql (mismatch #*0101 #*010101) 4)
+(eql (mismatch #*010101 #*0101) 4)
+(eql (mismatch #*010100 #*010111) 4)
+(null (mismatch #*0101 #*0101 :from-end t))
+(eql (mismatch #*00101 #*0101 :from-end t) 1)
+(eql (mismatch #*0101 #*00101 :from-end t) 0)
+(eql (mismatch #*00101 #*10101 :from-end t) 1)
+
+
+
+(equal (replace "abcdefghij" "0123456789" :start1 4 :end1 7 :start2 4)
+ "abcd456hij")
+(let ((lst (copy-seq "012345678")))
+ (and (equal (replace lst lst :start1 2 :start2 0) "010123456")
+ (equal lst "010123456")))
+
+
+(let* ((list0 (list 'a 'b 'c 'd 'e))
+ (list (replace list0 '(x y z))))
+ (and (eq list0 list)
+ (equal list0 '(x y z d e))))
+
+(let* ((list0 (list 'a 'b 'c 'd 'e))
+ (list (replace list0 '(x y z) :start1 1)))
+ (and (eq list0 list)
+ (equal list0 '(a x y z e))))
+
+(let* ((list0 (list 'a 'b 'c 'd 'e))
+ (list (replace list0 '(x y z) :start1 1 :end1 nil)))
+ (and (eq list0 list)
+ (equal list0 '(a x y z e))))
+
+(let* ((list0 (list 'a 'b 'c 'd 'e))
+ (list (replace list0 '(x y z) :start1 1 :start2 1)))
+ (and (eq list0 list)
+ (equal list0 '(a y z d e))))
+
+(let* ((list0 (list 'a 'b 'c 'd 'e))
+ (list (replace list0 '(x y z) :start1 1 :start2 1 :end2 nil)))
+ (and (eq list0 list)
+ (equal list0 '(a y z d e))))
+
+(let* ((list0 (list 'a 'b 'c 'd 'e))
+ (list (replace list0 '(x y z) :start1 1 :end1 nil :start2 1 :end2 nil)))
+ (and (eq list0 list)
+ (equal list0 '(a y z d e))))
+
+(let* ((list0 (list 'a 'b 'c 'd 'e))
+ (list (replace list0 '(x y z) :start1 1 :end1 2 :start2 1)))
+ (and (eq list0 list)
+ (equal list0 '(a y c d e))))
+
+(let* ((list0 (list 'a 'b 'c 'd 'e))
+ (list (replace list0 '(x y z) :start1 1 :end1 1)))
+ (and (eq list0 list)
+ (equal list0 '(a b c d e))))
+
+(let* ((list0 (list 'a 'b 'c 'd 'e))
+ (list (replace list0 '(x y z) :start1 2 :end1 2)))
+ (and (eq list0 list)
+ (equal list0 '(a b c d e))))
+
+(let* ((list0 (list 'a 'b 'c 'd 'e))
+ (list (replace list0 '(x y z) :start1 3 :end1 3)))
+ (and (eq list0 list)
+ (equal list0 '(a b c d e))))
+
+(let* ((list0 (list 'a 'b 'c 'd 'e))
+ (list (replace list0 '(x y z) :start1 4 :end1 4)))
+ (and (eq list0 list)
+ (equal list0 '(a b c d e))))
+
+(let* ((list0 (list 'a 'b 'c 'd 'e))
+ (list (replace list0 '(x y z) :start1 5 :end1 5)))
+ (and (eq list0 list)
+ (equal list0 '(a b c d e))))
+
+(null (replace nil nil))
+(null (replace nil '(a b c)))
+
+(let* ((list0 (list 'a 'b 'c))
+ (list (replace list0 '())))
+ (and (eq list0 list)
+ (equal list0 '(a b c))))
+
+(let* ((list0 (list 'a 'b 'c 'd 'e))
+ (list (replace list0 list0)))
+ (and (eq list0 list)
+ (equal list0 '(a b c d e))))
+
+(let* ((list0 (list 'a 'b 'c 'd 'e))
+ (list (replace list0 list0 :start1 3)))
+ (and (eq list0 list)
+ (equal list0 '(a b c a b))))
+
+(let* ((list0 (list 'a 'b 'c 'd 'e))
+ (list (replace list0 list0 :start1 1)))
+ (and (eq list0 list)
+ (equal list0 '(a a b c d))))
+
+(let* ((list0 (list 'a 'b 'c 'd 'e))
+ (list (replace list0 list0 :start1 1 :end1 3)))
+ (and (eq list0 list)
+ (equal list0 '(a a b d e))))
+
+(let* ((list0 (list 'a 'b 'c))
+ (list (replace list0 '(x y z))))
+ (and (eq list0 list)
+ (equal list0 '(x y z))))
+
+
+(let* ((vector0 (vector 'a 'b 'c 'd 'e))
+ (vector (replace vector0 '(x y z))))
+ (and (eq vector0 vector)
+ (equalp vector0 #(x y z d e))))
+
+(let* ((vector0 (vector 'a 'b 'c 'd 'e))
+ (vector (replace vector0 '(x y z) :start1 1)))
+ (and (eq vector0 vector)
+ (equalp vector0 #(a x y z e))))
+
+(let* ((vector0 (vector 'a 'b 'c 'd 'e))
+ (vector (replace vector0 '(x y z) :start1 1 :end1 nil)))
+ (and (eq vector0 vector)
+ (equalp vector0 #(a x y z e))))
+
+(let* ((vector0 (vector 'a 'b 'c 'd 'e))
+ (vector (replace vector0 '(x y z) :start1 1 :start2 1)))
+ (and (eq vector0 vector)
+ (equalp vector0 #(a y z d e))))
+
+(let* ((vector0 (vector 'a 'b 'c 'd 'e))
+ (vector (replace vector0 '(x y z) :start1 1 :start2 1 :end2 nil)))
+ (and (eq vector0 vector)
+ (equalp vector0 #(a y z d e))))
+
+(let* ((vector0 (vector 'a 'b 'c 'd 'e))
+ (vector (replace vector0 '(x y z) :start1 1 :end1 nil :start2 1 :end2 nil)))
+ (and (eq vector0 vector)
+ (equalp vector0 #(a y z d e))))
+
+(let* ((vector0 (vector 'a 'b 'c 'd 'e))
+ (vector (replace vector0 '(x y z) :start1 1 :end1 2 :start2 1)))
+ (and (eq vector0 vector)
+ (equalp vector0 #(a y c d e))))
+
+(let* ((vector0 (vector 'a 'b 'c 'd 'e))
+ (vector (replace vector0 '(x y z) :start1 1 :end1 1)))
+ (and (eq vector0 vector)
+ (equalp vector0 #(a b c d e))))
+
+(let* ((vector0 (vector 'a 'b 'c 'd 'e))
+ (vector (replace vector0 '(x y z) :start1 2 :end1 2)))
+ (and (eq vector0 vector)
+ (equalp vector0 #(a b c d e))))
+
+(let* ((vector0 (vector 'a 'b 'c 'd 'e))
+ (vector (replace vector0 '(x y z) :start1 3 :end1 3)))
+ (and (eq vector0 vector)
+ (equalp vector0 #(a b c d e))))
+
+(let* ((vector0 (vector 'a 'b 'c 'd 'e))
+ (vector (replace vector0 '(x y z) :start1 4 :end1 4)))
+ (and (eq vector0 vector)
+ (equalp vector0 #(a b c d e))))
+
+(let* ((vector0 (vector 'a 'b 'c 'd 'e))
+ (vector (replace vector0 '(x y z) :start1 5 :end1 5)))
+ (and (eq vector0 vector)
+ (equalp vector0 #(a b c d e))))
+
+(null (replace nil #()))
+(null (replace nil #(a b c)))
+
+(let* ((vector0 (vector 'a 'b 'c))
+ (vector (replace vector0 '())))
+ (and (eq vector0 vector)
+ (equalp vector0 #(a b c))))
+
+(let* ((vector0 (vector 'a 'b 'c 'd 'e))
+ (vector (replace vector0 vector0)))
+ (and (eq vector0 vector)
+ (equalp vector0 #(a b c d e))))
+
+(let* ((vector0 (vector 'a 'b 'c 'd 'e))
+ (vector (replace vector0 vector0 :start1 3)))
+ (and (eq vector0 vector)
+ (equalp vector0 #(a b c a b))))
+
+(let* ((vector0 (vector 'a 'b 'c 'd 'e))
+ (vector (replace vector0 vector0 :start1 1)))
+ (and (eq vector0 vector)
+ (equalp vector0 #(a a b c d))))
+
+(let* ((vector0 (vector 'a 'b 'c 'd 'e))
+ (vector (replace vector0 vector0 :start1 1 :end1 3)))
+ (and (eq vector0 vector)
+ (equalp vector0 #(a a b d e))))
+
+(let* ((vector0 (vector 'a 'b 'c))
+ (vector (replace vector0 '(x y z))))
+ (and (eq vector0 vector)
+ (equalp vector0 #(x y z))))
+
+
+(let* ((vector0 (vector 'a 'b 'c 'd 'e))
+ (vector (replace vector0 #(x y z))))
+ (and (eq vector0 vector)
+ (equalp vector0 #(x y z d e))))
+
+(let* ((vector0 (vector 'a 'b 'c 'd 'e))
+ (vector (replace vector0 #(x y z) :start1 1)))
+ (and (eq vector0 vector)
+ (equalp vector0 #(a x y z e))))
+
+(let* ((vector0 (vector 'a 'b 'c 'd 'e))
+ (vector (replace vector0 #(x y z) :start1 1 :end1 nil)))
+ (and (eq vector0 vector)
+ (equalp vector0 #(a x y z e))))
+
+(let* ((vector0 (vector 'a 'b 'c 'd 'e))
+ (vector (replace vector0 #(x y z) :start1 1 :start2 1)))
+ (and (eq vector0 vector)
+ (equalp vector0 #(a y z d e))))
+
+(let* ((vector0 (vector 'a 'b 'c 'd 'e))
+ (vector (replace vector0 #(x y z) :start1 1 :start2 1 :end2 nil)))
+ (and (eq vector0 vector)
+ (equalp vector0 #(a y z d e))))
+
+(let* ((vector0 (vector 'a 'b 'c 'd 'e))
+ (vector (replace vector0 #(x y z) :start1 1 :end1 nil :start2 1 :end2 nil)))
+ (and (eq vector0 vector)
+ (equalp vector0 #(a y z d e))))
+
+(let* ((vector0 (vector 'a 'b 'c 'd 'e))
+ (vector (replace vector0 #(x y z) :start1 1 :end1 2 :start2 1)))
+ (and (eq vector0 vector)
+ (equalp vector0 #(a y c d e))))
+
+(let* ((vector0 (vector 'a 'b 'c 'd 'e))
+ (vector (replace vector0 #(x y z) :start1 1 :end1 1)))
+ (and (eq vector0 vector)
+ (equalp vector0 #(a b c d e))))
+
+(let* ((vector0 (vector 'a 'b 'c 'd 'e))
+ (vector (replace vector0 #(x y z) :start1 2 :end1 2)))
+ (and (eq vector0 vector)
+ (equalp vector0 #(a b c d e))))
+
+(let* ((vector0 (vector 'a 'b 'c 'd 'e))
+ (vector (replace vector0 #(x y z) :start1 3 :end1 3)))
+ (and (eq vector0 vector)
+ (equalp vector0 #(a b c d e))))
+
+(let* ((vector0 (vector 'a 'b 'c 'd 'e))
+ (vector (replace vector0 #(x y z) :start1 4 :end1 4)))
+ (and (eq vector0 vector)
+ (equalp vector0 #(a b c d e))))
+
+(let* ((vector0 (vector 'a 'b 'c 'd 'e))
+ (vector (replace vector0 #(x y z) :start1 5 :end1 5)))
+ (and (eq vector0 vector)
+ (equalp vector0 #(a b c d e))))
+
+(null (replace nil #()))
+(null (replace nil #(a b c)))
+
+(let* ((vector0 (vector 'a 'b 'c))
+ (vector (replace vector0 #())))
+ (and (eq vector0 vector)
+ (equalp vector0 #(a b c))))
+
+(let* ((vector0 (vector 'a 'b 'c 'd 'e))
+ (vector (replace vector0 vector0)))
+ (and (eq vector0 vector)
+ (equalp vector0 #(a b c d e))))
+
+(let* ((vector0 (vector 'a 'b 'c 'd 'e))
+ (vector (replace vector0 vector0 :start1 3)))
+ (and (eq vector0 vector)
+ (equalp vector0 #(a b c a b))))
+
+(let* ((vector0 (vector 'a 'b 'c 'd 'e))
+ (vector (replace vector0 vector0 :start1 1)))
+ (and (eq vector0 vector)
+ (equalp vector0 #(a a b c d))))
+
+(let* ((vector0 (vector 'a 'b 'c 'd 'e))
+ (vector (replace vector0 vector0 :start1 1 :end1 3)))
+ (and (eq vector0 vector)
+ (equalp vector0 #(a a b d e))))
+
+(let* ((vector0 (vector 'a 'b 'c))
+ (vector (replace vector0 #(x y z))))
+ (and (eq vector0 vector)
+ (equalp vector0 #(x y z))))
+
+(let* ((str0 (copy-seq "abc"))
+ (str (replace str0 "xyz")))
+ (and (eq str0 str)
+ (equalp str0 "xyz")))
+
+(let* ((str0 (copy-seq ""))
+ (str (replace str0 "")))
+ (and (eq str0 str)
+ (equalp str0 "")))
+
+(let* ((str0 (copy-seq ""))
+ (str (replace str0 "xyz")))
+ (and (eq str0 str)
+ (equalp str0 "")))
+
+(let* ((str0 (copy-seq "abc"))
+ (str (replace str0 "")))
+ (and (eq str0 str)
+ (equalp str0 "abc")))
+
+(let* ((str0 (copy-seq "abcdef"))
+ (str (replace str0 "xyz" :start1 3)))
+ (and (eq str0 str)
+ (equalp str0 "abcxyz")))
+
+(let* ((str0 (copy-seq "abcdef"))
+ (str (replace str0 "xyz" :start1 4 :start2 1)))
+ (and (eq str0 str)
+ (equalp str0 "abcdyz")))
+
+(let* ((str0 (copy-seq "abcdef"))
+ (str (replace str0 "xyz" :start1 1 :end1 2 :start2 1)))
+ (and (eq str0 str)
+ (equalp str0 "aycdef")))
+
+(let* ((str0 (copy-seq "abcdef"))
+ (str (replace str0 "xyz" :start1 1 :start2 1 :end2 2)))
+ (and (eq str0 str)
+ (equalp str0 "aycdef")))
+
+(let* ((str0 (copy-seq "abcdef"))
+ (str (replace str0 str0 :start1 1)))
+ (and (eq str0 str)
+ (equalp str0 "aabcde")))
+
+
+(let* ((bv0 (copy-seq #*0000))
+ (bv (replace bv0 #*1010)))
+ (and (eq bv0 bv)
+ (equalp bv0 #*1010)))
+
+(let* ((bv0 (copy-seq #*))
+ (bv (replace bv0 #*1010)))
+ (and (eq bv0 bv)
+ (equalp bv0 #*)))
+
+(let* ((bv0 (copy-seq #*0000))
+ (bv (replace bv0 #*)))
+ (and (eq bv0 bv)
+ (equalp bv0 #*0000)))
+
+(let* ((bv0 (copy-seq #*0000))
+ (bv (replace bv0 #*1111 :start1 2)))
+ (and (eq bv0 bv)
+ (equalp bv0 #*0011)))
+
+(let* ((bv0 (copy-seq #*1001))
+ (bv (replace bv0 #*0110 :start1 1 :end1 3 :start2 1 :end2 3)))
+ (and (eq bv0 bv)
+ (equalp bv0 #*1111)))
+
+(let* ((bv0 (copy-seq #*1010))
+ (bv (replace bv0 bv0 :start1 1)))
+ (and (eq bv0 bv)
+ (equalp bv0 #*1101)))
+
+
+
+(equal (substitute #\. #\SPACE "0 2 4 6") "0.2.4.6")
+(equal (substitute 9 4 '(1 2 4 1 3 4 5)) '(1 2 9 1 3 9 5))
+(equal (substitute 9 4 '(1 2 4 1 3 4 5) :count 1) '(1 2 9 1 3 4 5))
+(equal (substitute 9 4 '(1 2 4 1 3 4 5) :count 1 :from-end t) '(1 2 4 1 3 9 5))
+(equal (substitute 9 3 '(1 2 4 1 3 4 5) :test #'>) '(9 9 4 9 3 4 5))
+(equal (substitute-if 0 #'evenp '((1) (2) (3) (4)) :start 2 :key #'car)
+ '((1) (2) (3) 0))
+(equal (substitute-if 9 #'oddp '(1 2 4 1 3 4 5)) '(9 2 4 9 9 4 9))
+(equal (substitute-if 9 #'evenp '(1 2 4 1 3 4 5) :count 1 :from-end t)
+ '(1 2 4 1 3 9 5))
+(let ((some-things (list 'a 'car 'b 'cdr 'c)))
+ (and (equal (nsubstitute-if "function was here" #'fboundp some-things
+ :count 1 :from-end t)
+ '(A CAR B "function was here" C))
+ (equal some-things '(A CAR B "function was here" C))))
+(let ((alpha-tester (copy-seq "ab ")))
+ (and (equal (nsubstitute-if-not #\z #'alpha-char-p alpha-tester) "abz")
+ (equal alpha-tester "abz")))
+
+
+(equal (substitute 'a 'x '(x y z)) '(a y z))
+(equal (substitute 'b 'y '(x y z)) '(x b z))
+(equal (substitute 'c 'z '(x y z)) '(x y c))
+(equal (substitute 'a 'p '(x y z)) '(x y z))
+(equal (substitute 'a 'x '()) '())
+(equal (substitute #\x #\b '(#\a #\b #\c #\d #\e) :test #'char<)
+ '(#\a #\b #\x #\x #\x))
+(equal (substitute #\x #\b '(#\a #\b #\c #\d #\e)
+ :test-not (complement #'char<))
+ '(#\a #\b #\x #\x #\x))
+(equal (substitute '(a) 'x '((x) (y) (z)) :key #'car)
+ '((a) (y) (z)))
+(equal (substitute 'c 'b '(a b a b a b a b)) '(a c a c a c a c))
+(equal (substitute 'a 'b '(b b b)) '(a a a))
+(equal (substitute 'z 'x '(a x b x c x d x e x f))
+ '(a z b z c z d z e z f))
+(equal (substitute 'z 'x '(a x b x c x d x e x f) :count nil)
+ '(a z b z c z d z e z f))
+(equal (substitute 'z 'x '(a x b x c x d x e x f) :count 0)
+ '(a x b x c x d x e x f))
+(equal (substitute 'z 'x '(a x b x c x d x e x f) :count -100)
+ '(a x b x c x d x e x f))
+(equal (substitute 'z 'x '(a x b x c x d x e x f) :count 1)
+ '(a z b x c x d x e x f))
+(equal (substitute 'z 'x '(a x b x c x d x e x f) :count 2)
+ '(a z b z c x d x e x f))
+(equal (substitute 'z 'x '(a x b x c x d x e x f) :count 3)
+ '(a z b z c z d x e x f))
+(equal (substitute 'z 'x '(a x b x c x d x e x f) :count 4)
+ '(a z b z c z d z e x f))
+(equal (substitute 'z 'x '(a x b x c x d x e x f) :count 5)
+ '(a z b z c z d z e z f))
+(equal (substitute 'z 'x '(a x b x c x d x e x f) :count 6)
+ '(a z b z c z d z e z f))
+(equal (substitute 'z 'x '(a x b x c x d x e x f) :count 7)
+ '(a z b z c z d z e z f))
+(equal (substitute 'z 'x '(a x b x c x d x e x f) :count nil :from-end t)
+ '(a z b z c z d z e z f))
+(equal (substitute 'z 'x '(a x b x c x d x e x f) :count 0 :from-end t)
+ '(a x b x c x d x e x f))
+(equal (substitute 'z 'x '(a x b x c x d x e x f) :count -100 :from-end t)
+ '(a x b x c x d x e x f))
+(equal (substitute 'z 'x '(a x b x c x d x e x f) :count 1 :from-end t)
+ '(a x b x c x d x e z f))
+(equal (substitute 'z 'x '(a x b x c x d x e x f) :count 2 :from-end t)
+ '(a x b x c x d z e z f))
+(equal (substitute 'z 'x '(a x b x c x d x e x f) :count 3 :from-end t)
+ '(a x b x c z d z e z f))
+(equal (substitute 'z 'x '(a x b x c x d x e x f) :count 4 :from-end t)
+ '(a x b z c z d z e z f))
+(equal (substitute 'z 'x '(a x b x c x d x e x f) :count 5 :from-end t)
+ '(a z b z c z d z e z f))
+(equal (substitute 'z 'x '(a x b x c x d x e x f) :count 6 :from-end t)
+ '(a z b z c z d z e z f))
+(equal (substitute 'z 'x '(a x b x c x d x e x f) :count 7 :from-end t)
+ '(a z b z c z d z e z f))
+(equal (substitute 'z 'x '(a x b x c x d x e x f) :start 2 :count 1)
+ '(a x b z c x d x e x f))
+(equal (substitute 'z 'x '(a x b x c x d x e x f) :start 2 :end nil :count 1)
+ '(a x b z c x d x e x f))
+(equal (substitute 'z 'x '(a x b x c x d x e x f) :start 2 :end 6 :count 100)
+ '(a x b z c z d x e x f))
+(equal (substitute 'z 'x '(a x b x c x d x e x f) :start 2 :end 11 :count 100)
+ '(a x b z c z d z e z f))
+(equal (substitute 'z 'x '(a x b x c x d x e x f) :start 2 :end 8 :count 10)
+ '(a x b z c z d z e x f))
+(equal (substitute 'z 'x '(a x b x c x d x e x f)
+ :start 2 :end 8 :count 2 :from-end t)
+ '(a x b x c z d z e x f))
+(equal (substitute #\z #\c '(#\a #\b #\c #\d #\e #\f) :test #'char<)
+ '(#\a #\b #\c #\z #\z #\z))
+(equal (substitute #\z #\c '(#\a #\b #\c #\d #\e #\f)
+ :test-not (complement #'char<))
+ '(#\a #\b #\c #\z #\z #\z))
+(equal (substitute "peace" "war" '("love" "hate" "war" "peace") :test #'equal)
+ '("love" "hate" "peace" "peace"))
+(equal (substitute "peace" "war" '("love" "hate" "war" "peace")
+ :test-not (complement #'equal))
+ '("love" "hate" "peace" "peace"))
+(equal (substitute "peace" "war" '("war" "War" "WAr" "WAR")
+ :test #'string-equal)
+ '("peace" "peace" "peace" "peace"))
+(equal (substitute "peace" "war" '("war" "War" "WAr" "WAR")
+ :test-not (complement #'string-equal))
+ '("peace" "peace" "peace" "peace"))
+(equal (substitute "peace" "WAR" '("war" "War" "WAr" "WAR")
+ :test #'string=)
+ '("war" "War" "WAr" "peace"))
+(equal (substitute "peace" "WAR" '("war" "War" "WAr" "WAR")
+ :test-not (complement #'string=))
+ '("war" "War" "WAr" "peace"))
+(equal (substitute "peace" "WAR" '("war" "War" "WAr" "WAR")
+ :test #'string=
+ :key #'string-upcase)
+ '("peace" "peace" "peace" "peace"))
+(equal (substitute "peace" "WAR" '("war" "War" "WAr" "WAR")
+ :test-not (complement #'string=)
+ :key #'string-upcase)
+ '("peace" "peace" "peace" "peace"))
+(equal (substitute "peace" "WAR" '("war" "War" "WAr" "WAR")
+ :start 1
+ :end 2
+ :test #'string=
+ :key #'string-upcase)
+ '("war" "peace" "WAr" "WAR"))
+(equal (substitute "peace" "WAR" '("war" "War" "WAr" "WAR")
+ :start 1
+ :end 2
+ :test-not (complement #'string=)
+ :key #'string-upcase)
+ '("war" "peace" "WAr" "WAR"))
+(equal (substitute "peace" "WAR" '("war" "War" "WAr" "WAR")
+ :start 1
+ :end nil
+ :test #'string=
+ :key #'string-upcase)
+ '("war" "peace" "peace" "peace"))
+(equal (substitute "peace" "WAR" '("war" "War" "WAr" "WAR")
+ :start 1
+ :end nil
+ :test-not (complement #'string=)
+ :key #'string-upcase)
+ '("war" "peace" "peace" "peace"))
+(equal (substitute "peace" "war" '("war" "War" "WAr" "WAR")
+ :test #'string=
+ :key #'string-upcase)
+ '("war" "War" "WAr" "WAR"))
+(equal (substitute "peace" "war" '("war" "War" "WAr" "WAR")
+ :test-not (complement #'string=)
+ :key #'string-upcase)
+ '("war" "War" "WAr" "WAR"))
+(equal (substitute "peace" "WAR"
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")
+ :start 1
+ :end 7
+ :count 1
+ :test-not (complement #'string=)
+ :key #'string-upcase)
+ '("war" "peace" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+(equal (substitute "peace" "WAR"
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")
+ :start 1
+ :end 7
+ :count 2
+ :test-not (complement #'string=)
+ :key #'string-upcase)
+ '("war" "peace" "peace" "WAR" "war" "War" "WAr" "WAR"))
+(equal (substitute "peace" "WAR"
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")
+ :start 1
+ :end 7
+ :count 2
+ :from-end t
+ :test-not (complement #'string=)
+ :key #'string-upcase)
+ '("war" "War" "WAr" "WAR" "war" "peace" "peace" "WAR"))
+(equal (substitute "peace" "WAR"
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")
+ :start 1
+ :end 7
+ :count 0
+ :from-end t
+ :test-not (complement #'string=)
+ :key #'string-upcase)
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+(equal (substitute "peace" "WAR"
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")
+ :start 1
+ :end 7
+ :count -2
+ :from-end t
+ :test-not (complement #'string=)
+ :key #'string-upcase)
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+(equal (substitute "peace" "WAR"
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")
+ :start 1
+ :end 7
+ :count nil
+ :from-end t
+ :test-not (complement #'string=)
+ :key #'string-upcase)
+ '("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR"))
+(equal (substitute "peace" "WAR"
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")
+ :start 1
+ :end 7
+ :count 6
+ :from-end t
+ :test-not (complement #'string=)
+ :key #'string-upcase)
+ '("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR"))
+(equal (substitute "peace" "WAR"
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")
+ :start 1
+ :end 7
+ :count 7
+ :from-end t
+ :test-not (complement #'string=)
+ :key #'string-upcase)
+ '("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR"))
+(equal (substitute "peace" "WAR"
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")
+ :start 1
+ :end 7
+ :count 100
+ :from-end t
+ :test-not (complement #'string=)
+ :key #'string-upcase)
+ '("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR"))
+
+
+(equalp (substitute 'a 'x #(x y z)) #(a y z))
+(equalp (substitute 'b 'y #(x y z)) #(x b z))
+(equalp (substitute 'c 'z #(x y z)) #(x y c))
+(equalp (substitute 'a 'p #(x y z)) #(x y z))
+(equalp (substitute 'a 'x #()) #())
+(equalp (substitute #\x #\b #(#\a #\b #\c #\d #\e) :test #'char<)
+ #(#\a #\b #\x #\x #\x))
+(equalp (substitute #\x #\b #(#\a #\b #\c #\d #\e)
+ :test-not (complement #'char<))
+ #(#\a #\b #\x #\x #\x))
+(equalp (substitute '(a) 'x #((x) (y) (z)) :key #'car)
+ #((a) (y) (z)))
+(equalp (substitute 'c 'b #(a b a b a b a b)) #(a c a c a c a c))
+(equalp (substitute 'a 'b #(b b b)) #(a a a))
+(equalp (substitute 'z 'x #(a x b x c x d x e x f))
+ #(a z b z c z d z e z f))
+(equalp (substitute 'z 'x #(a x b x c x d x e x f) :count nil)
+ #(a z b z c z d z e z f))
+(equalp (substitute 'z 'x #(a x b x c x d x e x f) :count 0)
+ #(a x b x c x d x e x f))
+(equalp (substitute 'z 'x #(a x b x c x d x e x f) :count -100)
+ #(a x b x c x d x e x f))
+(equalp (substitute 'z 'x #(a x b x c x d x e x f) :count 1)
+ #(a z b x c x d x e x f))
+(equalp (substitute 'z 'x #(a x b x c x d x e x f) :count 2)
+ #(a z b z c x d x e x f))
+(equalp (substitute 'z 'x #(a x b x c x d x e x f) :count 3)
+ #(a z b z c z d x e x f))
+(equalp (substitute 'z 'x #(a x b x c x d x e x f) :count 4)
+ #(a z b z c z d z e x f))
+(equalp (substitute 'z 'x #(a x b x c x d x e x f) :count 5)
+ #(a z b z c z d z e z f))
+(equalp (substitute 'z 'x #(a x b x c x d x e x f) :count 6)
+ #(a z b z c z d z e z f))
+(equalp (substitute 'z 'x #(a x b x c x d x e x f) :count 7)
+ #(a z b z c z d z e z f))
+(equalp (substitute 'z 'x #(a x b x c x d x e x f) :count nil :from-end t)
+ #(a z b z c z d z e z f))
+(equalp (substitute 'z 'x #(a x b x c x d x e x f) :count 0 :from-end t)
+ #(a x b x c x d x e x f))
+(equalp (substitute 'z 'x #(a x b x c x d x e x f) :count -100 :from-end t)
+ #(a x b x c x d x e x f))
+(equalp (substitute 'z 'x #(a x b x c x d x e x f) :count 1 :from-end t)
+ #(a x b x c x d x e z f))
+(equalp (substitute 'z 'x #(a x b x c x d x e x f) :count 2 :from-end t)
+ #(a x b x c x d z e z f))
+(equalp (substitute 'z 'x #(a x b x c x d x e x f) :count 3 :from-end t)
+ #(a x b x c z d z e z f))
+(equalp (substitute 'z 'x #(a x b x c x d x e x f) :count 4 :from-end t)
+ #(a x b z c z d z e z f))
+(equalp (substitute 'z 'x #(a x b x c x d x e x f) :count 5 :from-end t)
+ #(a z b z c z d z e z f))
+(equalp (substitute 'z 'x #(a x b x c x d x e x f) :count 6 :from-end t)
+ #(a z b z c z d z e z f))
+(equalp (substitute 'z 'x #(a x b x c x d x e x f) :count 7 :from-end t)
+ #(a z b z c z d z e z f))
+(equalp (substitute 'z 'x #(a x b x c x d x e x f) :start 2 :count 1)
+ #(a x b z c x d x e x f))
+(equalp (substitute 'z 'x #(a x b x c x d x e x f) :start 2 :end nil :count 1)
+ #(a x b z c x d x e x f))
+(equalp (substitute 'z 'x #(a x b x c x d x e x f) :start 2 :end 6 :count 100)
+ #(a x b z c z d x e x f))
+(equalp (substitute 'z 'x #(a x b x c x d x e x f) :start 2 :end 11 :count 100)
+ #(a x b z c z d z e z f))
+(equalp (substitute 'z 'x #(a x b x c x d x e x f) :start 2 :end 8 :count 10)
+ #(a x b z c z d z e x f))
+(equalp (substitute 'z 'x #(a x b x c x d x e x f)
+ :start 2 :end 8 :count 2 :from-end t)
+ #(a x b x c z d z e x f))
+(equalp (substitute #\z #\c #(#\a #\b #\c #\d #\e #\f) :test #'char<)
+ #(#\a #\b #\c #\z #\z #\z))
+(equalp (substitute #\z #\c #(#\a #\b #\c #\d #\e #\f)
+ :test-not (complement #'char<))
+ #(#\a #\b #\c #\z #\z #\z))
+(equalp (substitute "peace" "war" #("love" "hate" "war" "peace") :test #'equal)
+ #("love" "hate" "peace" "peace"))
+(equalp (substitute "peace" "war" #("love" "hate" "war" "peace")
+ :test-not (complement #'equal))
+ #("love" "hate" "peace" "peace"))
+(equalp (substitute "peace" "war" #("war" "War" "WAr" "WAR")
+ :test #'string-equal)
+ #("peace" "peace" "peace" "peace"))
+(equalp (substitute "peace" "war" #("war" "War" "WAr" "WAR")
+ :test-not (complement #'string-equal))
+ #("peace" "peace" "peace" "peace"))
+(equalp (substitute "peace" "WAR" #("war" "War" "WAr" "WAR")
+ :test #'string=)
+ #("war" "War" "WAr" "peace"))
+(equalp (substitute "peace" "WAR" #("war" "War" "WAr" "WAR")
+ :test-not (complement #'string=))
+ #("war" "War" "WAr" "peace"))
+(equalp (substitute "peace" "WAR" #("war" "War" "WAr" "WAR")
+ :test #'string=
+ :key #'string-upcase)
+ #("peace" "peace" "peace" "peace"))
+(equalp (substitute "peace" "WAR" #("war" "War" "WAr" "WAR")
+ :test-not (complement #'string=)
+ :key #'string-upcase)
+ #("peace" "peace" "peace" "peace"))
+(equalp (substitute "peace" "WAR" #("war" "War" "WAr" "WAR")
+ :start 1
+ :end 2
+ :test #'string=
+ :key #'string-upcase)
+ #("war" "peace" "WAr" "WAR"))
+(equalp (substitute "peace" "WAR" #("war" "War" "WAr" "WAR")
+ :start 1
+ :end 2
+ :test-not (complement #'string=)
+ :key #'string-upcase)
+ #("war" "peace" "WAr" "WAR"))
+(equalp (substitute "peace" "WAR" #("war" "War" "WAr" "WAR")
+ :start 1
+ :end nil
+ :test #'string=
+ :key #'string-upcase)
+ #("war" "peace" "peace" "peace"))
+(equalp (substitute "peace" "WAR" #("war" "War" "WAr" "WAR")
+ :start 1
+ :end nil
+ :test-not (complement #'string=)
+ :key #'string-upcase)
+ #("war" "peace" "peace" "peace"))
+(equalp (substitute "peace" "war" #("war" "War" "WAr" "WAR")
+ :test #'string=
+ :key #'string-upcase)
+ #("war" "War" "WAr" "WAR"))
+(equalp (substitute "peace" "war" #("war" "War" "WAr" "WAR")
+ :test-not (complement #'string=)
+ :key #'string-upcase)
+ #("war" "War" "WAr" "WAR"))
+(equalp (substitute "peace" "WAR"
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")
+ :start 1
+ :end 7
+ :count 1
+ :test-not (complement #'string=)
+ :key #'string-upcase)
+ #("war" "peace" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+(equalp (substitute "peace" "WAR"
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")
+ :start 1
+ :end 7
+ :count 2
+ :test-not (complement #'string=)
+ :key #'string-upcase)
+ #("war" "peace" "peace" "WAR" "war" "War" "WAr" "WAR"))
+(equalp (substitute "peace" "WAR"
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")
+ :start 1
+ :end 7
+ :count 2
+ :from-end t
+ :test-not (complement #'string=)
+ :key #'string-upcase)
+ #("war" "War" "WAr" "WAR" "war" "peace" "peace" "WAR"))
+(equalp (substitute "peace" "WAR"
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")
+ :start 1
+ :end 7
+ :count 0
+ :from-end t
+ :test-not (complement #'string=)
+ :key #'string-upcase)
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+(equalp (substitute "peace" "WAR"
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")
+ :start 1
+ :end 7
+ :count -2
+ :from-end t
+ :test-not (complement #'string=)
+ :key #'string-upcase)
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+(equalp (substitute "peace" "WAR"
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")
+ :start 1
+ :end 7
+ :count nil
+ :from-end t
+ :test-not (complement #'string=)
+ :key #'string-upcase)
+ #("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR"))
+(equalp (substitute "peace" "WAR"
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")
+ :start 1
+ :end 7
+ :count 6
+ :from-end t
+ :test-not (complement #'string=)
+ :key #'string-upcase)
+ #("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR"))
+(equalp (substitute "peace" "WAR"
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")
+ :start 1
+ :end 7
+ :count 7
+ :from-end t
+ :test-not (complement #'string=)
+ :key #'string-upcase)
+ #("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR"))
+(equalp (substitute "peace" "WAR"
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")
+ :start 1
+ :end 7
+ :count 100
+ :from-end t
+ :test-not (complement #'string=)
+ :key #'string-upcase)
+ #("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR"))
+(string= (substitute #\A #\a "abcabc") "AbcAbc")
+(string= (substitute #\A #\a "") "")
+(string= (substitute #\A #\a "xyz") "xyz")
+(string= (substitute #\A #\a "aaaaaaaaaa" :start 5 :end nil) "aaaaaAAAAA")
+(string= (substitute #\x #\5 "0123456789" :test #'char<) "012345xxxx")
+(string= (substitute #\x #\5 "0123456789" :test #'char>) "xxxxx56789")
+(string= (substitute #\x #\D "abcdefg"
+ :key #'char-upcase
+ :test #'char>)
+ "xxxdefg")
+(string= (substitute #\x #\D "abcdefg"
+ :start 1
+ :end 2
+ :key #'char-upcase
+ :test #'char>)
+ "axcdefg")
+(string= (substitute #\A #\a "aaaaaaaaaa" :count 2) "AAaaaaaaaa")
+(string= (substitute #\A #\a "aaaaaaaaaa" :count -1) "aaaaaaaaaa")
+(string= (substitute #\A #\a "aaaaaaaaaa" :count 0) "aaaaaaaaaa")
+(string= (substitute #\A #\a "aaaaaaaaaa" :count nil) "AAAAAAAAAA")
+(string= (substitute #\A #\a "aaaaaaaaaa" :count 100) "AAAAAAAAAA")
+(string= (substitute #\A #\a "aaaaaaaaaa" :count 9) "AAAAAAAAAa")
+(string= (substitute #\A #\a "aaaaaaaaaa" :count 9 :from-end t) "aAAAAAAAAA")
+(string= (substitute #\A #\a "aaaaaaaaaa"
+ :start 2
+ :end 8
+ :count 3)
+ "aaAAAaaaaa")
+(string= (substitute #\A #\a "aaaaaaaaaa"
+ :start 2
+ :end 8
+ :from-end t
+ :count 3)
+ "aaaaaAAAaa")
+(string= (substitute #\x #\A "aaaaaaaaaa"
+ :start 2
+ :end 8
+ :from-end t
+ :count 3)
+ "aaaaaaaaaa")
+(string= (substitute #\X #\A "aaaaaaaaaa"
+ :start 2
+ :end 8
+ :from-end t
+ :key #'char-upcase
+ :count 3)
+ "aaaaaXXXaa")
+(string= (substitute #\X #\D "abcdefghij"
+ :start 2
+ :end 8
+ :from-end t
+ :key #'char-upcase
+ :test #'char<
+ :count 3)
+ "abcdeXXXij")
+(equalp (substitute 0 1 #*1111) #*0000)
+(equalp (substitute 0 1 #*1111 :start 1 :end nil) #*1000)
+(equalp (substitute 0 1 #*1111 :start 1 :end 3) #*1001)
+(equalp (substitute 0 1 #*11111111 :start 1 :end 7) #*10000001)
+(equalp (substitute 0 1 #*11111111 :start 1 :end 7 :count 3) #*10001111)
+(equalp (substitute 0 1 #*11111111 :start 1 :end 7 :count 3 :from-end t)
+ #*11110001)
+(equalp (substitute 1 1 #*10101010
+ :start 1 :end 7 :count 3 :from-end t
+ :key #'(lambda (x) (if (zerop x) 1 0)))
+ #*11111110)
+(equalp (substitute 1 1 #*10101010
+ :start 1 :end 7 :count 3 :from-end t
+ :key #'(lambda (x) (if (zerop x) 1 0))
+ :test #'>=)
+ #*10101110)
+
+
+
+(equal (substitute-if 'a #'(lambda (arg) (eq arg 'x)) '(x y z)) '(a y z))
+(equal (substitute-if 'b #'(lambda (arg) (eq arg 'y)) '(x y z)) '(x b z))
+(equal (substitute-if 'c #'(lambda (arg) (eq arg 'z)) '(x y z)) '(x y c))
+(equal (substitute-if 'a #'(lambda (arg) (eq arg 'p)) '(x y z)) '(x y z))
+(equal (substitute-if 'a #'(lambda (arg) (eq arg 'x)) '()) '())
+(equal (substitute-if #\x #'(lambda (arg) (char< #\b arg))
+ '(#\a #\b #\c #\d #\e))
+ '(#\a #\b #\x #\x #\x))
+(equal (substitute-if '(a) #'(lambda (arg) (eq arg 'x))
+ '((x) (y) (z)) :key #'car)
+ '((a) (y) (z)))
+(equal (substitute-if 'c #'(lambda (arg) (eq arg 'b))
+ '(a b a b a b a b)) '(a c a c a c a c))
+(equal (substitute-if 'a #'(lambda (arg) (eq arg 'b))
+ '(b b b)) '(a a a))
+(equal (substitute-if 'z #'(lambda (arg) (eq arg 'x))
+ '(a x b x c x d x e x f))
+ '(a z b z c z d z e z f))
+(equal (substitute-if 'z #'(lambda (arg) (eq arg 'x))
+ '(a x b x c x d x e x f) :count nil)
+ '(a z b z c z d z e z f))
+(equal (substitute-if 'z #'(lambda (arg) (eq arg 'x))
+ '(a x b x c x d x e x f) :count 0)
+ '(a x b x c x d x e x f))
+(equal (substitute-if 'z #'(lambda (arg) (eq arg 'x))
+ '(a x b x c x d x e x f) :count -100)
+ '(a x b x c x d x e x f))
+(equal (substitute-if 'z #'(lambda (arg) (eq arg 'x))
+ '(a x b x c x d x e x f) :count 1)
+ '(a z b x c x d x e x f))
+(equal (substitute-if 'z #'(lambda (arg) (eq arg 'x))
+ '(a x b x c x d x e x f) :count 2)
+ '(a z b z c x d x e x f))
+(equal (substitute-if 'z #'(lambda (arg) (eq arg 'x))
+ '(a x b x c x d x e x f) :count 3)
+ '(a z b z c z d x e x f))
+(equal (substitute-if 'z #'(lambda (arg) (eq arg 'x))
+ '(a x b x c x d x e x f) :count 4)
+ '(a z b z c z d z e x f))
+(equal (substitute-if 'z #'(lambda (arg) (eq arg 'x))
+ '(a x b x c x d x e x f) :count 5)
+ '(a z b z c z d z e z f))
+(equal (substitute-if 'z #'(lambda (arg) (eq arg 'x))
+ '(a x b x c x d x e x f) :count 6)
+ '(a z b z c z d z e z f))
+(equal (substitute-if 'z #'(lambda (arg) (eq arg 'x))
+ '(a x b x c x d x e x f) :count 7)
+ '(a z b z c z d z e z f))
+(equal (substitute-if 'z #'(lambda (arg) (eq arg 'x))
+ '(a x b x c x d x e x f) :count nil :from-end t)
+ '(a z b z c z d z e z f))
+(equal (substitute-if 'z #'(lambda (arg) (eq arg 'x))
+ '(a x b x c x d x e x f) :count 0 :from-end t)
+ '(a x b x c x d x e x f))
+(equal (substitute-if 'z #'(lambda (arg) (eq arg 'x))
+ '(a x b x c x d x e x f) :count -100 :from-end t)
+ '(a x b x c x d x e x f))
+(equal (substitute-if 'z #'(lambda (arg) (eq arg 'x))
+ '(a x b x c x d x e x f) :count 1 :from-end t)
+ '(a x b x c x d x e z f))
+(equal (substitute-if 'z #'(lambda (arg) (eq arg 'x))
+ '(a x b x c x d x e x f) :count 2 :from-end t)
+ '(a x b x c x d z e z f))
+(equal (substitute-if 'z #'(lambda (arg) (eq arg 'x))
+ '(a x b x c x d x e x f) :count 3 :from-end t)
+ '(a x b x c z d z e z f))
+(equal (substitute-if 'z #'(lambda (arg) (eq arg 'x))
+ '(a x b x c x d x e x f) :count 4 :from-end t)
+ '(a x b z c z d z e z f))
+(equal (substitute-if 'z #'(lambda (arg) (eq arg 'x))
+ '(a x b x c x d x e x f) :count 5 :from-end t)
+ '(a z b z c z d z e z f))
+(equal (substitute-if 'z #'(lambda (arg) (eq arg 'x))
+ '(a x b x c x d x e x f) :count 6 :from-end t)
+ '(a z b z c z d z e z f))
+(equal (substitute-if 'z #'(lambda (arg) (eq arg 'x))
+ '(a x b x c x d x e x f) :count 7 :from-end t)
+ '(a z b z c z d z e z f))
+(equal (substitute-if 'z #'(lambda (arg) (eq arg 'x))
+ '(a x b x c x d x e x f) :start 2 :count 1)
+ '(a x b z c x d x e x f))
+(equal (substitute-if 'z #'(lambda (arg) (eq arg 'x))
+ '(a x b x c x d x e x f) :start 2 :end nil :count 1)
+ '(a x b z c x d x e x f))
+(equal (substitute-if 'z #'(lambda (arg) (eq arg 'x))
+ '(a x b x c x d x e x f) :start 2 :end 6 :count 100)
+ '(a x b z c z d x e x f))
+(equal (substitute-if 'z #'(lambda (arg) (eq arg 'x))
+ '(a x b x c x d x e x f) :start 2 :end 11 :count 100)
+ '(a x b z c z d z e z f))
+(equal (substitute-if 'z #'(lambda (arg) (eq arg 'x))
+ '(a x b x c x d x e x f) :start 2 :end 8 :count 10)
+ '(a x b z c z d z e x f))
+(equal (substitute-if 'z #'(lambda (arg) (eq arg 'x))
+ '(a x b x c x d x e x f)
+ :start 2 :end 8 :count 2 :from-end t)
+ '(a x b x c z d z e x f))
+(equal (substitute-if #\z #'(lambda (arg) (char< #\c arg))
+ '(#\a #\b #\c #\d #\e #\f))
+ '(#\a #\b #\c #\z #\z #\z))
+(equal (substitute-if "peace" #'(lambda (arg) (equal "war" arg))
+ '("love" "hate" "war" "peace"))
+ '("love" "hate" "peace" "peace"))
+(equal (substitute-if "peace" #'(lambda (arg) (string-equal "war" arg))
+ '("war" "War" "WAr" "WAR"))
+ '("peace" "peace" "peace" "peace"))
+(equal (substitute-if "peace" #'(lambda (arg) (string= "WAR" arg))
+ '("war" "War" "WAr" "WAR")
+ :key #'string-upcase)
+ '("peace" "peace" "peace" "peace"))
+(equal (substitute-if "peace" #'(lambda (arg) (string= "WAR" arg))
+ '("war" "War" "WAr" "WAR")
+ :start 1
+ :end 2
+ :key #'string-upcase)
+ '("war" "peace" "WAr" "WAR"))
+(equal (substitute-if "peace" #'(lambda (arg) (string= "WAR" arg))
+ '("war" "War" "WAr" "WAR")
+ :start 1
+ :end nil
+ :key #'string-upcase)
+ '("war" "peace" "peace" "peace"))
+(equal (substitute-if "peace" #'(lambda (arg) (string= "war" arg))
+ '("war" "War" "WAr" "WAR")
+ :key #'string-upcase)
+ '("war" "War" "WAr" "WAR"))
+(equal (substitute-if "peace" #'(lambda (arg) (string= "WAR" arg))
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")
+ :start 1
+ :end 7
+ :count 1
+ :key #'string-upcase)
+ '("war" "peace" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+(equal (substitute-if "peace" #'(lambda (arg) (string= "WAR" arg))
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")
+ :start 1
+ :end 7
+ :count 2
+ :key #'string-upcase)
+ '("war" "peace" "peace" "WAR" "war" "War" "WAr" "WAR"))
+(equal (substitute-if "peace" #'(lambda (arg) (string= "WAR" arg))
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")
+ :start 1
+ :end 7
+ :count 2
+ :from-end t
+ :key #'string-upcase)
+ '("war" "War" "WAr" "WAR" "war" "peace" "peace" "WAR"))
+(equal (substitute-if "peace" #'(lambda (arg) (string= "WAR" arg))
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")
+ :start 1
+ :end 7
+ :count 0
+ :from-end t
+ :key #'string-upcase)
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+(equal (substitute-if "peace" #'(lambda (arg) (string= "WAR" arg))
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")
+ :start 1
+ :end 7
+ :count -2
+ :from-end t
+ :key #'string-upcase)
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+(equal (substitute-if "peace" #'(lambda (arg) (string= "WAR" arg))
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")
+ :start 1
+ :end 7
+ :count nil
+ :from-end t
+ :key #'string-upcase)
+ '("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR"))
+(equal (substitute-if "peace" #'(lambda (arg) (string= "WAR" arg))
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")
+ :start 1
+ :end 7
+ :count 6
+ :from-end t
+ :key #'string-upcase)
+ '("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR"))
+(equal (substitute-if "peace" #'(lambda (arg) (string= "WAR" arg))
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")
+ :start 1
+ :end 7
+ :count 7
+ :from-end t
+ :key #'string-upcase)
+ '("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR"))
+(equal (substitute-if "peace" #'(lambda (arg) (string= "WAR" arg))
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")
+ :start 1
+ :end 7
+ :count 100
+ :from-end t
+ :key #'string-upcase)
+ '("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR"))
+
+
+(equalp (substitute-if 'a #'(lambda (arg) (eq arg 'x)) #(x y z)) #(a y z))
+(equalp (substitute-if 'b #'(lambda (arg) (eq arg 'y)) #(x y z)) #(x b z))
+(equalp (substitute-if 'c #'(lambda (arg) (eq arg 'z)) #(x y z)) #(x y c))
+(equalp (substitute-if 'a #'(lambda (arg) (eq arg 'p)) #(x y z)) #(x y z))
+(equalp (substitute-if 'a #'(lambda (arg) (eq arg 'x)) #()) #())
+(equalp (substitute-if #\x #'(lambda (arg) (char< #\b arg))
+ #(#\a #\b #\c #\d #\e))
+ #(#\a #\b #\x #\x #\x))
+(equalp (substitute-if '(a) #'(lambda (arg) (eq arg 'x))
+ #((x) (y) (z)) :key #'car)
+ #((a) (y) (z)))
+(equalp (substitute-if 'c #'(lambda (arg) (eq arg 'b))
+ #(a b a b a b a b)) #(a c a c a c a c))
+(equalp (substitute-if 'a #'(lambda (arg) (eq arg 'b))
+ #(b b b)) #(a a a))
+(equalp (substitute-if 'z #'(lambda (arg) (eq arg 'x))
+ #(a x b x c x d x e x f))
+ #(a z b z c z d z e z f))
+(equalp (substitute-if 'z #'(lambda (arg) (eq arg 'x))
+ #(a x b x c x d x e x f) :count nil)
+ #(a z b z c z d z e z f))
+(equalp (substitute-if 'z #'(lambda (arg) (eq arg 'x))
+ #(a x b x c x d x e x f) :count 0)
+ #(a x b x c x d x e x f))
+(equalp (substitute-if 'z #'(lambda (arg) (eq arg 'x))
+ #(a x b x c x d x e x f) :count -100)
+ #(a x b x c x d x e x f))
+(equalp (substitute-if 'z #'(lambda (arg) (eq arg 'x))
+ #(a x b x c x d x e x f) :count 1)
+ #(a z b x c x d x e x f))
+(equalp (substitute-if 'z #'(lambda (arg) (eq arg 'x))
+ #(a x b x c x d x e x f) :count 2)
+ #(a z b z c x d x e x f))
+(equalp (substitute-if 'z #'(lambda (arg) (eq arg 'x))
+ #(a x b x c x d x e x f) :count 3)
+ #(a z b z c z d x e x f))
+(equalp (substitute-if 'z #'(lambda (arg) (eq arg 'x))
+ #(a x b x c x d x e x f) :count 4)
+ #(a z b z c z d z e x f))
+(equalp (substitute-if 'z #'(lambda (arg) (eq arg 'x))
+ #(a x b x c x d x e x f) :count 5)
+ #(a z b z c z d z e z f))
+(equalp (substitute-if 'z #'(lambda (arg) (eq arg 'x))
+ #(a x b x c x d x e x f) :count 6)
+ #(a z b z c z d z e z f))
+(equalp (substitute-if 'z #'(lambda (arg) (eq arg 'x))
+ #(a x b x c x d x e x f) :count 7)
+ #(a z b z c z d z e z f))
+(equalp (substitute-if 'z #'(lambda (arg) (eq arg 'x))
+ #(a x b x c x d x e x f) :count nil :from-end t)
+ #(a z b z c z d z e z f))
+(equalp (substitute-if 'z #'(lambda (arg) (eq arg 'x))
+ #(a x b x c x d x e x f) :count 0 :from-end t)
+ #(a x b x c x d x e x f))
+(equalp (substitute-if 'z #'(lambda (arg) (eq arg 'x))
+ #(a x b x c x d x e x f) :count -100 :from-end t)
+ #(a x b x c x d x e x f))
+(equalp (substitute-if 'z #'(lambda (arg) (eq arg 'x))
+ #(a x b x c x d x e x f) :count 1 :from-end t)
+ #(a x b x c x d x e z f))
+(equalp (substitute-if 'z #'(lambda (arg) (eq arg 'x))
+ #(a x b x c x d x e x f) :count 2 :from-end t)
+ #(a x b x c x d z e z f))
+(equalp (substitute-if 'z #'(lambda (arg) (eq arg 'x))
+ #(a x b x c x d x e x f) :count 3 :from-end t)
+ #(a x b x c z d z e z f))
+(equalp (substitute-if 'z #'(lambda (arg) (eq arg 'x))
+ #(a x b x c x d x e x f) :count 4 :from-end t)
+ #(a x b z c z d z e z f))
+(equalp (substitute-if 'z #'(lambda (arg) (eq arg 'x))
+ #(a x b x c x d x e x f) :count 5 :from-end t)
+ #(a z b z c z d z e z f))
+(equalp (substitute-if 'z #'(lambda (arg) (eq arg 'x))
+ #(a x b x c x d x e x f) :count 6 :from-end t)
+ #(a z b z c z d z e z f))
+(equalp (substitute-if 'z #'(lambda (arg) (eq arg 'x))
+ #(a x b x c x d x e x f) :count 7 :from-end t)
+ #(a z b z c z d z e z f))
+(equalp (substitute-if 'z #'(lambda (arg) (eq arg 'x))
+ #(a x b x c x d x e x f) :start 2 :count 1)
+ #(a x b z c x d x e x f))
+(equalp (substitute-if 'z #'(lambda (arg) (eq arg 'x))
+ #(a x b x c x d x e x f) :start 2 :end nil :count 1)
+ #(a x b z c x d x e x f))
+(equalp (substitute-if 'z #'(lambda (arg) (eq arg 'x))
+ #(a x b x c x d x e x f) :start 2 :end 6 :count 100)
+ #(a x b z c z d x e x f))
+(equalp (substitute-if 'z #'(lambda (arg) (eq arg 'x))
+ #(a x b x c x d x e x f) :start 2 :end 11 :count 100)
+ #(a x b z c z d z e z f))
+(equalp (substitute-if 'z #'(lambda (arg) (eq arg 'x))
+ #(a x b x c x d x e x f) :start 2 :end 8 :count 10)
+ #(a x b z c z d z e x f))
+(equalp (substitute-if 'z #'(lambda (arg) (eq arg 'x))
+ #(a x b x c x d x e x f)
+ :start 2 :end 8 :count 2 :from-end t)
+ #(a x b x c z d z e x f))
+(equalp (substitute-if #\z #'(lambda (arg) (char< #\c arg))
+ #(#\a #\b #\c #\d #\e #\f))
+ #(#\a #\b #\c #\z #\z #\z))
+(equalp (substitute-if "peace" #'(lambda (arg) (equal "war" arg))
+ #("love" "hate" "war" "peace"))
+ #("love" "hate" "peace" "peace"))
+(equalp (substitute-if "peace" #'(lambda (arg) (string-equal "war" arg))
+ #("war" "War" "WAr" "WAR"))
+ #("peace" "peace" "peace" "peace"))
+(equalp (substitute-if "peace" #'(lambda (arg) (string= "WAR" arg))
+ #("war" "War" "WAr" "WAR")
+ :key #'string-upcase)
+ #("peace" "peace" "peace" "peace"))
+(equalp (substitute-if "peace" #'(lambda (arg) (string= "WAR" arg))
+ #("war" "War" "WAr" "WAR")
+ :start 1
+ :end 2
+ :key #'string-upcase)
+ #("war" "peace" "WAr" "WAR"))
+(equalp (substitute-if "peace" #'(lambda (arg) (string= "WAR" arg))
+ #("war" "War" "WAr" "WAR")
+ :start 1
+ :end nil
+ :key #'string-upcase)
+ #("war" "peace" "peace" "peace"))
+(equalp (substitute-if "peace" #'(lambda (arg) (string= "war" arg))
+ #("war" "War" "WAr" "WAR")
+ :key #'string-upcase)
+ #("war" "War" "WAr" "WAR"))
+(equalp (substitute-if "peace" #'(lambda (arg) (string= "WAR" arg))
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")
+ :start 1
+ :end 7
+ :count 1
+ :key #'string-upcase)
+ #("war" "peace" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+(equalp (substitute-if "peace" #'(lambda (arg) (string= "WAR" arg))
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")
+ :start 1
+ :end 7
+ :count 2
+ :key #'string-upcase)
+ #("war" "peace" "peace" "WAR" "war" "War" "WAr" "WAR"))
+(equalp (substitute-if "peace" #'(lambda (arg) (string= "WAR" arg))
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")
+ :start 1
+ :end 7
+ :count 2
+ :from-end t
+ :key #'string-upcase)
+ #("war" "War" "WAr" "WAR" "war" "peace" "peace" "WAR"))
+(equalp (substitute-if "peace" #'(lambda (arg) (string= "WAR" arg))
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")
+ :start 1
+ :end 7
+ :count 0
+ :from-end t
+ :key #'string-upcase)
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+(equalp (substitute-if "peace" #'(lambda (arg) (string= "WAR" arg))
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")
+ :start 1
+ :end 7
+ :count -2
+ :from-end t
+ :key #'string-upcase)
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+(equalp (substitute-if "peace" #'(lambda (arg) (string= "WAR" arg))
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")
+ :start 1
+ :end 7
+ :count nil
+ :from-end t
+ :key #'string-upcase)
+ #("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR"))
+(equalp (substitute-if "peace" #'(lambda (arg) (string= "WAR" arg))
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")
+ :start 1
+ :end 7
+ :count 6
+ :from-end t
+ :key #'string-upcase)
+ #("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR"))
+(equalp (substitute-if "peace" #'(lambda (arg) (string= "WAR" arg))
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")
+ :start 1
+ :end 7
+ :count 7
+ :from-end t
+ :key #'string-upcase)
+ #("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR"))
+(equalp (substitute-if "peace" #'(lambda (arg) (string= "WAR" arg))
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")
+ :start 1
+ :end 7
+ :count 100
+ :from-end t
+ :key #'string-upcase)
+ #("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR"))
+
+(string= (substitute-if #\A #'(lambda (arg) (eql #\a arg)) "abcabc") "AbcAbc")
+(string= (substitute-if #\A #'(lambda (arg) (eql #\a arg)) "") "")
+(string= (substitute-if #\A #'(lambda (arg) (eql #\a arg)) "xyz") "xyz")
+(string= (substitute-if #\A #'(lambda (arg) (eql #\a arg))
+ "aaaaaaaaaa" :start 5 :end nil) "aaaaaAAAAA")
+(string= (substitute-if #\x #'(lambda (arg) (char< #\5 arg))
+ "0123456789") "012345xxxx")
+(string= (substitute-if #\x #'(lambda (arg) (char> #\5 arg))
+ "0123456789") "xxxxx56789")
+(string= (substitute-if #\x #'(lambda (arg) (char> #\D arg)) "abcdefg"
+ :key #'char-upcase)
+ "xxxdefg")
+(string= (substitute-if #\x #'(lambda (arg) (char> #\D arg)) "abcdefg"
+ :start 1
+ :end 2
+ :key #'char-upcase)
+ "axcdefg")
+(string= (substitute-if #\A #'(lambda (arg) (eql #\a arg))
+ "aaaaaaaaaa" :count 2) "AAaaaaaaaa")
+(string= (substitute-if #\A #'(lambda (arg) (eql #\a arg))
+ "aaaaaaaaaa" :count -1) "aaaaaaaaaa")
+(string= (substitute-if #\A #'(lambda (arg) (eql #\a arg))
+ "aaaaaaaaaa" :count 0) "aaaaaaaaaa")
+(string= (substitute-if #\A #'(lambda (arg) (eql #\a arg))
+ "aaaaaaaaaa" :count nil) "AAAAAAAAAA")
+(string= (substitute-if #\A #'(lambda (arg) (eql #\a arg))
+ "aaaaaaaaaa" :count 100) "AAAAAAAAAA")
+(string= (substitute-if #\A #'(lambda (arg) (eql #\a arg))
+ "aaaaaaaaaa" :count 9) "AAAAAAAAAa")
+(string= (substitute-if #\A #'(lambda (arg) (eql #\a arg))
+ "aaaaaaaaaa" :count 9 :from-end t) "aAAAAAAAAA")
+(string= (substitute-if #\A #'(lambda (arg) (eql #\a arg))
+ "aaaaaaaaaa"
+ :start 2
+ :end 8
+ :count 3)
+ "aaAAAaaaaa")
+(string= (substitute-if #\A #'(lambda (arg) (eql #\a arg))
+ "aaaaaaaaaa"
+ :start 2
+ :end 8
+ :from-end t
+ :count 3)
+ "aaaaaAAAaa")
+(string= (substitute-if #\x #'(lambda (arg) (eql #\A arg))
+ "aaaaaaaaaa"
+ :start 2
+ :end 8
+ :from-end t
+ :count 3)
+ "aaaaaaaaaa")
+(string= (substitute-if #\X #'(lambda (arg) (eql #\A arg))
+ "aaaaaaaaaa"
+ :start 2
+ :end 8
+ :from-end t
+ :key #'char-upcase
+ :count 3)
+ "aaaaaXXXaa")
+(string= (substitute-if #\X #'(lambda (arg) (char< #\D arg))
+ "abcdefghij"
+ :start 2
+ :end 8
+ :from-end t
+ :key #'char-upcase
+ :count 3)
+ "abcdeXXXij")
+(equalp (substitute-if 0 #'(lambda (arg) (= 1 arg)) #*1111) #*0000)
+(equalp (substitute-if 0 #'(lambda (arg) (= 1 arg))
+ #*1111 :start 1 :end nil) #*1000)
+(equalp (substitute-if 0 #'(lambda (arg) (= 1 arg))
+ #*1111 :start 1 :end 3) #*1001)
+(equalp (substitute-if 0 #'(lambda (arg) (= 1 arg))
+ #*11111111 :start 1 :end 7) #*10000001)
+(equalp (substitute-if 0 #'(lambda (arg) (= 1 arg))
+ #*11111111 :start 1 :end 7 :count 3) #*10001111)
+(equalp (substitute-if 0 #'(lambda (arg) (= 1 arg))
+ #*11111111 :start 1 :end 7 :count 3 :from-end t)
+ #*11110001)
+(equalp (substitute-if 1 #'(lambda (arg) (= 1 arg))
+ #*10101010
+ :start 1 :end 7 :count 3 :from-end t
+ :key #'(lambda (x) (if (zerop x) 1 0)))
+ #*11111110)
+(equalp (substitute-if 1 #'(lambda (arg) (>= 1 arg))
+ #*10101010
+ :start 1 :end 7 :count 3 :from-end t
+ :key #'(lambda (x) (if (zerop x) 1 0)))
+ #*10101110)
+
+
+
+(equal (substitute-if-not 'a #'(lambda (arg) (not (eq arg 'x))) '(x y z))
+ '(a y z))
+(equal (substitute-if-not 'b #'(lambda (arg) (not (eq arg 'y))) '(x y z))
+ '(x b z))
+(equal (substitute-if-not 'c #'(lambda (arg) (not (eq arg 'z))) '(x y z))
+ '(x y c))
+(equal (substitute-if-not 'a #'(lambda (arg) (not (eq arg 'p))) '(x y z))
+ '(x y z))
+(equal (substitute-if-not 'a #'(lambda (arg) (not (eq arg 'x))) '()) '())
+(equal (substitute-if-not #\x #'(lambda (arg) (not (char< #\b arg)))
+ '(#\a #\b #\c #\d #\e))
+ '(#\a #\b #\x #\x #\x))
+(equal (substitute-if-not '(a) #'(lambda (arg) (not (eq arg 'x)))
+ '((x) (y) (z)) :key #'car)
+ '((a) (y) (z)))
+(equal (substitute-if-not 'c #'(lambda (arg) (not (eq arg 'b)))
+ '(a b a b a b a b)) '(a c a c a c a c))
+(equal (substitute-if-not 'a #'(lambda (arg) (not (eq arg 'b)))
+ '(b b b)) '(a a a))
+(equal (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ '(a x b x c x d x e x f))
+ '(a z b z c z d z e z f))
+(equal (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ '(a x b x c x d x e x f) :count nil)
+ '(a z b z c z d z e z f))
+(equal (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ '(a x b x c x d x e x f) :count 0)
+ '(a x b x c x d x e x f))
+(equal (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ '(a x b x c x d x e x f) :count -100)
+ '(a x b x c x d x e x f))
+(equal (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ '(a x b x c x d x e x f) :count 1)
+ '(a z b x c x d x e x f))
+(equal (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ '(a x b x c x d x e x f) :count 2)
+ '(a z b z c x d x e x f))
+(equal (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ '(a x b x c x d x e x f) :count 3)
+ '(a z b z c z d x e x f))
+(equal (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ '(a x b x c x d x e x f) :count 4)
+ '(a z b z c z d z e x f))
+(equal (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ '(a x b x c x d x e x f) :count 5)
+ '(a z b z c z d z e z f))
+(equal (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ '(a x b x c x d x e x f) :count 6)
+ '(a z b z c z d z e z f))
+(equal (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ '(a x b x c x d x e x f) :count 7)
+ '(a z b z c z d z e z f))
+(equal (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ '(a x b x c x d x e x f) :count nil :from-end t)
+ '(a z b z c z d z e z f))
+(equal (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ '(a x b x c x d x e x f) :count 0 :from-end t)
+ '(a x b x c x d x e x f))
+(equal (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ '(a x b x c x d x e x f) :count -100 :from-end t)
+ '(a x b x c x d x e x f))
+(equal (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ '(a x b x c x d x e x f) :count 1 :from-end t)
+ '(a x b x c x d x e z f))
+(equal (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ '(a x b x c x d x e x f) :count 2 :from-end t)
+ '(a x b x c x d z e z f))
+(equal (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ '(a x b x c x d x e x f) :count 3 :from-end t)
+ '(a x b x c z d z e z f))
+(equal (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ '(a x b x c x d x e x f) :count 4 :from-end t)
+ '(a x b z c z d z e z f))
+(equal (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ '(a x b x c x d x e x f) :count 5 :from-end t)
+ '(a z b z c z d z e z f))
+(equal (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ '(a x b x c x d x e x f) :count 6 :from-end t)
+ '(a z b z c z d z e z f))
+(equal (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ '(a x b x c x d x e x f) :count 7 :from-end t)
+ '(a z b z c z d z e z f))
+(equal (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ '(a x b x c x d x e x f) :start 2 :count 1)
+ '(a x b z c x d x e x f))
+(equal (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ '(a x b x c x d x e x f) :start 2 :end nil :count 1)
+ '(a x b z c x d x e x f))
+(equal (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ '(a x b x c x d x e x f) :start 2 :end 6 :count 100)
+ '(a x b z c z d x e x f))
+(equal (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ '(a x b x c x d x e x f) :start 2 :end 11 :count 100)
+ '(a x b z c z d z e z f))
+(equal (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ '(a x b x c x d x e x f) :start 2 :end 8 :count 10)
+ '(a x b z c z d z e x f))
+(equal (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ '(a x b x c x d x e x f)
+ :start 2 :end 8 :count 2 :from-end t)
+ '(a x b x c z d z e x f))
+(equal (substitute-if-not #\z #'(lambda (arg) (not (char< #\c arg)))
+ '(#\a #\b #\c #\d #\e #\f))
+ '(#\a #\b #\c #\z #\z #\z))
+(equal (substitute-if-not "peace" #'(lambda (arg) (not (equal "war" arg)))
+ '("love" "hate" "war" "peace"))
+ '("love" "hate" "peace" "peace"))
+(equal (substitute-if-not "peace"
+ #'(lambda (arg) (not (string-equal "war" arg)))
+ '("war" "War" "WAr" "WAR"))
+ '("peace" "peace" "peace" "peace"))
+(equal (substitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg)))
+ '("war" "War" "WAr" "WAR")
+ :key #'string-upcase)
+ '("peace" "peace" "peace" "peace"))
+(equal (substitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg)))
+ '("war" "War" "WAr" "WAR")
+ :start 1
+ :end 2
+ :key #'string-upcase)
+ '("war" "peace" "WAr" "WAR"))
+(equal (substitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg)))
+ '("war" "War" "WAr" "WAR")
+ :start 1
+ :end nil
+ :key #'string-upcase)
+ '("war" "peace" "peace" "peace"))
+(equal (substitute-if-not "peace" #'(lambda (arg) (not (string= "war" arg)))
+ '("war" "War" "WAr" "WAR")
+ :key #'string-upcase)
+ '("war" "War" "WAr" "WAR"))
+(equal (substitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg)))
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")
+ :start 1
+ :end 7
+ :count 1
+ :key #'string-upcase)
+ '("war" "peace" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+(equal (substitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg)))
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")
+ :start 1
+ :end 7
+ :count 2
+ :key #'string-upcase)
+ '("war" "peace" "peace" "WAR" "war" "War" "WAr" "WAR"))
+(equal (substitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg)))
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")
+ :start 1
+ :end 7
+ :count 2
+ :from-end t
+ :key #'string-upcase)
+ '("war" "War" "WAr" "WAR" "war" "peace" "peace" "WAR"))
+(equal (substitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg)))
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")
+ :start 1
+ :end 7
+ :count 0
+ :from-end t
+ :key #'string-upcase)
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+(equal (substitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg)))
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")
+ :start 1
+ :end 7
+ :count -2
+ :from-end t
+ :key #'string-upcase)
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+(equal (substitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg)))
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")
+ :start 1
+ :end 7
+ :count nil
+ :from-end t
+ :key #'string-upcase)
+ '("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR"))
+(equal (substitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg)))
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")
+ :start 1
+ :end 7
+ :count 6
+ :from-end t
+ :key #'string-upcase)
+ '("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR"))
+(equal (substitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg)))
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")
+ :start 1
+ :end 7
+ :count 7
+ :from-end t
+ :key #'string-upcase)
+ '("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR"))
+(equal (substitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg)))
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")
+ :start 1
+ :end 7
+ :count 100
+ :from-end t
+ :key #'string-upcase)
+ '("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR"))
+
+
+(equalp (substitute-if-not 'a #'(lambda (arg) (not (eq arg 'x)))
+ #(x y z)) #(a y z))
+(equalp (substitute-if-not 'b #'(lambda (arg) (not (eq arg 'y)))
+ #(x y z)) #(x b z))
+(equalp (substitute-if-not 'c #'(lambda (arg) (not (eq arg 'z)))
+ #(x y z)) #(x y c))
+(equalp (substitute-if-not 'a #'(lambda (arg) (not (eq arg 'p)))
+ #(x y z)) #(x y z))
+(equalp (substitute-if-not 'a #'(lambda (arg) (not (eq arg 'x)))
+ #()) #())
+(equalp (substitute-if-not #\x #'(lambda (arg) (not (char< #\b arg)))
+ #(#\a #\b #\c #\d #\e))
+ #(#\a #\b #\x #\x #\x))
+(equalp (substitute-if-not '(a) #'(lambda (arg) (not (eq arg 'x)))
+ #((x) (y) (z)) :key #'car)
+ #((a) (y) (z)))
+(equalp (substitute-if-not 'c #'(lambda (arg) (not (eq arg 'b)))
+ #(a b a b a b a b)) #(a c a c a c a c))
+(equalp (substitute-if-not 'a #'(lambda (arg) (not (eq arg 'b)))
+ #(b b b)) #(a a a))
+(equalp (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ #(a x b x c x d x e x f))
+ #(a z b z c z d z e z f))
+(equalp (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ #(a x b x c x d x e x f) :count nil)
+ #(a z b z c z d z e z f))
+(equalp (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ #(a x b x c x d x e x f) :count 0)
+ #(a x b x c x d x e x f))
+(equalp (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ #(a x b x c x d x e x f) :count -100)
+ #(a x b x c x d x e x f))
+(equalp (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ #(a x b x c x d x e x f) :count 1)
+ #(a z b x c x d x e x f))
+(equalp (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ #(a x b x c x d x e x f) :count 2)
+ #(a z b z c x d x e x f))
+(equalp (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ #(a x b x c x d x e x f) :count 3)
+ #(a z b z c z d x e x f))
+(equalp (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ #(a x b x c x d x e x f) :count 4)
+ #(a z b z c z d z e x f))
+(equalp (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ #(a x b x c x d x e x f) :count 5)
+ #(a z b z c z d z e z f))
+(equalp (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ #(a x b x c x d x e x f) :count 6)
+ #(a z b z c z d z e z f))
+(equalp (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ #(a x b x c x d x e x f) :count 7)
+ #(a z b z c z d z e z f))
+(equalp (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ #(a x b x c x d x e x f) :count nil :from-end t)
+ #(a z b z c z d z e z f))
+(equalp (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ #(a x b x c x d x e x f) :count 0 :from-end t)
+ #(a x b x c x d x e x f))
+(equalp (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ #(a x b x c x d x e x f) :count -100 :from-end t)
+ #(a x b x c x d x e x f))
+(equalp (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ #(a x b x c x d x e x f) :count 1 :from-end t)
+ #(a x b x c x d x e z f))
+(equalp (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ #(a x b x c x d x e x f) :count 2 :from-end t)
+ #(a x b x c x d z e z f))
+(equalp (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ #(a x b x c x d x e x f) :count 3 :from-end t)
+ #(a x b x c z d z e z f))
+(equalp (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ #(a x b x c x d x e x f) :count 4 :from-end t)
+ #(a x b z c z d z e z f))
+(equalp (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ #(a x b x c x d x e x f) :count 5 :from-end t)
+ #(a z b z c z d z e z f))
+(equalp (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ #(a x b x c x d x e x f) :count 6 :from-end t)
+ #(a z b z c z d z e z f))
+(equalp (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ #(a x b x c x d x e x f) :count 7 :from-end t)
+ #(a z b z c z d z e z f))
+(equalp (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ #(a x b x c x d x e x f) :start 2 :count 1)
+ #(a x b z c x d x e x f))
+(equalp (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ #(a x b x c x d x e x f) :start 2 :end nil :count 1)
+ #(a x b z c x d x e x f))
+(equalp (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ #(a x b x c x d x e x f) :start 2 :end 6 :count 100)
+ #(a x b z c z d x e x f))
+(equalp (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ #(a x b x c x d x e x f) :start 2 :end 11 :count 100)
+ #(a x b z c z d z e z f))
+(equalp (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ #(a x b x c x d x e x f) :start 2 :end 8 :count 10)
+ #(a x b z c z d z e x f))
+(equalp (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ #(a x b x c x d x e x f)
+ :start 2 :end 8 :count 2 :from-end t)
+ #(a x b x c z d z e x f))
+(equalp (substitute-if-not #\z #'(lambda (arg) (not (char< #\c arg)))
+ #(#\a #\b #\c #\d #\e #\f))
+ #(#\a #\b #\c #\z #\z #\z))
+(equalp (substitute-if-not "peace" #'(lambda (arg) (not (equal "war" arg)))
+ #("love" "hate" "war" "peace"))
+ #("love" "hate" "peace" "peace"))
+(equalp (substitute-if-not "peace"
+ #'(lambda (arg) (not (string-equal "war" arg)))
+ #("war" "War" "WAr" "WAR"))
+ #("peace" "peace" "peace" "peace"))
+(equalp (substitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg)))
+ #("war" "War" "WAr" "WAR")
+ :key #'string-upcase)
+ #("peace" "peace" "peace" "peace"))
+(equalp (substitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg)))
+ #("war" "War" "WAr" "WAR")
+ :start 1
+ :end 2
+ :key #'string-upcase)
+ #("war" "peace" "WAr" "WAR"))
+(equalp (substitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg)))
+ #("war" "War" "WAr" "WAR")
+ :start 1
+ :end nil
+ :key #'string-upcase)
+ #("war" "peace" "peace" "peace"))
+(equalp (substitute-if-not "peace" #'(lambda (arg) (not (string= "war" arg)))
+ #("war" "War" "WAr" "WAR")
+ :key #'string-upcase)
+ #("war" "War" "WAr" "WAR"))
+(equalp (substitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg)))
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")
+ :start 1
+ :end 7
+ :count 1
+ :key #'string-upcase)
+ #("war" "peace" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+(equalp (substitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg)))
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")
+ :start 1
+ :end 7
+ :count 2
+ :key #'string-upcase)
+ #("war" "peace" "peace" "WAR" "war" "War" "WAr" "WAR"))
+(equalp (substitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg)))
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")
+ :start 1
+ :end 7
+ :count 2
+ :from-end t
+ :key #'string-upcase)
+ #("war" "War" "WAr" "WAR" "war" "peace" "peace" "WAR"))
+(equalp (substitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg)))
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")
+ :start 1
+ :end 7
+ :count 0
+ :from-end t
+ :key #'string-upcase)
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+(equalp (substitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg)))
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")
+ :start 1
+ :end 7
+ :count -2
+ :from-end t
+ :key #'string-upcase)
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+(equalp (substitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg)))
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")
+ :start 1
+ :end 7
+ :count nil
+ :from-end t
+ :key #'string-upcase)
+ #("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR"))
+(equalp (substitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg)))
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")
+ :start 1
+ :end 7
+ :count 6
+ :from-end t
+ :key #'string-upcase)
+ #("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR"))
+(equalp (substitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg)))
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")
+ :start 1
+ :end 7
+ :count 7
+ :from-end t
+ :key #'string-upcase)
+ #("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR"))
+(equalp (substitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg)))
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")
+ :start 1
+ :end 7
+ :count 100
+ :from-end t
+ :key #'string-upcase)
+ #("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR"))
+
+(string= (substitute-if-not #\A #'(lambda (arg) (not (eql #\a arg))) "abcabc")
+ "AbcAbc")
+(string= (substitute-if-not #\A #'(lambda (arg) (not (eql #\a arg))) "") "")
+(string= (substitute-if-not #\A #'(lambda (arg) (not (eql #\a arg))) "xyz")
+ "xyz")
+(string= (substitute-if-not #\A #'(lambda (arg) (not (eql #\a arg)))
+ "aaaaaaaaaa" :start 5 :end nil) "aaaaaAAAAA")
+(string= (substitute-if-not #\x #'(lambda (arg) (not (char< #\5 arg)))
+ "0123456789") "012345xxxx")
+(string= (substitute-if-not #\x #'(lambda (arg) (not (char> #\5 arg)))
+ "0123456789") "xxxxx56789")
+(string= (substitute-if-not #\x #'(lambda (arg) (not (char> #\D arg)))
+ "abcdefg"
+ :key #'char-upcase)
+ "xxxdefg")
+(string= (substitute-if-not #\x #'(lambda (arg) (not (char> #\D arg)))
+ "abcdefg"
+ :start 1
+ :end 2
+ :key #'char-upcase)
+ "axcdefg")
+(string= (substitute-if-not #\A #'(lambda (arg) (not (eql #\a arg)))
+ "aaaaaaaaaa" :count 2) "AAaaaaaaaa")
+(string= (substitute-if-not #\A #'(lambda (arg) (not (eql #\a arg)))
+ "aaaaaaaaaa" :count -1) "aaaaaaaaaa")
+(string= (substitute-if-not #\A #'(lambda (arg) (not (eql #\a arg)))
+ "aaaaaaaaaa" :count 0) "aaaaaaaaaa")
+(string= (substitute-if-not #\A #'(lambda (arg) (not (eql #\a arg)))
+ "aaaaaaaaaa" :count nil) "AAAAAAAAAA")
+(string= (substitute-if-not #\A #'(lambda (arg) (not (eql #\a arg)))
+ "aaaaaaaaaa" :count 100) "AAAAAAAAAA")
+(string= (substitute-if-not #\A #'(lambda (arg) (not (eql #\a arg)))
+ "aaaaaaaaaa" :count 9) "AAAAAAAAAa")
+(string= (substitute-if-not #\A #'(lambda (arg) (not (eql #\a arg)))
+ "aaaaaaaaaa" :count 9 :from-end t) "aAAAAAAAAA")
+(string= (substitute-if-not #\A #'(lambda (arg) (not (eql #\a arg)))
+ "aaaaaaaaaa"
+ :start 2
+ :end 8
+ :count 3)
+ "aaAAAaaaaa")
+(string= (substitute-if-not #\A #'(lambda (arg) (not (eql #\a arg)))
+ "aaaaaaaaaa"
+ :start 2
+ :end 8
+ :from-end t
+ :count 3)
+ "aaaaaAAAaa")
+(string= (substitute-if-not #\x #'(lambda (arg) (not (eql #\A arg)))
+ "aaaaaaaaaa"
+ :start 2
+ :end 8
+ :from-end t
+ :count 3)
+ "aaaaaaaaaa")
+(string= (substitute-if-not #\X #'(lambda (arg) (not (eql #\A arg)))
+ "aaaaaaaaaa"
+ :start 2
+ :end 8
+ :from-end t
+ :key #'char-upcase
+ :count 3)
+ "aaaaaXXXaa")
+(string= (substitute-if-not #\X #'(lambda (arg) (not (char< #\D arg)))
+ "abcdefghij"
+ :start 2
+ :end 8
+ :from-end t
+ :key #'char-upcase
+ :count 3)
+ "abcdeXXXij")
+(equalp (substitute-if-not 0 #'(lambda (arg) (not (= 1 arg))) #*1111) #*0000)
+(equalp (substitute-if-not 0 #'(lambda (arg) (not (= 1 arg)))
+ #*1111 :start 1 :end nil) #*1000)
+(equalp (substitute-if-not 0 #'(lambda (arg) (not (= 1 arg)))
+ #*1111 :start 1 :end 3) #*1001)
+(equalp (substitute-if-not 0 #'(lambda (arg) (not (= 1 arg)))
+ #*11111111 :start 1 :end 7) #*10000001)
+(equalp (substitute-if-not 0 #'(lambda (arg) (not (= 1 arg)))
+ #*11111111 :start 1 :end 7 :count 3) #*10001111)
+(equalp (substitute-if-not 0 #'(lambda (arg) (not (= 1 arg)))
+ #*11111111 :start 1 :end 7 :count 3 :from-end t)
+ #*11110001)
+(equalp (substitute-if-not 1 #'(lambda (arg) (not (= 1 arg)))
+ #*10101010
+ :start 1 :end 7 :count 3 :from-end t
+ :key #'(lambda (x) (if (zerop x) 1 0)))
+ #*11111110)
+(equalp (substitute-if-not 1 #'(lambda (arg) (not (>= 1 arg)))
+ #*10101010
+ :start 1 :end 7 :count 3 :from-end t
+ :key #'(lambda (x) (if (zerop x) 1 0)))
+ #*10101110)
+
+
+(equal (nsubstitute 'a 'x (copy-seq '(x y z))) '(a y z))
+(equal (nsubstitute 'b 'y (copy-seq '(x y z))) '(x b z))
+(equal (nsubstitute 'c 'z (copy-seq '(x y z))) '(x y c))
+(equal (nsubstitute 'a 'p (copy-seq '(x y z))) '(x y z))
+(equal (nsubstitute 'a 'x (copy-seq '())) '())
+(equal (nsubstitute #\x #\b (copy-seq '(#\a #\b #\c #\d #\e)) :test #'char<)
+ '(#\a #\b #\x #\x #\x))
+(equal (nsubstitute #\x #\b (copy-seq '(#\a #\b #\c #\d #\e))
+ :test-not (complement #'char<))
+ '(#\a #\b #\x #\x #\x))
+(equal (nsubstitute '(a) 'x (copy-seq '((x) (y) (z))) :key #'car)
+ '((a) (y) (z)))
+(equal (nsubstitute 'c 'b (copy-seq '(a b a b a b a b))) '(a c a c a c a c))
+(equal (nsubstitute 'a 'b (copy-seq '(b b b))) '(a a a))
+(equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)))
+ '(a z b z c z d z e z f))
+(equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)) :count nil)
+ '(a z b z c z d z e z f))
+(equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)) :count 0)
+ '(a x b x c x d x e x f))
+(equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)) :count -100)
+ '(a x b x c x d x e x f))
+(equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)) :count 1)
+ '(a z b x c x d x e x f))
+(equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)) :count 2)
+ '(a z b z c x d x e x f))
+(equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)) :count 3)
+ '(a z b z c z d x e x f))
+(equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)) :count 4)
+ '(a z b z c z d z e x f))
+(equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)) :count 5)
+ '(a z b z c z d z e z f))
+(equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)) :count 6)
+ '(a z b z c z d z e z f))
+(equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)) :count 7)
+ '(a z b z c z d z e z f))
+(equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f))
+ :count nil :from-end t)
+ '(a z b z c z d z e z f))
+(equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f))
+ :count 0 :from-end t)
+ '(a x b x c x d x e x f))
+(equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f))
+ :count -100 :from-end t)
+ '(a x b x c x d x e x f))
+(equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f))
+ :count 1 :from-end t)
+ '(a x b x c x d x e z f))
+(equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f))
+ :count 2 :from-end t)
+ '(a x b x c x d z e z f))
+(equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f))
+ :count 3 :from-end t)
+ '(a x b x c z d z e z f))
+(equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f))
+ :count 4 :from-end t)
+ '(a x b z c z d z e z f))
+(equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f))
+ :count 5 :from-end t)
+ '(a z b z c z d z e z f))
+(equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f))
+ :count 6 :from-end t)
+ '(a z b z c z d z e z f))
+(equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f))
+ :count 7 :from-end t)
+ '(a z b z c z d z e z f))
+(equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f))
+ :start 2 :count 1)
+ '(a x b z c x d x e x f))
+(equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f))
+ :start 2 :end nil :count 1)
+ '(a x b z c x d x e x f))
+(equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f))
+ :start 2 :end 6 :count 100)
+ '(a x b z c z d x e x f))
+(equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f))
+ :start 2 :end 11 :count 100)
+ '(a x b z c z d z e z f))
+(equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f))
+ :start 2 :end 8 :count 10)
+ '(a x b z c z d z e x f))
+(equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f))
+ :start 2 :end 8 :count 2 :from-end t)
+ '(a x b x c z d z e x f))
+(equal (nsubstitute #\z #\c (copy-seq '(#\a #\b #\c #\d #\e #\f))
+ :test #'char<)
+ '(#\a #\b #\c #\z #\z #\z))
+(equal (nsubstitute #\z #\c (copy-seq '(#\a #\b #\c #\d #\e #\f))
+ :test-not (complement #'char<))
+ '(#\a #\b #\c #\z #\z #\z))
+(equal (nsubstitute "peace" "war" (copy-seq '("love" "hate" "war" "peace"))
+ :test #'equal)
+ '("love" "hate" "peace" "peace"))
+(equal (nsubstitute "peace" "war" (copy-seq '("love" "hate" "war" "peace"))
+ :test-not (complement #'equal))
+ '("love" "hate" "peace" "peace"))
+(equal (nsubstitute "peace" "war" (copy-seq '("war" "War" "WAr" "WAR"))
+ :test #'string-equal)
+ '("peace" "peace" "peace" "peace"))
+(equal (nsubstitute "peace" "war" (copy-seq '("war" "War" "WAr" "WAR"))
+ :test-not (complement #'string-equal))
+ '("peace" "peace" "peace" "peace"))
+(equal (nsubstitute "peace" "WAR" (copy-seq '("war" "War" "WAr" "WAR"))
+ :test #'string=)
+ '("war" "War" "WAr" "peace"))
+(equal (nsubstitute "peace" "WAR" (copy-seq '("war" "War" "WAr" "WAR"))
+ :test-not (complement #'string=))
+ '("war" "War" "WAr" "peace"))
+(equal (nsubstitute "peace" "WAR" (copy-seq '("war" "War" "WAr" "WAR"))
+ :test #'string=
+ :key #'string-upcase)
+ '("peace" "peace" "peace" "peace"))
+(equal (nsubstitute "peace" "WAR" (copy-seq '("war" "War" "WAr" "WAR"))
+ :test-not (complement #'string=)
+ :key #'string-upcase)
+ '("peace" "peace" "peace" "peace"))
+(equal (nsubstitute "peace" "WAR" (copy-seq '("war" "War" "WAr" "WAR"))
+ :start 1
+ :end 2
+ :test #'string=
+ :key #'string-upcase)
+ '("war" "peace" "WAr" "WAR"))
+(equal (nsubstitute "peace" "WAR" (copy-seq '("war" "War" "WAr" "WAR"))
+ :start 1
+ :end 2
+ :test-not (complement #'string=)
+ :key #'string-upcase)
+ '("war" "peace" "WAr" "WAR"))
+(equal (nsubstitute "peace" "WAR" (copy-seq '("war" "War" "WAr" "WAR"))
+ :start 1
+ :end nil
+ :test #'string=
+ :key #'string-upcase)
+ '("war" "peace" "peace" "peace"))
+(equal (nsubstitute "peace" "WAR" (copy-seq '("war" "War" "WAr" "WAR"))
+ :start 1
+ :end nil
+ :test-not (complement #'string=)
+ :key #'string-upcase)
+ '("war" "peace" "peace" "peace"))
+(equal (nsubstitute "peace" "war" (copy-seq '("war" "War" "WAr" "WAR"))
+ :test #'string=
+ :key #'string-upcase)
+ '("war" "War" "WAr" "WAR"))
+(equal (nsubstitute "peace" "war" (copy-seq '("war" "War" "WAr" "WAR"))
+ :test-not (complement #'string=)
+ :key #'string-upcase)
+ '("war" "War" "WAr" "WAR"))
+(equal (nsubstitute "peace" "WAR"
+ (copy-seq
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+ :start 1
+ :end 7
+ :count 1
+ :test-not (complement #'string=)
+ :key #'string-upcase)
+ '("war" "peace" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+(equal (nsubstitute "peace" "WAR"
+ (copy-seq '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+ :start 1
+ :end 7
+ :count 2
+ :test-not (complement #'string=)
+ :key #'string-upcase)
+ '("war" "peace" "peace" "WAR" "war" "War" "WAr" "WAR"))
+(equal (nsubstitute "peace" "WAR"
+ (copy-seq
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+ :start 1
+ :end 7
+ :count 2
+ :from-end t
+ :test-not (complement #'string=)
+ :key #'string-upcase)
+ '("war" "War" "WAr" "WAR" "war" "peace" "peace" "WAR"))
+(equal (nsubstitute "peace" "WAR"
+ (copy-seq
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+ :start 1
+ :end 7
+ :count 0
+ :from-end t
+ :test-not (complement #'string=)
+ :key #'string-upcase)
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+(equal (nsubstitute "peace" "WAR"
+ (copy-seq
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+ :start 1
+ :end 7
+ :count -2
+ :from-end t
+ :test-not (complement #'string=)
+ :key #'string-upcase)
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+(equal (nsubstitute "peace" "WAR"
+ (copy-seq
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+ :start 1
+ :end 7
+ :count nil
+ :from-end t
+ :test-not (complement #'string=)
+ :key #'string-upcase)
+ '("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR"))
+(equal (nsubstitute "peace" "WAR"
+ (copy-seq
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+ :start 1
+ :end 7
+ :count 6
+ :from-end t
+ :test-not (complement #'string=)
+ :key #'string-upcase)
+ '("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR"))
+(equal (nsubstitute "peace" "WAR"
+ (copy-seq
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+ :start 1
+ :end 7
+ :count 7
+ :from-end t
+ :test-not (complement #'string=)
+ :key #'string-upcase)
+ '("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR"))
+(equal (nsubstitute "peace" "WAR"
+ (copy-seq
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+ :start 1
+ :end 7
+ :count 100
+ :from-end t
+ :test-not (complement #'string=)
+ :key #'string-upcase)
+ '("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR"))
+
+
+(equalp (nsubstitute 'a 'x (copy-seq #(x y z))) #(a y z))
+(equalp (nsubstitute 'b 'y (copy-seq #(x y z))) #(x b z))
+(equalp (nsubstitute 'c 'z (copy-seq #(x y z))) #(x y c))
+(equalp (nsubstitute 'a 'p (copy-seq #(x y z))) #(x y z))
+(equalp (nsubstitute 'a 'x (copy-seq #())) #())
+(equalp (nsubstitute #\x #\b (copy-seq #(#\a #\b #\c #\d #\e)) :test #'char<)
+ #(#\a #\b #\x #\x #\x))
+(equalp (nsubstitute #\x #\b (copy-seq #(#\a #\b #\c #\d #\e))
+ :test-not (complement #'char<))
+ #(#\a #\b #\x #\x #\x))
+(equalp (nsubstitute '(a) 'x (copy-seq #((x) (y) (z))) :key #'car)
+ #((a) (y) (z)))
+(equalp (nsubstitute 'c 'b (copy-seq #(a b a b a b a b))) #(a c a c a c a c))
+(equalp (nsubstitute 'a 'b (copy-seq #(b b b))) #(a a a))
+(equalp (nsubstitute 'z 'x (copy-seq #(a x b x c x d x e x f)))
+ #(a z b z c z d z e z f))
+(equalp (nsubstitute 'z 'x (copy-seq #(a x b x c x d x e x f)) :count nil)
+ #(a z b z c z d z e z f))
+(equalp (nsubstitute 'z 'x (copy-seq #(a x b x c x d x e x f)) :count 0)
+ #(a x b x c x d x e x f))
+(equalp (nsubstitute 'z 'x (copy-seq #(a x b x c x d x e x f)) :count -100)
+ #(a x b x c x d x e x f))
+(equalp (nsubstitute 'z 'x (copy-seq #(a x b x c x d x e x f)) :count 1)
+ #(a z b x c x d x e x f))
+(equalp (nsubstitute 'z 'x (copy-seq #(a x b x c x d x e x f)) :count 2)
+ #(a z b z c x d x e x f))
+(equalp (nsubstitute 'z 'x (copy-seq #(a x b x c x d x e x f)) :count 3)
+ #(a z b z c z d x e x f))
+(equalp (nsubstitute 'z 'x (copy-seq #(a x b x c x d x e x f)) :count 4)
+ #(a z b z c z d z e x f))
+(equalp (nsubstitute 'z 'x (copy-seq #(a x b x c x d x e x f)) :count 5)
+ #(a z b z c z d z e z f))
+(equalp (nsubstitute 'z 'x (copy-seq #(a x b x c x d x e x f)) :count 6)
+ #(a z b z c z d z e z f))
+(equalp (nsubstitute 'z 'x (copy-seq #(a x b x c x d x e x f)) :count 7)
+ #(a z b z c z d z e z f))
+(equalp (nsubstitute 'z 'x (copy-seq #(a x b x c x d x e x f))
+ :count nil :from-end t)
+ #(a z b z c z d z e z f))
+(equalp (nsubstitute 'z 'x (copy-seq #(a x b x c x d x e x f))
+ :count 0 :from-end t)
+ #(a x b x c x d x e x f))
+(equalp (nsubstitute 'z 'x (copy-seq #(a x b x c x d x e x f))
+ :count -100 :from-end t)
+ #(a x b x c x d x e x f))
+(equalp (nsubstitute 'z 'x (copy-seq #(a x b x c x d x e x f))
+ :count 1 :from-end t)
+ #(a x b x c x d x e z f))
+(equalp (nsubstitute 'z 'x (copy-seq #(a x b x c x d x e x f))
+ :count 2 :from-end t)
+ #(a x b x c x d z e z f))
+(equalp (nsubstitute 'z 'x (copy-seq #(a x b x c x d x e x f))
+ :count 3 :from-end t)
+ #(a x b x c z d z e z f))
+(equalp (nsubstitute 'z 'x (copy-seq #(a x b x c x d x e x f))
+ :count 4 :from-end t)
+ #(a x b z c z d z e z f))
+(equalp (nsubstitute 'z 'x (copy-seq #(a x b x c x d x e x f))
+ :count 5 :from-end t)
+ #(a z b z c z d z e z f))
+(equalp (nsubstitute 'z 'x (copy-seq #(a x b x c x d x e x f))
+ :count 6 :from-end t)
+ #(a z b z c z d z e z f))
+(equalp (nsubstitute 'z 'x (copy-seq #(a x b x c x d x e x f))
+ :count 7 :from-end t)
+ #(a z b z c z d z e z f))
+(equalp (nsubstitute 'z 'x (copy-seq #(a x b x c x d x e x f))
+ :start 2 :count 1)
+ #(a x b z c x d x e x f))
+(equalp (nsubstitute 'z 'x (copy-seq #(a x b x c x d x e x f))
+ :start 2 :end nil :count 1)
+ #(a x b z c x d x e x f))
+(equalp (nsubstitute 'z 'x (copy-seq #(a x b x c x d x e x f))
+ :start 2 :end 6 :count 100)
+ #(a x b z c z d x e x f))
+(equalp (nsubstitute 'z 'x (copy-seq #(a x b x c x d x e x f))
+ :start 2 :end 11 :count 100)
+ #(a x b z c z d z e z f))
+(equalp (nsubstitute 'z 'x (copy-seq #(a x b x c x d x e x f))
+ :start 2 :end 8 :count 10)
+ #(a x b z c z d z e x f))
+(equalp (nsubstitute 'z 'x (copy-seq #(a x b x c x d x e x f))
+ :start 2 :end 8 :count 2 :from-end t)
+ #(a x b x c z d z e x f))
+(equalp (nsubstitute #\z #\c (copy-seq #(#\a #\b #\c #\d #\e #\f))
+ :test #'char<)
+ #(#\a #\b #\c #\z #\z #\z))
+(equalp (nsubstitute #\z #\c (copy-seq #(#\a #\b #\c #\d #\e #\f))
+ :test-not (complement #'char<))
+ #(#\a #\b #\c #\z #\z #\z))
+(equalp (nsubstitute "peace" "war" (copy-seq #("love" "hate" "war" "peace"))
+ :test #'equal)
+ #("love" "hate" "peace" "peace"))
+(equalp (nsubstitute "peace" "war" (copy-seq #("love" "hate" "war" "peace"))
+ :test-not (complement #'equal))
+ #("love" "hate" "peace" "peace"))
+(equalp (nsubstitute "peace" "war" (copy-seq #("war" "War" "WAr" "WAR"))
+ :test #'string-equal)
+ #("peace" "peace" "peace" "peace"))
+(equalp (nsubstitute "peace" "war" (copy-seq #("war" "War" "WAr" "WAR"))
+ :test-not (complement #'string-equal))
+ #("peace" "peace" "peace" "peace"))
+(equalp (nsubstitute "peace" "WAR" (copy-seq #("war" "War" "WAr" "WAR"))
+ :test #'string=)
+ #("war" "War" "WAr" "peace"))
+(equalp (nsubstitute "peace" "WAR" (copy-seq #("war" "War" "WAr" "WAR"))
+ :test-not (complement #'string=))
+ #("war" "War" "WAr" "peace"))
+(equalp (nsubstitute "peace" "WAR" (copy-seq #("war" "War" "WAr" "WAR"))
+ :test #'string=
+ :key #'string-upcase)
+ #("peace" "peace" "peace" "peace"))
+(equalp (nsubstitute "peace" "WAR" (copy-seq #("war" "War" "WAr" "WAR"))
+ :test-not (complement #'string=)
+ :key #'string-upcase)
+ #("peace" "peace" "peace" "peace"))
+(equalp (nsubstitute "peace" "WAR" (copy-seq #("war" "War" "WAr" "WAR"))
+ :start 1
+ :end 2
+ :test #'string=
+ :key #'string-upcase)
+ #("war" "peace" "WAr" "WAR"))
+(equalp (nsubstitute "peace" "WAR" (copy-seq #("war" "War" "WAr" "WAR"))
+ :start 1
+ :end 2
+ :test-not (complement #'string=)
+ :key #'string-upcase)
+ #("war" "peace" "WAr" "WAR"))
+(equalp (nsubstitute "peace" "WAR" (copy-seq #("war" "War" "WAr" "WAR"))
+ :start 1
+ :end nil
+ :test #'string=
+ :key #'string-upcase)
+ #("war" "peace" "peace" "peace"))
+(equalp (nsubstitute "peace" "WAR" (copy-seq #("war" "War" "WAr" "WAR"))
+ :start 1
+ :end nil
+ :test-not (complement #'string=)
+ :key #'string-upcase)
+ #("war" "peace" "peace" "peace"))
+(equalp (nsubstitute "peace" "war" (copy-seq #("war" "War" "WAr" "WAR"))
+ :test #'string=
+ :key #'string-upcase)
+ #("war" "War" "WAr" "WAR"))
+(equalp (nsubstitute "peace" "war" (copy-seq #("war" "War" "WAr" "WAR"))
+ :test-not (complement #'string=)
+ :key #'string-upcase)
+ #("war" "War" "WAr" "WAR"))
+(equalp (nsubstitute "peace" "WAR"
+ (copy-seq
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+ :start 1
+ :end 7
+ :count 1
+ :test-not (complement #'string=)
+ :key #'string-upcase)
+ #("war" "peace" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+(equalp (nsubstitute "peace" "WAR"
+ (copy-seq
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+ :start 1
+ :end 7
+ :count 2
+ :test-not (complement #'string=)
+ :key #'string-upcase)
+ #("war" "peace" "peace" "WAR" "war" "War" "WAr" "WAR"))
+(equalp (nsubstitute "peace" "WAR"
+ (copy-seq
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+ :start 1
+ :end 7
+ :count 2
+ :from-end t
+ :test-not (complement #'string=)
+ :key #'string-upcase)
+ #("war" "War" "WAr" "WAR" "war" "peace" "peace" "WAR"))
+(equalp (nsubstitute "peace" "WAR"
+ (copy-seq
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+ :start 1
+ :end 7
+ :count 0
+ :from-end t
+ :test-not (complement #'string=)
+ :key #'string-upcase)
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+(equalp (nsubstitute "peace" "WAR"
+ (copy-seq
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+ :start 1
+ :end 7
+ :count -2
+ :from-end t
+ :test-not (complement #'string=)
+ :key #'string-upcase)
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+(equalp (nsubstitute "peace" "WAR"
+ (copy-seq
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+ :start 1
+ :end 7
+ :count nil
+ :from-end t
+ :test-not (complement #'string=)
+ :key #'string-upcase)
+ #("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR"))
+(equalp (nsubstitute "peace" "WAR"
+ (copy-seq
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+ :start 1
+ :end 7
+ :count 6
+ :from-end t
+ :test-not (complement #'string=)
+ :key #'string-upcase)
+ #("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR"))
+(equalp (nsubstitute "peace" "WAR"
+ (copy-seq
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+ :start 1
+ :end 7
+ :count 7
+ :from-end t
+ :test-not (complement #'string=)
+ :key #'string-upcase)
+ #("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR"))
+(equalp (nsubstitute "peace" "WAR"
+ (copy-seq
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+ :start 1
+ :end 7
+ :count 100
+ :from-end t
+ :test-not (complement #'string=)
+ :key #'string-upcase)
+ #("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR"))
+(string= (nsubstitute #\A #\a (copy-seq "abcabc")) "AbcAbc")
+(string= (nsubstitute #\A #\a (copy-seq "")) "")
+(string= (nsubstitute #\A #\a (copy-seq "xyz")) "xyz")
+(string= (nsubstitute #\A #\a (copy-seq "aaaaaaaaaa") :start 5 :end nil)
+ "aaaaaAAAAA")
+(string= (nsubstitute #\x #\5 (copy-seq "0123456789") :test #'char<)
+ "012345xxxx")
+(string= (nsubstitute #\x #\5 (copy-seq "0123456789") :test #'char>)
+ "xxxxx56789")
+(string= (nsubstitute #\x #\D (copy-seq "abcdefg")
+ :key #'char-upcase
+ :test #'char>)
+ "xxxdefg")
+(string= (nsubstitute #\x #\D (copy-seq "abcdefg")
+ :start 1
+ :end 2
+ :key #'char-upcase
+ :test #'char>)
+ "axcdefg")
+(string= (nsubstitute #\A #\a (copy-seq "aaaaaaaaaa") :count 2) "AAaaaaaaaa")
+(string= (nsubstitute #\A #\a (copy-seq "aaaaaaaaaa") :count -1) "aaaaaaaaaa")
+(string= (nsubstitute #\A #\a (copy-seq "aaaaaaaaaa") :count 0) "aaaaaaaaaa")
+(string= (nsubstitute #\A #\a (copy-seq "aaaaaaaaaa") :count nil) "AAAAAAAAAA")
+(string= (nsubstitute #\A #\a (copy-seq "aaaaaaaaaa") :count 100) "AAAAAAAAAA")
+(string= (nsubstitute #\A #\a (copy-seq "aaaaaaaaaa") :count 9) "AAAAAAAAAa")
+(string= (nsubstitute #\A #\a (copy-seq "aaaaaaaaaa") :count 9 :from-end t)
+ "aAAAAAAAAA")
+(string= (nsubstitute #\A #\a (copy-seq "aaaaaaaaaa")
+ :start 2
+ :end 8
+ :count 3)
+ "aaAAAaaaaa")
+(string= (nsubstitute #\A #\a (copy-seq "aaaaaaaaaa")
+ :start 2
+ :end 8
+ :from-end t
+ :count 3)
+ "aaaaaAAAaa")
+(string= (nsubstitute #\x #\A (copy-seq "aaaaaaaaaa")
+ :start 2
+ :end 8
+ :from-end t
+ :count 3)
+ "aaaaaaaaaa")
+(string= (nsubstitute #\X #\A (copy-seq "aaaaaaaaaa")
+ :start 2
+ :end 8
+ :from-end t
+ :key #'char-upcase
+ :count 3)
+ "aaaaaXXXaa")
+(string= (nsubstitute #\X #\D (copy-seq "abcdefghij")
+ :start 2
+ :end 8
+ :from-end t
+ :key #'char-upcase
+ :test #'char<
+ :count 3)
+ "abcdeXXXij")
+(equalp (nsubstitute 0 1 (copy-seq #*1111)) #*0000)
+(equalp (nsubstitute 0 1 (copy-seq #*1111) :start 1 :end nil) #*1000)
+(equalp (nsubstitute 0 1 (copy-seq #*1111) :start 1 :end 3) #*1001)
+(equalp (nsubstitute 0 1 (copy-seq #*11111111) :start 1 :end 7) #*10000001)
+(equalp (nsubstitute 0 1 (copy-seq #*11111111) :start 1 :end 7 :count 3)
+ #*10001111)
+(equalp (nsubstitute 0 1 (copy-seq #*11111111)
+ :start 1 :end 7 :count 3 :from-end t)
+ #*11110001)
+(equalp (nsubstitute 1 1 (copy-seq #*10101010)
+ :start 1 :end 7 :count 3 :from-end t
+ :key #'(lambda (x) (if (zerop x) 1 0)))
+ #*11111110)
+(equalp (nsubstitute 1 1 (copy-seq #*10101010)
+ :start 1 :end 7 :count 3 :from-end t
+ :key #'(lambda (x) (if (zerop x) 1 0))
+ :test #'>=)
+ #*10101110)
+
+
+
+(equal (nsubstitute-if 'a #'(lambda (arg) (eq arg 'x)) (copy-seq '(x y z)))
+ '(a y z))
+(equal (nsubstitute-if 'b #'(lambda (arg) (eq arg 'y)) (copy-seq '(x y z)))
+ '(x b z))
+(equal (nsubstitute-if 'c #'(lambda (arg) (eq arg 'z)) (copy-seq '(x y z)))
+ '(x y c))
+(equal (nsubstitute-if 'a #'(lambda (arg) (eq arg 'p)) (copy-seq '(x y z)))
+ '(x y z))
+(equal (nsubstitute-if 'a #'(lambda (arg) (eq arg 'x)) (copy-seq '()))
+ '())
+(equal (nsubstitute-if #\x #'(lambda (arg) (char< #\b arg))
+ (copy-seq '(#\a #\b #\c #\d #\e)))
+ '(#\a #\b #\x #\x #\x))
+(equal (nsubstitute-if '(a) #'(lambda (arg) (eq arg 'x))
+ (copy-seq '((x) (y) (z))) :key #'car)
+ '((a) (y) (z)))
+(equal (nsubstitute-if 'c #'(lambda (arg) (eq arg 'b))
+ (copy-seq '(a b a b a b a b))) '(a c a c a c a c))
+(equal (nsubstitute-if 'a #'(lambda (arg) (eq arg 'b))
+ (copy-seq '(b b b))) '(a a a))
+(equal (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x))
+ (copy-seq '(a x b x c x d x e x f)))
+ '(a z b z c z d z e z f))
+(equal (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x))
+ (copy-seq '(a x b x c x d x e x f)) :count nil)
+ '(a z b z c z d z e z f))
+(equal (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x))
+ (copy-seq '(a x b x c x d x e x f)) :count 0)
+ '(a x b x c x d x e x f))
+(equal (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x))
+ (copy-seq '(a x b x c x d x e x f)) :count -100)
+ '(a x b x c x d x e x f))
+(equal (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x))
+ (copy-seq '(a x b x c x d x e x f)) :count 1)
+ '(a z b x c x d x e x f))
+(equal (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x))
+ (copy-seq '(a x b x c x d x e x f)) :count 2)
+ '(a z b z c x d x e x f))
+(equal (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x))
+ (copy-seq '(a x b x c x d x e x f)) :count 3)
+ '(a z b z c z d x e x f))
+(equal (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x))
+ (copy-seq '(a x b x c x d x e x f)) :count 4)
+ '(a z b z c z d z e x f))
+(equal (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x))
+ (copy-seq '(a x b x c x d x e x f)) :count 5)
+ '(a z b z c z d z e z f))
+(equal (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x))
+ (copy-seq '(a x b x c x d x e x f)) :count 6)
+ '(a z b z c z d z e z f))
+(equal (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x))
+ (copy-seq '(a x b x c x d x e x f)) :count 7)
+ '(a z b z c z d z e z f))
+(equal (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x))
+ (copy-seq '(a x b x c x d x e x f))
+ :count nil :from-end t)
+ '(a z b z c z d z e z f))
+(equal (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x))
+ (copy-seq '(a x b x c x d x e x f)) :count 0 :from-end t)
+ '(a x b x c x d x e x f))
+(equal (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x))
+ (copy-seq '(a x b x c x d x e x f))
+ :count -100 :from-end t)
+ '(a x b x c x d x e x f))
+(equal (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x))
+ (copy-seq '(a x b x c x d x e x f))
+ :count 1 :from-end t)
+ '(a x b x c x d x e z f))
+(equal (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x))
+ (copy-seq '(a x b x c x d x e x f))
+ :count 2 :from-end t)
+ '(a x b x c x d z e z f))
+(equal (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x))
+ (copy-seq '(a x b x c x d x e x f))
+ :count 3 :from-end t)
+ '(a x b x c z d z e z f))
+(equal (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x))
+ (copy-seq '(a x b x c x d x e x f))
+ :count 4 :from-end t)
+ '(a x b z c z d z e z f))
+(equal (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x))
+ (copy-seq '(a x b x c x d x e x f))
+ :count 5 :from-end t)
+ '(a z b z c z d z e z f))
+(equal (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x))
+ (copy-seq '(a x b x c x d x e x f))
+ :count 6 :from-end t)
+ '(a z b z c z d z e z f))
+(equal (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x))
+ (copy-seq '(a x b x c x d x e x f))
+ :count 7 :from-end t)
+ '(a z b z c z d z e z f))
+(equal (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x))
+ (copy-seq '(a x b x c x d x e x f)) :start 2 :count 1)
+ '(a x b z c x d x e x f))
+(equal (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x))
+ (copy-seq '(a x b x c x d x e x f))
+ :start 2 :end nil :count 1)
+ '(a x b z c x d x e x f))
+(equal (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x))
+ (copy-seq '(a x b x c x d x e x f))
+ :start 2 :end 6 :count 100)
+ '(a x b z c z d x e x f))
+(equal (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x))
+ (copy-seq '(a x b x c x d x e x f))
+ :start 2 :end 11 :count 100)
+ '(a x b z c z d z e z f))
+(equal (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x))
+ (copy-seq '(a x b x c x d x e x f))
+ :start 2 :end 8 :count 10)
+ '(a x b z c z d z e x f))
+(equal (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x))
+ (copy-seq '(a x b x c x d x e x f))
+ :start 2 :end 8 :count 2 :from-end t)
+ '(a x b x c z d z e x f))
+(equal (nsubstitute-if #\z #'(lambda (arg) (char< #\c arg))
+ (copy-seq '(#\a #\b #\c #\d #\e #\f)))
+ '(#\a #\b #\c #\z #\z #\z))
+(equal (nsubstitute-if "peace" #'(lambda (arg) (equal "war" arg))
+ (copy-seq '("love" "hate" "war" "peace")))
+ '("love" "hate" "peace" "peace"))
+(equal (nsubstitute-if "peace" #'(lambda (arg) (string-equal "war" arg))
+ (copy-seq '("war" "War" "WAr" "WAR")))
+ '("peace" "peace" "peace" "peace"))
+(equal (nsubstitute-if "peace" #'(lambda (arg) (string= "WAR" arg))
+ (copy-seq '("war" "War" "WAr" "WAR"))
+ :key #'string-upcase)
+ '("peace" "peace" "peace" "peace"))
+(equal (nsubstitute-if "peace" #'(lambda (arg) (string= "WAR" arg))
+ (copy-seq '("war" "War" "WAr" "WAR"))
+ :start 1
+ :end 2
+ :key #'string-upcase)
+ '("war" "peace" "WAr" "WAR"))
+(equal (nsubstitute-if "peace" #'(lambda (arg) (string= "WAR" arg))
+ (copy-seq '("war" "War" "WAr" "WAR"))
+ :start 1
+ :end nil
+ :key #'string-upcase)
+ '("war" "peace" "peace" "peace"))
+(equal (nsubstitute-if "peace" #'(lambda (arg) (string= "war" arg))
+ (copy-seq '("war" "War" "WAr" "WAR"))
+ :key #'string-upcase)
+ '("war" "War" "WAr" "WAR"))
+(equal (nsubstitute-if "peace" #'(lambda (arg) (string= "WAR" arg))
+ (copy-seq
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+ :start 1
+ :end 7
+ :count 1
+ :key #'string-upcase)
+ '("war" "peace" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+(equal (nsubstitute-if "peace" #'(lambda (arg) (string= "WAR" arg))
+ (copy-seq
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+ :start 1
+ :end 7
+ :count 2
+ :key #'string-upcase)
+ '("war" "peace" "peace" "WAR" "war" "War" "WAr" "WAR"))
+(equal (nsubstitute-if "peace" #'(lambda (arg) (string= "WAR" arg))
+ (copy-seq
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+ :start 1
+ :end 7
+ :count 2
+ :from-end t
+ :key #'string-upcase)
+ '("war" "War" "WAr" "WAR" "war" "peace" "peace" "WAR"))
+(equal (nsubstitute-if "peace" #'(lambda (arg) (string= "WAR" arg))
+ (copy-seq
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+ :start 1
+ :end 7
+ :count 0
+ :from-end t
+ :key #'string-upcase)
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+(equal (nsubstitute-if "peace" #'(lambda (arg) (string= "WAR" arg))
+ (copy-seq
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+ :start 1
+ :end 7
+ :count -2
+ :from-end t
+ :key #'string-upcase)
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+(equal (nsubstitute-if "peace" #'(lambda (arg) (string= "WAR" arg))
+ (copy-seq
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+ :start 1
+ :end 7
+ :count nil
+ :from-end t
+ :key #'string-upcase)
+ '("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR"))
+(equal (nsubstitute-if "peace" #'(lambda (arg) (string= "WAR" arg))
+ (copy-seq
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+ :start 1
+ :end 7
+ :count 6
+ :from-end t
+ :key #'string-upcase)
+ '("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR"))
+(equal (nsubstitute-if "peace" #'(lambda (arg) (string= "WAR" arg))
+ (copy-seq
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+ :start 1
+ :end 7
+ :count 7
+ :from-end t
+ :key #'string-upcase)
+ '("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR"))
+(equal (nsubstitute-if "peace" #'(lambda (arg) (string= "WAR" arg))
+ (copy-seq
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+ :start 1
+ :end 7
+ :count 100
+ :from-end t
+ :key #'string-upcase)
+ '("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR"))
+
+
+(equalp (nsubstitute-if 'a #'(lambda (arg) (eq arg 'x)) (copy-seq #(x y z)))
+ #(a y z))
+(equalp (nsubstitute-if 'b #'(lambda (arg) (eq arg 'y)) (copy-seq #(x y z)))
+ #(x b z))
+(equalp (nsubstitute-if 'c #'(lambda (arg) (eq arg 'z)) (copy-seq #(x y z)))
+ #(x y c))
+(equalp (nsubstitute-if 'a #'(lambda (arg) (eq arg 'p)) (copy-seq #(x y z)))
+ #(x y z))
+(equalp (nsubstitute-if 'a #'(lambda (arg) (eq arg 'x)) (copy-seq #())) #())
+(equalp (nsubstitute-if #\x #'(lambda (arg) (char< #\b arg))
+ (copy-seq #(#\a #\b #\c #\d #\e)))
+ #(#\a #\b #\x #\x #\x))
+(equalp (nsubstitute-if '(a) #'(lambda (arg) (eq arg 'x))
+ (copy-seq #((x) (y) (z))) :key #'car)
+ #((a) (y) (z)))
+(equalp (nsubstitute-if 'c #'(lambda (arg) (eq arg 'b))
+ (copy-seq #(a b a b a b a b))) #(a c a c a c a c))
+(equalp (nsubstitute-if 'a #'(lambda (arg) (eq arg 'b))
+ (copy-seq #(b b b))) #(a a a))
+(equalp (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x))
+ (copy-seq #(a x b x c x d x e x f)))
+ #(a z b z c z d z e z f))
+(equalp (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x))
+ (copy-seq #(a x b x c x d x e x f)) :count nil)
+ #(a z b z c z d z e z f))
+(equalp (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x))
+ (copy-seq #(a x b x c x d x e x f)) :count 0)
+ #(a x b x c x d x e x f))
+(equalp (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x))
+ (copy-seq #(a x b x c x d x e x f)) :count -100)
+ #(a x b x c x d x e x f))
+(equalp (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x))
+ (copy-seq #(a x b x c x d x e x f)) :count 1)
+ #(a z b x c x d x e x f))
+(equalp (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x))
+ (copy-seq #(a x b x c x d x e x f)) :count 2)
+ #(a z b z c x d x e x f))
+(equalp (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x))
+ (copy-seq #(a x b x c x d x e x f)) :count 3)
+ #(a z b z c z d x e x f))
+(equalp (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x))
+ (copy-seq #(a x b x c x d x e x f)) :count 4)
+ #(a z b z c z d z e x f))
+(equalp (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x))
+ (copy-seq #(a x b x c x d x e x f)) :count 5)
+ #(a z b z c z d z e z f))
+(equalp (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x))
+ (copy-seq #(a x b x c x d x e x f)) :count 6)
+ #(a z b z c z d z e z f))
+(equalp (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x))
+ (copy-seq #(a x b x c x d x e x f)) :count 7)
+ #(a z b z c z d z e z f))
+(equalp (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x))
+ (copy-seq #(a x b x c x d x e x f))
+ :count nil :from-end t)
+ #(a z b z c z d z e z f))
+(equalp (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x))
+ (copy-seq #(a x b x c x d x e x f))
+ :count 0 :from-end t)
+ #(a x b x c x d x e x f))
+(equalp (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x))
+ (copy-seq #(a x b x c x d x e x f))
+ :count -100 :from-end t)
+ #(a x b x c x d x e x f))
+(equalp (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x))
+ (copy-seq #(a x b x c x d x e x f))
+ :count 1 :from-end t)
+ #(a x b x c x d x e z f))
+(equalp (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x))
+ (copy-seq #(a x b x c x d x e x f))
+ :count 2 :from-end t)
+ #(a x b x c x d z e z f))
+(equalp (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x))
+ (copy-seq #(a x b x c x d x e x f))
+ :count 3 :from-end t)
+ #(a x b x c z d z e z f))
+(equalp (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x))
+ (copy-seq #(a x b x c x d x e x f))
+ :count 4 :from-end t)
+ #(a x b z c z d z e z f))
+(equalp (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x))
+ (copy-seq #(a x b x c x d x e x f))
+ :count 5 :from-end t)
+ #(a z b z c z d z e z f))
+(equalp (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x))
+ (copy-seq #(a x b x c x d x e x f))
+ :count 6 :from-end t)
+ #(a z b z c z d z e z f))
+(equalp (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x))
+ (copy-seq #(a x b x c x d x e x f))
+ :count 7 :from-end t)
+ #(a z b z c z d z e z f))
+(equalp (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x))
+ (copy-seq #(a x b x c x d x e x f))
+ :start 2 :count 1)
+ #(a x b z c x d x e x f))
+(equalp (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x))
+ (copy-seq #(a x b x c x d x e x f))
+ :start 2 :end nil :count 1)
+ #(a x b z c x d x e x f))
+(equalp (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x))
+ (copy-seq #(a x b x c x d x e x f))
+ :start 2 :end 6 :count 100)
+ #(a x b z c z d x e x f))
+(equalp (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x))
+ (copy-seq #(a x b x c x d x e x f))
+ :start 2 :end 11 :count 100)
+ #(a x b z c z d z e z f))
+(equalp (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x))
+ (copy-seq #(a x b x c x d x e x f))
+ :start 2 :end 8 :count 10)
+ #(a x b z c z d z e x f))
+(equalp (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x))
+ (copy-seq #(a x b x c x d x e x f))
+ :start 2 :end 8 :count 2 :from-end t)
+ #(a x b x c z d z e x f))
+(equalp (nsubstitute-if #\z #'(lambda (arg) (char< #\c arg))
+ (copy-seq #(#\a #\b #\c #\d #\e #\f)))
+ #(#\a #\b #\c #\z #\z #\z))
+(equalp (nsubstitute-if "peace" #'(lambda (arg) (equal "war" arg))
+ (copy-seq #("love" "hate" "war" "peace")))
+ #("love" "hate" "peace" "peace"))
+(equalp (nsubstitute-if "peace" #'(lambda (arg) (string-equal "war" arg))
+ (copy-seq #("war" "War" "WAr" "WAR")))
+ #("peace" "peace" "peace" "peace"))
+(equalp (nsubstitute-if "peace" #'(lambda (arg) (string= "WAR" arg))
+ (copy-seq #("war" "War" "WAr" "WAR"))
+ :key #'string-upcase)
+ #("peace" "peace" "peace" "peace"))
+(equalp (nsubstitute-if "peace" #'(lambda (arg) (string= "WAR" arg))
+ (copy-seq #("war" "War" "WAr" "WAR"))
+ :start 1
+ :end 2
+ :key #'string-upcase)
+ #("war" "peace" "WAr" "WAR"))
+(equalp (nsubstitute-if "peace" #'(lambda (arg) (string= "WAR" arg))
+ (copy-seq #("war" "War" "WAr" "WAR"))
+ :start 1
+ :end nil
+ :key #'string-upcase)
+ #("war" "peace" "peace" "peace"))
+(equalp (nsubstitute-if "peace" #'(lambda (arg) (string= "war" arg))
+ (copy-seq #("war" "War" "WAr" "WAR"))
+ :key #'string-upcase)
+ #("war" "War" "WAr" "WAR"))
+(equalp (nsubstitute-if "peace" #'(lambda (arg) (string= "WAR" arg))
+ (copy-seq
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+ :start 1
+ :end 7
+ :count 1
+ :key #'string-upcase)
+ #("war" "peace" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+(equalp (nsubstitute-if "peace" #'(lambda (arg) (string= "WAR" arg))
+ (copy-seq
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+ :start 1
+ :end 7
+ :count 2
+ :key #'string-upcase)
+ #("war" "peace" "peace" "WAR" "war" "War" "WAr" "WAR"))
+(equalp (nsubstitute-if "peace" #'(lambda (arg) (string= "WAR" arg))
+ (copy-seq
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+ :start 1
+ :end 7
+ :count 2
+ :from-end t
+ :key #'string-upcase)
+ #("war" "War" "WAr" "WAR" "war" "peace" "peace" "WAR"))
+(equalp (nsubstitute-if "peace" #'(lambda (arg) (string= "WAR" arg))
+ (copy-seq
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+ :start 1
+ :end 7
+ :count 0
+ :from-end t
+ :key #'string-upcase)
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+(equalp (nsubstitute-if "peace" #'(lambda (arg) (string= "WAR" arg))
+ (copy-seq
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+ :start 1
+ :end 7
+ :count -2
+ :from-end t
+ :key #'string-upcase)
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+(equalp (nsubstitute-if "peace" #'(lambda (arg) (string= "WAR" arg))
+ (copy-seq
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+ :start 1
+ :end 7
+ :count nil
+ :from-end t
+ :key #'string-upcase)
+ #("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR"))
+(equalp (nsubstitute-if "peace" #'(lambda (arg) (string= "WAR" arg))
+ (copy-seq
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+ :start 1
+ :end 7
+ :count 6
+ :from-end t
+ :key #'string-upcase)
+ #("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR"))
+(equalp (nsubstitute-if "peace" #'(lambda (arg) (string= "WAR" arg))
+ (copy-seq
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+ :start 1
+ :end 7
+ :count 7
+ :from-end t
+ :key #'string-upcase)
+ #("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR"))
+(equalp (nsubstitute-if "peace" #'(lambda (arg) (string= "WAR" arg))
+ (copy-seq
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+ :start 1
+ :end 7
+ :count 100
+ :from-end t
+ :key #'string-upcase)
+ #("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR"))
+
+(string= (nsubstitute-if #\A #'(lambda (arg) (eql #\a arg))
+ (copy-seq "abcabc")) "AbcAbc")
+(string= (nsubstitute-if #\A #'(lambda (arg) (eql #\a arg)) (copy-seq "")) "")
+(string= (nsubstitute-if #\A #'(lambda (arg) (eql #\a arg)) (copy-seq "xyz"))
+ "xyz")
+(string= (nsubstitute-if #\A #'(lambda (arg) (eql #\a arg))
+ (copy-seq "aaaaaaaaaa") :start 5 :end nil)
+ "aaaaaAAAAA")
+(string= (nsubstitute-if #\x #'(lambda (arg) (char< #\5 arg))
+ (copy-seq "0123456789")) "012345xxxx")
+(string= (nsubstitute-if #\x #'(lambda (arg) (char> #\5 arg))
+ (copy-seq "0123456789")) "xxxxx56789")
+(string= (nsubstitute-if #\x #'(lambda (arg) (char> #\D arg))
+ (copy-seq "abcdefg")
+ :key #'char-upcase)
+ "xxxdefg")
+(string= (nsubstitute-if #\x #'(lambda (arg) (char> #\D arg))
+ (copy-seq "abcdefg")
+ :start 1
+ :end 2
+ :key #'char-upcase)
+ "axcdefg")
+(string= (nsubstitute-if #\A #'(lambda (arg) (eql #\a arg))
+ (copy-seq "aaaaaaaaaa") :count 2) "AAaaaaaaaa")
+(string= (nsubstitute-if #\A #'(lambda (arg) (eql #\a arg))
+ (copy-seq "aaaaaaaaaa") :count -1) "aaaaaaaaaa")
+(string= (nsubstitute-if #\A #'(lambda (arg) (eql #\a arg))
+ (copy-seq "aaaaaaaaaa") :count 0) "aaaaaaaaaa")
+(string= (nsubstitute-if #\A #'(lambda (arg) (eql #\a arg))
+ (copy-seq "aaaaaaaaaa") :count nil) "AAAAAAAAAA")
+(string= (nsubstitute-if #\A #'(lambda (arg) (eql #\a arg))
+ (copy-seq "aaaaaaaaaa") :count 100) "AAAAAAAAAA")
+(string= (nsubstitute-if #\A #'(lambda (arg) (eql #\a arg))
+ (copy-seq "aaaaaaaaaa") :count 9) "AAAAAAAAAa")
+(string= (nsubstitute-if #\A #'(lambda (arg) (eql #\a arg))
+ (copy-seq "aaaaaaaaaa") :count 9 :from-end t)
+ "aAAAAAAAAA")
+(string= (nsubstitute-if #\A #'(lambda (arg) (eql #\a arg))
+ (copy-seq "aaaaaaaaaa")
+ :start 2
+ :end 8
+ :count 3)
+ "aaAAAaaaaa")
+(string= (nsubstitute-if #\A #'(lambda (arg) (eql #\a arg))
+ (copy-seq "aaaaaaaaaa")
+ :start 2
+ :end 8
+ :from-end t
+ :count 3)
+ "aaaaaAAAaa")
+(string= (nsubstitute-if #\x #'(lambda (arg) (eql #\A arg))
+ (copy-seq "aaaaaaaaaa")
+ :start 2
+ :end 8
+ :from-end t
+ :count 3)
+ "aaaaaaaaaa")
+(string= (nsubstitute-if #\X #'(lambda (arg) (eql #\A arg))
+ (copy-seq "aaaaaaaaaa")
+ :start 2
+ :end 8
+ :from-end t
+ :key #'char-upcase
+ :count 3)
+ "aaaaaXXXaa")
+(string= (nsubstitute-if #\X #'(lambda (arg) (char< #\D arg))
+ (copy-seq "abcdefghij")
+ :start 2
+ :end 8
+ :from-end t
+ :key #'char-upcase
+ :count 3)
+ "abcdeXXXij")
+(equalp (nsubstitute-if 0 #'(lambda (arg) (= 1 arg)) (copy-seq #*1111)) #*0000)
+(equalp (nsubstitute-if 0 #'(lambda (arg) (= 1 arg))
+ (copy-seq #*1111) :start 1 :end nil) #*1000)
+(equalp (nsubstitute-if 0 #'(lambda (arg) (= 1 arg))
+ (copy-seq #*1111) :start 1 :end 3) #*1001)
+(equalp (nsubstitute-if 0 #'(lambda (arg) (= 1 arg))
+ (copy-seq #*11111111) :start 1 :end 7) #*10000001)
+(equalp (nsubstitute-if 0 #'(lambda (arg) (= 1 arg))
+ (copy-seq #*11111111) :start 1 :end 7 :count 3)
+ #*10001111)
+(equalp (nsubstitute-if 0 #'(lambda (arg) (= 1 arg))
+ (copy-seq #*11111111)
+ :start 1 :end 7 :count 3 :from-end t)
+ #*11110001)
+(equalp (nsubstitute-if 1 #'(lambda (arg) (= 1 arg))
+ (copy-seq #*10101010)
+ :start 1 :end 7 :count 3 :from-end t
+ :key #'(lambda (x) (if (zerop x) 1 0)))
+ #*11111110)
+(equalp (nsubstitute-if 1 #'(lambda (arg) (>= 1 arg))
+ (copy-seq #*10101010)
+ :start 1 :end 7 :count 3 :from-end t
+ :key #'(lambda (x) (if (zerop x) 1 0)))
+ #*10101110)
+
+
+(equal (nsubstitute-if-not 'a #'(lambda (arg) (not (eq arg 'x)))
+ (copy-seq '(x y z)))
+ '(a y z))
+(equal (nsubstitute-if-not 'b #'(lambda (arg) (not (eq arg 'y)))
+ (copy-seq '(x y z)))
+ '(x b z))
+(equal (nsubstitute-if-not 'c #'(lambda (arg) (not (eq arg 'z)))
+ (copy-seq '(x y z)))
+ '(x y c))
+(equal (nsubstitute-if-not 'a #'(lambda (arg) (not (eq arg 'p)))
+ (copy-seq '(x y z)))
+ '(x y z))
+(equal (nsubstitute-if-not 'a #'(lambda (arg) (not (eq arg 'x)))
+ (copy-seq '())) '())
+(equal (nsubstitute-if-not #\x #'(lambda (arg) (not (char< #\b arg)))
+ (copy-seq '(#\a #\b #\c #\d #\e)))
+ '(#\a #\b #\x #\x #\x))
+(equal (nsubstitute-if-not '(a) #'(lambda (arg) (not (eq arg 'x)))
+ (copy-seq '((x) (y) (z))) :key #'car)
+ '((a) (y) (z)))
+(equal (nsubstitute-if-not 'c #'(lambda (arg) (not (eq arg 'b)))
+ (copy-seq '(a b a b a b a b))) '(a c a c a c a c))
+(equal (nsubstitute-if-not 'a #'(lambda (arg) (not (eq arg 'b)))
+ (copy-seq '(b b b))) '(a a a))
+(equal (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ (copy-seq '(a x b x c x d x e x f)))
+ '(a z b z c z d z e z f))
+(equal (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ (copy-seq '(a x b x c x d x e x f)) :count nil)
+ '(a z b z c z d z e z f))
+(equal (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ (copy-seq '(a x b x c x d x e x f)) :count 0)
+ '(a x b x c x d x e x f))
+(equal (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ (copy-seq '(a x b x c x d x e x f)) :count -100)
+ '(a x b x c x d x e x f))
+(equal (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ (copy-seq '(a x b x c x d x e x f)) :count 1)
+ '(a z b x c x d x e x f))
+(equal (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ (copy-seq '(a x b x c x d x e x f)) :count 2)
+ '(a z b z c x d x e x f))
+(equal (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ (copy-seq '(a x b x c x d x e x f)) :count 3)
+ '(a z b z c z d x e x f))
+(equal (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ (copy-seq '(a x b x c x d x e x f)) :count 4)
+ '(a z b z c z d z e x f))
+(equal (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ (copy-seq '(a x b x c x d x e x f)) :count 5)
+ '(a z b z c z d z e z f))
+(equal (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ (copy-seq '(a x b x c x d x e x f)) :count 6)
+ '(a z b z c z d z e z f))
+(equal (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ (copy-seq '(a x b x c x d x e x f)) :count 7)
+ '(a z b z c z d z e z f))
+(equal (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ (copy-seq '(a x b x c x d x e x f))
+ :count nil :from-end t)
+ '(a z b z c z d z e z f))
+(equal (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ (copy-seq '(a x b x c x d x e x f))
+ :count 0 :from-end t)
+ '(a x b x c x d x e x f))
+(equal (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ (copy-seq '(a x b x c x d x e x f))
+ :count -100 :from-end t)
+ '(a x b x c x d x e x f))
+(equal (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ (copy-seq '(a x b x c x d x e x f))
+ :count 1 :from-end t)
+ '(a x b x c x d x e z f))
+(equal (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ (copy-seq '(a x b x c x d x e x f))
+ :count 2 :from-end t)
+ '(a x b x c x d z e z f))
+(equal (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ (copy-seq '(a x b x c x d x e x f))
+ :count 3 :from-end t)
+ '(a x b x c z d z e z f))
+(equal (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ (copy-seq '(a x b x c x d x e x f))
+ :count 4 :from-end t)
+ '(a x b z c z d z e z f))
+(equal (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ (copy-seq '(a x b x c x d x e x f))
+ :count 5 :from-end t)
+ '(a z b z c z d z e z f))
+(equal (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ (copy-seq '(a x b x c x d x e x f))
+ :count 6 :from-end t)
+ '(a z b z c z d z e z f))
+(equal (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ (copy-seq '(a x b x c x d x e x f))
+ :count 7 :from-end t)
+ '(a z b z c z d z e z f))
+(equal (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ (copy-seq '(a x b x c x d x e x f))
+ :start 2 :count 1)
+ '(a x b z c x d x e x f))
+(equal (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ (copy-seq '(a x b x c x d x e x f))
+ :start 2 :end nil :count 1)
+ '(a x b z c x d x e x f))
+(equal (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ (copy-seq '(a x b x c x d x e x f))
+ :start 2 :end 6 :count 100)
+ '(a x b z c z d x e x f))
+(equal (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ (copy-seq '(a x b x c x d x e x f))
+ :start 2 :end 11 :count 100)
+ '(a x b z c z d z e z f))
+(equal (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ (copy-seq '(a x b x c x d x e x f))
+ :start 2 :end 8 :count 10)
+ '(a x b z c z d z e x f))
+(equal (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ (copy-seq '(a x b x c x d x e x f))
+ :start 2 :end 8 :count 2 :from-end t)
+ '(a x b x c z d z e x f))
+(equal (nsubstitute-if-not #\z #'(lambda (arg) (not (char< #\c arg)))
+ (copy-seq '(#\a #\b #\c #\d #\e #\f)))
+ '(#\a #\b #\c #\z #\z #\z))
+(equal (nsubstitute-if-not "peace" #'(lambda (arg) (not (equal "war" arg)))
+ (copy-seq '("love" "hate" "war" "peace")))
+ '("love" "hate" "peace" "peace"))
+(equal (nsubstitute-if-not "peace"
+ #'(lambda (arg) (not (string-equal "war" arg)))
+ (copy-seq '("war" "War" "WAr" "WAR")))
+ '("peace" "peace" "peace" "peace"))
+(equal (nsubstitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg)))
+ (copy-seq '("war" "War" "WAr" "WAR"))
+ :key #'string-upcase)
+ '("peace" "peace" "peace" "peace"))
+(equal (nsubstitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg)))
+ (copy-seq '("war" "War" "WAr" "WAR"))
+ :start 1
+ :end 2
+ :key #'string-upcase)
+ '("war" "peace" "WAr" "WAR"))
+(equal (nsubstitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg)))
+ (copy-seq '("war" "War" "WAr" "WAR"))
+ :start 1
+ :end nil
+ :key #'string-upcase)
+ '("war" "peace" "peace" "peace"))
+(equal (nsubstitute-if-not "peace" #'(lambda (arg) (not (string= "war" arg)))
+ (copy-seq '("war" "War" "WAr" "WAR"))
+ :key #'string-upcase)
+ '("war" "War" "WAr" "WAR"))
+(equal (nsubstitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg)))
+ (copy-seq
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+ :start 1
+ :end 7
+ :count 1
+ :key #'string-upcase)
+ '("war" "peace" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+(equal (nsubstitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg)))
+ (copy-seq
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+ :start 1
+ :end 7
+ :count 2
+ :key #'string-upcase)
+ '("war" "peace" "peace" "WAR" "war" "War" "WAr" "WAR"))
+(equal (nsubstitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg)))
+ (copy-seq
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+ :start 1
+ :end 7
+ :count 2
+ :from-end t
+ :key #'string-upcase)
+ '("war" "War" "WAr" "WAR" "war" "peace" "peace" "WAR"))
+(equal (nsubstitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg)))
+ (copy-seq
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+ :start 1
+ :end 7
+ :count 0
+ :from-end t
+ :key #'string-upcase)
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+(equal (nsubstitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg)))
+ (copy-seq
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+ :start 1
+ :end 7
+ :count -2
+ :from-end t
+ :key #'string-upcase)
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+(equal (nsubstitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg)))
+ (copy-seq
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+ :start 1
+ :end 7
+ :count nil
+ :from-end t
+ :key #'string-upcase)
+ '("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR"))
+(equal (nsubstitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg)))
+ (copy-seq
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+ :start 1
+ :end 7
+ :count 6
+ :from-end t
+ :key #'string-upcase)
+ '("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR"))
+(equal (nsubstitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg)))
+ (copy-seq
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+ :start 1
+ :end 7
+ :count 7
+ :from-end t
+ :key #'string-upcase)
+ '("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR"))
+(equal (nsubstitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg)))
+ (copy-seq
+ '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+ :start 1
+ :end 7
+ :count 100
+ :from-end t
+ :key #'string-upcase)
+ '("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR"))
+
+
+(equalp (nsubstitute-if-not 'a #'(lambda (arg) (not (eq arg 'x)))
+ (copy-seq #(x y z))) #(a y z))
+(equalp (nsubstitute-if-not 'b #'(lambda (arg) (not (eq arg 'y)))
+ (copy-seq #(x y z))) #(x b z))
+(equalp (nsubstitute-if-not 'c #'(lambda (arg) (not (eq arg 'z)))
+ (copy-seq #(x y z))) #(x y c))
+(equalp (nsubstitute-if-not 'a #'(lambda (arg) (not (eq arg 'p)))
+ (copy-seq #(x y z))) #(x y z))
+(equalp (nsubstitute-if-not 'a #'(lambda (arg) (not (eq arg 'x)))
+ (copy-seq #())) #())
+(equalp (nsubstitute-if-not #\x #'(lambda (arg) (not (char< #\b arg)))
+ (copy-seq #(#\a #\b #\c #\d #\e)))
+ #(#\a #\b #\x #\x #\x))
+(equalp (nsubstitute-if-not '(a) #'(lambda (arg) (not (eq arg 'x)))
+ (copy-seq #((x) (y) (z))) :key #'car)
+ #((a) (y) (z)))
+(equalp (nsubstitute-if-not 'c #'(lambda (arg) (not (eq arg 'b)))
+ (copy-seq #(a b a b a b a b))) #(a c a c a c a c))
+(equalp (nsubstitute-if-not 'a #'(lambda (arg) (not (eq arg 'b)))
+ (copy-seq #(b b b))) #(a a a))
+(equalp (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ (copy-seq #(a x b x c x d x e x f)))
+ #(a z b z c z d z e z f))
+(equalp (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ (copy-seq #(a x b x c x d x e x f)) :count nil)
+ #(a z b z c z d z e z f))
+(equalp (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ (copy-seq #(a x b x c x d x e x f)) :count 0)
+ #(a x b x c x d x e x f))
+(equalp (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ (copy-seq #(a x b x c x d x e x f)) :count -100)
+ #(a x b x c x d x e x f))
+(equalp (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ (copy-seq #(a x b x c x d x e x f)) :count 1)
+ #(a z b x c x d x e x f))
+(equalp (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ (copy-seq #(a x b x c x d x e x f)) :count 2)
+ #(a z b z c x d x e x f))
+(equalp (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ (copy-seq #(a x b x c x d x e x f)) :count 3)
+ #(a z b z c z d x e x f))
+(equalp (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ (copy-seq #(a x b x c x d x e x f)) :count 4)
+ #(a z b z c z d z e x f))
+(equalp (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ (copy-seq #(a x b x c x d x e x f)) :count 5)
+ #(a z b z c z d z e z f))
+(equalp (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ (copy-seq #(a x b x c x d x e x f)) :count 6)
+ #(a z b z c z d z e z f))
+(equalp (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ (copy-seq #(a x b x c x d x e x f)) :count 7)
+ #(a z b z c z d z e z f))
+(equalp (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ (copy-seq #(a x b x c x d x e x f))
+ :count nil :from-end t)
+ #(a z b z c z d z e z f))
+(equalp (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ (copy-seq #(a x b x c x d x e x f))
+ :count 0 :from-end t)
+ #(a x b x c x d x e x f))
+(equalp (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ (copy-seq #(a x b x c x d x e x f))
+ :count -100 :from-end t)
+ #(a x b x c x d x e x f))
+(equalp (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ (copy-seq #(a x b x c x d x e x f))
+ :count 1 :from-end t)
+ #(a x b x c x d x e z f))
+(equalp (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ (copy-seq #(a x b x c x d x e x f))
+ :count 2 :from-end t)
+ #(a x b x c x d z e z f))
+(equalp (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ (copy-seq #(a x b x c x d x e x f))
+ :count 3 :from-end t)
+ #(a x b x c z d z e z f))
+(equalp (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ (copy-seq #(a x b x c x d x e x f))
+ :count 4 :from-end t)
+ #(a x b z c z d z e z f))
+(equalp (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ (copy-seq #(a x b x c x d x e x f))
+ :count 5 :from-end t)
+ #(a z b z c z d z e z f))
+(equalp (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ (copy-seq #(a x b x c x d x e x f))
+ :count 6 :from-end t)
+ #(a z b z c z d z e z f))
+(equalp (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ (copy-seq #(a x b x c x d x e x f))
+ :count 7 :from-end t)
+ #(a z b z c z d z e z f))
+(equalp (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ (copy-seq #(a x b x c x d x e x f))
+ :start 2 :count 1)
+ #(a x b z c x d x e x f))
+(equalp (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ (copy-seq #(a x b x c x d x e x f))
+ :start 2 :end nil :count 1)
+ #(a x b z c x d x e x f))
+(equalp (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ (copy-seq #(a x b x c x d x e x f))
+ :start 2 :end 6 :count 100)
+ #(a x b z c z d x e x f))
+(equalp (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ (copy-seq #(a x b x c x d x e x f))
+ :start 2 :end 11 :count 100)
+ #(a x b z c z d z e z f))
+(equalp (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ (copy-seq #(a x b x c x d x e x f))
+ :start 2 :end 8 :count 10)
+ #(a x b z c z d z e x f))
+(equalp (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x)))
+ (copy-seq #(a x b x c x d x e x f))
+ :start 2 :end 8 :count 2 :from-end t)
+ #(a x b x c z d z e x f))
+(equalp (nsubstitute-if-not #\z #'(lambda (arg) (not (char< #\c arg)))
+ (copy-seq #(#\a #\b #\c #\d #\e #\f)))
+ #(#\a #\b #\c #\z #\z #\z))
+(equalp (nsubstitute-if-not "peace" #'(lambda (arg) (not (equal "war" arg)))
+ (copy-seq #("love" "hate" "war" "peace")))
+ #("love" "hate" "peace" "peace"))
+(equalp (nsubstitute-if-not "peace"
+ #'(lambda (arg) (not (string-equal "war" arg)))
+ (copy-seq #("war" "War" "WAr" "WAR")))
+ #("peace" "peace" "peace" "peace"))
+(equalp (nsubstitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg)))
+ (copy-seq #("war" "War" "WAr" "WAR"))
+ :key #'string-upcase)
+ #("peace" "peace" "peace" "peace"))
+(equalp (nsubstitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg)))
+ (copy-seq #("war" "War" "WAr" "WAR"))
+ :start 1
+ :end 2
+ :key #'string-upcase)
+ #("war" "peace" "WAr" "WAR"))
+(equalp (nsubstitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg)))
+ (copy-seq #("war" "War" "WAr" "WAR"))
+ :start 1
+ :end nil
+ :key #'string-upcase)
+ #("war" "peace" "peace" "peace"))
+(equalp (nsubstitute-if-not "peace" #'(lambda (arg) (not (string= "war" arg)))
+ (copy-seq #("war" "War" "WAr" "WAR"))
+ :key #'string-upcase)
+ #("war" "War" "WAr" "WAR"))
+(equalp (nsubstitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg)))
+ (copy-seq
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+ :start 1
+ :end 7
+ :count 1
+ :key #'string-upcase)
+ #("war" "peace" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+(equalp (nsubstitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg)))
+ (copy-seq
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+ :start 1
+ :end 7
+ :count 2
+ :key #'string-upcase)
+ #("war" "peace" "peace" "WAR" "war" "War" "WAr" "WAR"))
+(equalp (nsubstitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg)))
+ (copy-seq
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+ :start 1
+ :end 7
+ :count 2
+ :from-end t
+ :key #'string-upcase)
+ #("war" "War" "WAr" "WAR" "war" "peace" "peace" "WAR"))
+(equalp (nsubstitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg)))
+ (copy-seq
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+ :start 1
+ :end 7
+ :count 0
+ :from-end t
+ :key #'string-upcase)
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+(equalp (nsubstitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg)))
+ (copy-seq
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+ :start 1
+ :end 7
+ :count -2
+ :from-end t
+ :key #'string-upcase)
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+(equalp (nsubstitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg)))
+ (copy-seq
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+ :start 1
+ :end 7
+ :count nil
+ :from-end t
+ :key #'string-upcase)
+ #("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR"))
+(equalp (nsubstitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg)))
+ (copy-seq
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+ :start 1
+ :end 7
+ :count 6
+ :from-end t
+ :key #'string-upcase)
+ #("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR"))
+(equalp (nsubstitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg)))
+ (copy-seq
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+ :start 1
+ :end 7
+ :count 7
+ :from-end t
+ :key #'string-upcase)
+ #("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR"))
+(equalp (nsubstitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg)))
+ (copy-seq
+ #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR"))
+ :start 1
+ :end 7
+ :count 100
+ :from-end t
+ :key #'string-upcase)
+ #("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR"))
+
+(string= (nsubstitute-if-not #\A #'(lambda (arg) (not (eql #\a arg)))
+ (copy-seq "abcabc"))
+ "AbcAbc")
+(string= (nsubstitute-if-not #\A #'(lambda (arg) (not (eql #\a arg)))
+ (copy-seq "")) "")
+(string= (nsubstitute-if-not #\A #'(lambda (arg) (not (eql #\a arg)))
+ (copy-seq "xyz"))
+ "xyz")
+(string= (nsubstitute-if-not #\A #'(lambda (arg) (not (eql #\a arg)))
+ (copy-seq "aaaaaaaaaa") :start 5 :end nil)
+ "aaaaaAAAAA")
+(string= (nsubstitute-if-not #\x #'(lambda (arg) (not (char< #\5 arg)))
+ (copy-seq "0123456789")) "012345xxxx")
+(string= (nsubstitute-if-not #\x #'(lambda (arg) (not (char> #\5 arg)))
+ (copy-seq "0123456789")) "xxxxx56789")
+(string= (nsubstitute-if-not #\x #'(lambda (arg) (not (char> #\D arg)))
+ (copy-seq "abcdefg")
+ :key #'char-upcase)
+ "xxxdefg")
+(string= (nsubstitute-if-not #\x #'(lambda (arg) (not (char> #\D arg)))
+ (copy-seq "abcdefg")
+ :start 1
+ :end 2
+ :key #'char-upcase)
+ "axcdefg")
+(string= (nsubstitute-if-not #\A #'(lambda (arg) (not (eql #\a arg)))
+ (copy-seq "aaaaaaaaaa") :count 2) "AAaaaaaaaa")
+(string= (nsubstitute-if-not #\A #'(lambda (arg) (not (eql #\a arg)))
+ (copy-seq "aaaaaaaaaa") :count -1) "aaaaaaaaaa")
+(string= (nsubstitute-if-not #\A #'(lambda (arg) (not (eql #\a arg)))
+ (copy-seq "aaaaaaaaaa") :count 0) "aaaaaaaaaa")
+(string= (nsubstitute-if-not #\A #'(lambda (arg) (not (eql #\a arg)))
+ (copy-seq "aaaaaaaaaa") :count nil) "AAAAAAAAAA")
+(string= (nsubstitute-if-not #\A #'(lambda (arg) (not (eql #\a arg)))
+ (copy-seq "aaaaaaaaaa") :count 100) "AAAAAAAAAA")
+(string= (nsubstitute-if-not #\A #'(lambda (arg) (not (eql #\a arg)))
+ (copy-seq "aaaaaaaaaa") :count 9) "AAAAAAAAAa")
+(string= (nsubstitute-if-not #\A #'(lambda (arg) (not (eql #\a arg)))
+ (copy-seq "aaaaaaaaaa") :count 9 :from-end t)
+ "aAAAAAAAAA")
+(string= (nsubstitute-if-not #\A #'(lambda (arg) (not (eql #\a arg)))
+ (copy-seq "aaaaaaaaaa")
+ :start 2
+ :end 8
+ :count 3)
+ "aaAAAaaaaa")
+(string= (nsubstitute-if-not #\A #'(lambda (arg) (not (eql #\a arg)))
+ (copy-seq "aaaaaaaaaa")
+ :start 2
+ :end 8
+ :from-end t
+ :count 3)
+ "aaaaaAAAaa")
+(string= (nsubstitute-if-not #\x #'(lambda (arg) (not (eql #\A arg)))
+ (copy-seq "aaaaaaaaaa")
+ :start 2
+ :end 8
+ :from-end t
+ :count 3)
+ "aaaaaaaaaa")
+(string= (nsubstitute-if-not #\X #'(lambda (arg) (not (eql #\A arg)))
+ (copy-seq "aaaaaaaaaa")
+ :start 2
+ :end 8
+ :from-end t
+ :key #'char-upcase
+ :count 3)
+ "aaaaaXXXaa")
+(string= (nsubstitute-if-not #\X #'(lambda (arg) (not (char< #\D arg)))
+ (copy-seq "abcdefghij")
+ :start 2
+ :end 8
+ :from-end t
+ :key #'char-upcase
+ :count 3)
+ "abcdeXXXij")
+(equalp (nsubstitute-if-not 0 #'(lambda (arg) (not (= 1 arg)))
+ (copy-seq #*1111)) #*0000)
+(equalp (nsubstitute-if-not 0 #'(lambda (arg) (not (= 1 arg)))
+ (copy-seq #*1111) :start 1 :end nil) #*1000)
+(equalp (nsubstitute-if-not 0 #'(lambda (arg) (not (= 1 arg)))
+ (copy-seq #*1111) :start 1 :end 3) #*1001)
+(equalp (nsubstitute-if-not 0 #'(lambda (arg) (not (= 1 arg)))
+ (copy-seq #*11111111) :start 1 :end 7) #*10000001)
+(equalp (nsubstitute-if-not 0 #'(lambda (arg) (not (= 1 arg)))
+ (copy-seq #*11111111) :start 1 :end 7 :count 3)
+ #*10001111)
+(equalp (nsubstitute-if-not 0 #'(lambda (arg) (not (= 1 arg)))
+ (copy-seq #*11111111)
+ :start 1 :end 7 :count 3 :from-end t)
+ #*11110001)
+(equalp (nsubstitute-if-not 1 #'(lambda (arg) (not (= 1 arg)))
+ (copy-seq #*10101010)
+ :start 1 :end 7 :count 3 :from-end t
+ :key #'(lambda (x) (if (zerop x) 1 0)))
+ #*11111110)
+(equalp (nsubstitute-if-not 1 #'(lambda (arg) (not (>= 1 arg)))
+ (copy-seq #*10101010)
+ :start 1 :end 7 :count 3 :from-end t
+ :key #'(lambda (x) (if (zerop x) 1 0)))
+ #*10101110)
+
+
+(string= (concatenate 'string "all" " " "together" " " "now")
+ "all together now")
+(equal (concatenate 'list "ABC" '(d e f) #(1 2 3) #*1011)
+ '(#\A #\B #\C D E F 1 2 3 1 0 1 1))
+(null (concatenate 'list))
+(HANDLER-CASE (PROGN (CONCATENATE 'SYMBOL))
+ (ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (CONCATENATE 'CLASS))
+ (ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+
+(equal (concatenate 'list '() '(a b c) '(x y z)) '(a b c x y z))
+(equal (concatenate 'list '(a) #(b) '(c) #(x y) '(z)) '(a b c x y z))
+(equal (concatenate 'list '(a b c) #(d e f) "ghi" #*0101)
+ '(a b c d e f #\g #\h #\i 0 1 0 1))
+(null (concatenate 'list))
+(let* ((list0 '(a b c))
+ (list (concatenate 'list list0)))
+ (and (not (eq list0 list))
+ (equal list list0)
+ (equal list '(a b c))))
+(null (concatenate 'list '() #() "" #*))
+(equal (concatenate 'list #(a b c) '() '() '(x y z) #() #() #* #(j k l))
+ '(a b c x y z j k l))
+
+(equalp (concatenate 'vector '() '(a b c) '(x y z)) #(a b c x y z))
+(equalp (concatenate 'vector '(a) #(b) '(c) #(x y) '(z)) #(a b c x y z))
+(equalp (concatenate 'vector '(a b c) #(d e f) "ghi" #*0101)
+ #(a b c d e f #\g #\h #\i 0 1 0 1))
+(equalp (concatenate 'vector) #())
+(let* ((vector0 #(a b c))
+ (vector (concatenate 'vector vector0)))
+ (and (not (eq vector0 vector))
+ (equalp vector vector0)
+ (equalp vector #(a b c))))
+(equalp (concatenate 'vector '() #() "" #*) #())
+(equalp (concatenate 'vector #(a b c) '() '() '(x y z) #() #() #* #(j k l))
+ #(a b c x y z j k l))
+
+(string= (concatenate 'string "abc" "def" "ghi" "jkl" "mno" "pqr")
+ "abcdefghijklmnopqr")
+(string= (concatenate
+ 'string
+ "" "abc" "" "def" "" "ghi" "" "" "jkl" "" "mno" "" "pqr" "" "")
+ "abcdefghijklmnopqr")
+(string= (concatenate 'string) "")
+(string= (concatenate 'string "" '() #* #()) "")
+(string= (concatenate 'string "abc" '(#\d #\e #\f #\g) #(#\h #\i #\j #\k #\l))
+ "abcdefghijkl")
+(equal (concatenate 'bit-vector #*0101 #*1010) #*01011010)
+(equal (concatenate 'bit-vector #*0101 #*1010 #* #*11 #*1 #*1)
+ #*010110101111)
+(equal (concatenate 'bit-vector '(0 1 0 1) '(0 1 0 1) #(0 1 0 1) #*0101)
+ #*0101010101010101)
+(equal (concatenate 'bit-vector) #*)
+(equal (concatenate 'bit-vector #*) #*)
+(equal (concatenate 'bit-vector #* '() #()) #*)
+
+
+
+(let ((test1 (list 1 3 4 6 7))
+ (test2 (list 2 5 8)))
+ (equal (merge 'list test1 test2 #'<) '(1 2 3 4 5 6 7 8)))
+(let ((test1 (copy-seq "BOY"))
+ (test2 (copy-seq "nosy")))
+ (equal (merge 'string test1 test2 #'char-lessp) "BnOosYy"))
+(let ((test1 (vector '(red . 1) '(blue . 4)))
+ (test2 (vector '(yellow . 2) '(green . 7))))
+ (equalp (merge 'vector test1 test2 #'< :key #'cdr)
+ #((RED . 1) (YELLOW . 2) (BLUE . 4) (GREEN . 7))))
+
+
+(equal (merge 'list (list 1 3 5 7 9) (list 0 2 4 6 8) #'<)
+ '(0 1 2 3 4 5 6 7 8 9))
+(equal (merge 'cons (list 1 3 5 7 9) (list 0 2 4 6 8) #'<)
+ '(0 1 2 3 4 5 6 7 8 9))
+(equal (merge 'list (list 0 1 2) nil #'<) '(0 1 2))
+(equal (merge 'list nil (list 0 1 2) #'<) '(0 1 2))
+(equal (merge 'list nil nil #'<) nil)
+(equal (merge 'list
+ (list '(1 1) '(2 1) '(3 1))
+ (list '(1 2) '(2 2) '(3 2)) #'< :key #'car)
+ '((1 1) (1 2) (2 1) (2 2) (3 1) (3 2)))
+(equal (merge 'list
+ (list '(1 1) '(2 1) '(2 1 1) '(3 1))
+ (list '(1 2) '(2 2) '(3 2)) #'< :key #'car)
+ '((1 1) (1 2) (2 1) (2 1 1) (2 2) (3 1) (3 2)))
+(equal (merge 'list
+ (list '(1 1) '(2 1) '(2 1 1) '(3 1))
+ (list '(1 2) '(2 2) '(3 2) '(3 2 2)) #'< :key #'car)
+ '((1 1) (1 2) (2 1) (2 1 1) (2 2) (3 1) (3 2) (3 2 2)))
+(equal (merge 'list (list 3 1 9 5 7) (list 8 6 0 2 4) #'<)
+ '(3 1 8 6 0 2 4 9 5 7))
+
+
+(equal (merge 'list (vector 1 3 5 7 9) (list 0 2 4 6 8) #'<)
+ '(0 1 2 3 4 5 6 7 8 9))
+(equal (merge 'cons (vector 1 3 5 7 9) (list 0 2 4 6 8) #'<)
+ '(0 1 2 3 4 5 6 7 8 9))
+(equal (merge 'list (vector 0 1 2) nil #'<) '(0 1 2))
+(equal (merge 'list #() (list 0 1 2) #'<) '(0 1 2))
+(equal (merge 'list #() #() #'<) nil)
+(equal (merge 'list
+ (vector '(1 1) '(2 1) '(3 1))
+ (list '(1 2) '(2 2) '(3 2)) #'< :key #'car)
+ '((1 1) (1 2) (2 1) (2 2) (3 1) (3 2)))
+(equal (merge 'list
+ (vector '(1 1) '(2 1) '(2 1 1) '(3 1))
+ (list '(1 2) '(2 2) '(3 2)) #'< :key #'car)
+ '((1 1) (1 2) (2 1) (2 1 1) (2 2) (3 1) (3 2)))
+(equal (merge 'list
+ (vector '(1 1) '(2 1) '(2 1 1) '(3 1))
+ (list '(1 2) '(2 2) '(3 2) '(3 2 2)) #'< :key #'car)
+ '((1 1) (1 2) (2 1) (2 1 1) (2 2) (3 1) (3 2) (3 2 2)))
+(equal (merge 'list (vector 3 1 9 5 7) (list 8 6 0 2 4) #'<)
+ '(3 1 8 6 0 2 4 9 5 7))
+
+
+(equal (merge 'list (list 1 3 5 7 9) (vector 0 2 4 6 8) #'<)
+ '(0 1 2 3 4 5 6 7 8 9))
+(equal (merge 'cons (list 1 3 5 7 9) (vector 0 2 4 6 8) #'<)
+ '(0 1 2 3 4 5 6 7 8 9))
+(equal (merge 'list (list 0 1 2) #() #'<) '(0 1 2))
+(equal (merge 'list nil (vector 0 1 2) #'<) '(0 1 2))
+(equal (merge 'list nil #() #'<) nil)
+(equal (merge 'list
+ (list '(1 1) '(2 1) '(3 1))
+ (vector '(1 2) '(2 2) '(3 2)) #'< :key #'car)
+ '((1 1) (1 2) (2 1) (2 2) (3 1) (3 2)))
+(equal (merge 'list
+ (list '(1 1) '(2 1) '(2 1 1) '(3 1))
+ (vector '(1 2) '(2 2) '(3 2)) #'< :key #'car)
+ '((1 1) (1 2) (2 1) (2 1 1) (2 2) (3 1) (3 2)))
+(equal (merge 'list
+ (list '(1 1) '(2 1) '(2 1 1) '(3 1))
+ (vector '(1 2) '(2 2) '(3 2) '(3 2 2)) #'< :key #'car)
+ '((1 1) (1 2) (2 1) (2 1 1) (2 2) (3 1) (3 2) (3 2 2)))
+(equal (merge 'list (list 3 1 9 5 7) (vector 8 6 0 2 4) #'<)
+ '(3 1 8 6 0 2 4 9 5 7))
+
+
+(equal (merge 'list (vector 1 3 5 7 9) (vector 0 2 4 6 8) #'<)
+ '(0 1 2 3 4 5 6 7 8 9))
+(equal (merge 'cons (vector 1 3 5 7 9) (vector 0 2 4 6 8) #'<)
+ '(0 1 2 3 4 5 6 7 8 9))
+(equal (merge 'list (vector 0 1 2) #() #'<) '(0 1 2))
+(equal (merge 'list #() (vector 0 1 2) #'<) '(0 1 2))
+(equal (merge 'list #() #() #'<) nil)
+(equal (merge 'list
+ (vector '(1 1) '(2 1) '(3 1))
+ (vector '(1 2) '(2 2) '(3 2)) #'< :key #'car)
+ '((1 1) (1 2) (2 1) (2 2) (3 1) (3 2)))
+(equal (merge 'list
+ (vector '(1 1) '(2 1) '(2 1 1) '(3 1))
+ (vector '(1 2) '(2 2) '(3 2)) #'< :key #'car)
+ '((1 1) (1 2) (2 1) (2 1 1) (2 2) (3 1) (3 2)))
+(equal (merge 'list
+ (vector '(1 1) '(2 1) '(2 1 1) '(3 1))
+ (vector '(1 2) '(2 2) '(3 2) '(3 2 2)) #'< :key #'car)
+ '((1 1) (1 2) (2 1) (2 1 1) (2 2) (3 1) (3 2) (3 2 2)))
+(equal (merge 'list (vector 3 1 9 5 7) (vector 8 6 0 2 4) #'<)
+ '(3 1 8 6 0 2 4 9 5 7))
+
+
+(equalp (merge 'vector (list 1 3 5 7 9) (list 0 2 4 6 8) #'<)
+ #(0 1 2 3 4 5 6 7 8 9))
+(equalp (merge 'vector (list 1 3 5 7 9) (list 0 2 4 6 8) #'<)
+ #(0 1 2 3 4 5 6 7 8 9))
+(equalp (merge 'vector (list 0 1 2) nil #'<) #(0 1 2))
+(equalp (merge 'vector nil (list 0 1 2) #'<) #(0 1 2))
+(equalp (merge 'vector nil nil #'<) #())
+(equalp (merge 'vector
+ (list '(1 1) '(2 1) '(3 1))
+ (list '(1 2) '(2 2) '(3 2)) #'< :key #'car)
+ #((1 1) (1 2) (2 1) (2 2) (3 1) (3 2)))
+(equalp (merge 'vector
+ (list '(1 1) '(2 1) '(2 1 1) '(3 1))
+ (list '(1 2) '(2 2) '(3 2)) #'< :key #'car)
+ #((1 1) (1 2) (2 1) (2 1 1) (2 2) (3 1) (3 2)))
+(equalp (merge 'vector
+ (list '(1 1) '(2 1) '(2 1 1) '(3 1))
+ (list '(1 2) '(2 2) '(3 2) '(3 2 2)) #'< :key #'car)
+ #((1 1) (1 2) (2 1) (2 1 1) (2 2) (3 1) (3 2) (3 2 2)))
+(equalp (merge 'vector (list 3 1 9 5 7) (list 8 6 0 2 4) #'<)
+ #(3 1 8 6 0 2 4 9 5 7))
+
+
+(equalp (merge 'vector (vector 1 3 5 7 9) (list 0 2 4 6 8) #'<)
+ #(0 1 2 3 4 5 6 7 8 9))
+(equalp (merge 'vector (vector 1 3 5 7 9) (list 0 2 4 6 8) #'<)
+ #(0 1 2 3 4 5 6 7 8 9))
+(equalp (merge 'vector (vector 0 1 2) nil #'<) #(0 1 2))
+(equalp (merge 'vector #() (list 0 1 2) #'<) #(0 1 2))
+(equalp (merge 'vector #() #() #'<) #())
+(equalp (merge 'vector
+ (vector '(1 1) '(2 1) '(3 1))
+ (list '(1 2) '(2 2) '(3 2)) #'< :key #'car)
+ #((1 1) (1 2) (2 1) (2 2) (3 1) (3 2)))
+(equalp (merge 'vector
+ (vector '(1 1) '(2 1) '(2 1 1) '(3 1))
+ (list '(1 2) '(2 2) '(3 2)) #'< :key #'car)
+ #((1 1) (1 2) (2 1) (2 1 1) (2 2) (3 1) (3 2)))
+(equalp (merge 'vector
+ (vector '(1 1) '(2 1) '(2 1 1) '(3 1))
+ (list '(1 2) '(2 2) '(3 2) '(3 2 2)) #'< :key #'car)
+ #((1 1) (1 2) (2 1) (2 1 1) (2 2) (3 1) (3 2) (3 2 2)))
+(equalp (merge 'vector (vector 3 1 9 5 7) (list 8 6 0 2 4) #'<)
+ #(3 1 8 6 0 2 4 9 5 7))
+
+
+(equalp (merge 'vector (list 1 3 5 7 9) (vector 0 2 4 6 8) #'<)
+ #(0 1 2 3 4 5 6 7 8 9))
+(equalp (merge 'vector (list 1 3 5 7 9) (vector 0 2 4 6 8) #'<)
+ #(0 1 2 3 4 5 6 7 8 9))
+(equalp (merge 'vector (list 0 1 2) #() #'<) #(0 1 2))
+(equalp (merge 'vector nil (vector 0 1 2) #'<) #(0 1 2))
+(equalp (merge 'vector nil #() #'<) #())
+(equalp (merge 'vector
+ (list '(1 1) '(2 1) '(3 1))
+ (vector '(1 2) '(2 2) '(3 2)) #'< :key #'car)
+ #((1 1) (1 2) (2 1) (2 2) (3 1) (3 2)))
+(equalp (merge 'vector
+ (list '(1 1) '(2 1) '(2 1 1) '(3 1))
+ (vector '(1 2) '(2 2) '(3 2)) #'< :key #'car)
+ #((1 1) (1 2) (2 1) (2 1 1) (2 2) (3 1) (3 2)))
+(equalp (merge 'vector
+ (list '(1 1) '(2 1) '(2 1 1) '(3 1))
+ (vector '(1 2) '(2 2) '(3 2) '(3 2 2)) #'< :key #'car)
+ #((1 1) (1 2) (2 1) (2 1 1) (2 2) (3 1) (3 2) (3 2 2)))
+(equalp (merge 'vector (list 3 1 9 5 7) (vector 8 6 0 2 4) #'<)
+ #(3 1 8 6 0 2 4 9 5 7))
+
+
+(equalp (merge 'vector (vector 1 3 5 7 9) (vector 0 2 4 6 8) #'<)
+ #(0 1 2 3 4 5 6 7 8 9))
+(equalp (merge 'vector (vector 0 1 2) #() #'<) #(0 1 2))
+(equalp (merge 'vector #() (vector 0 1 2) #'<) #(0 1 2))
+(equalp (merge 'vector #() #() #'<) #())
+(equalp (merge 'vector
+ (vector '(1 1) '(2 1) '(3 1))
+ (vector '(1 2) '(2 2) '(3 2)) #'< :key #'car)
+ #((1 1) (1 2) (2 1) (2 2) (3 1) (3 2)))
+(equalp (merge 'vector
+ (vector '(1 1) '(2 1) '(2 1 1) '(3 1))
+ (vector '(1 2) '(2 2) '(3 2)) #'< :key #'car)
+ #((1 1) (1 2) (2 1) (2 1 1) (2 2) (3 1) (3 2)))
+(equalp (merge 'vector
+ (vector '(1 1) '(2 1) '(2 1 1) '(3 1))
+ (vector '(1 2) '(2 2) '(3 2) '(3 2 2)) #'< :key #'car)
+ #((1 1) (1 2) (2 1) (2 1 1) (2 2) (3 1) (3 2) (3 2 2)))
+(equalp (merge 'vector (vector 3 1 9 5 7) (vector 8 6 0 2 4) #'<)
+ #(3 1 8 6 0 2 4 9 5 7))
+
+
+(string= (merge 'string (list #\a #\c #\e) (list #\b #\d #\f) #'char<) "abcdef")
+(string= (merge 'string (list #\a #\b #\c) (list #\d #\e #\f) #'char<) "abcdef")
+(string= (merge 'string (list #\a #\b #\c) '() #'char<) "abc")
+(string= (merge 'string '() (list #\a #\b #\c) #'char<) "abc")
+(string= (merge 'string (list #\a #\b #\c) (copy-seq "") #'char<) "abc")
+(string= (merge 'string (list #\a #\b #\c) (copy-seq "BCD") #'char-lessp)
+ "abBcCD")
+(string= (merge 'string (list #\a #\b #\z) #(#\c #\x #\y) #'char<) "abcxyz")
+
+(equal (merge 'bit-vector (copy-seq #*0101) (copy-seq #*1010) #'<) #*01011010)
+(equal (merge 'bit-vector (copy-seq #*0101) (copy-seq #*) #'<) #*0101)
+(equal (merge 'bit-vector (copy-seq #*0101) '() #'<) #*0101)
+(equal (merge 'bit-vector nil (copy-seq #*0101) #'<) #*0101)
+(equal (merge 'bit-vector (copy-seq #*0101) (copy-seq #*0101) #'<) #*00101101)
+
+
+
+
+(equal (remove 4 '(1 3 4 5 9)) '(1 3 5 9))
+(equal (remove 4 '(1 2 4 1 3 4 5)) '(1 2 1 3 5))
+(equal (remove 4 '(1 2 4 1 3 4 5) :count 1) '(1 2 1 3 4 5))
+(equal (remove 4 '(1 2 4 1 3 4 5) :count 1 :from-end t) '(1 2 4 1 3 5))
+(equal (remove 3 '(1 2 4 1 3 4 5) :test #'>) '(4 3 4 5))
+(let* ((lst '(list of four elements))
+ (lst2 (copy-seq lst))
+ (lst3 (delete 'four lst)))
+ (and (equal lst3 '(LIST OF ELEMENTS))
+ (not (equal lst lst2))))
+(equal (remove-if #'oddp '(1 2 4 1 3 4 5)) '(2 4 4))
+(equal (remove-if #'evenp '(1 2 4 1 3 4 5) :count 1 :from-end t)
+ '(1 2 4 1 3 5))
+(equal (remove-if-not #'evenp '(1 2 3 4 5 6 7 8 9) :count 2 :from-end t)
+ '(1 2 3 4 5 6 8))
+(equal (delete 4 (list 1 2 4 1 3 4 5)) '(1 2 1 3 5))
+(equal (delete 4 (list 1 2 4 1 3 4 5) :count 1) '(1 2 1 3 4 5))
+(equal (delete 4 (list 1 2 4 1 3 4 5) :count 1 :from-end t) '(1 2 4 1 3 5))
+(equal (delete 3 (list 1 2 4 1 3 4 5) :test #'>) '(4 3 4 5))
+(equal (delete-if #'oddp (list 1 2 4 1 3 4 5)) '(2 4 4))
+(equal (delete-if #'evenp (list 1 2 4 1 3 4 5) :count 1 :from-end t)
+ '(1 2 4 1 3 5))
+(equal (delete-if #'evenp (list 1 2 3 4 5 6)) '(1 3 5))
+
+
+(let* ((list0 (list 0 1 2 3 4))
+ (list (remove 3 list0)))
+ (and (not (eq list0 list))
+ (equal list0 '(0 1 2 3 4))
+ (equal list '(0 1 2 4))))
+(equal (remove 'a (list 'a 'b 'c 'a 'b 'c)) '(b c b c))
+(equal (remove 'b (list 'a 'b 'c 'a 'b 'c)) '(a c a c))
+(equal (remove 'c (list 'a 'b 'c 'a 'b 'c)) '(a b a b))
+(equal (remove 'a (list 'a 'a 'a)) '())
+(equal (remove 'z (list 'a 'b 'c)) '(a b c))
+(equal (remove 'a '()) '())
+(equal (remove 'a (list 'a 'b 'c 'a 'b 'c) :count 0) '(a b c a b c))
+(equal (remove 'a (list 'a 'b 'c 'a 'b 'c) :count 1) '(b c a b c))
+(equal (remove 'a (list 'a 'b 'c 'a 'b 'c) :count 1 :from-end t) '(a b c b c))
+(equal (remove 'a (list 'a 'b 'c 'a 'b 'c) :count 2) '(b c b c))
+(equal (remove 'a (list 'a 'b 'c 'a 'b 'c) :count 2 :from-end t) '(b c b c))
+(equal (remove 'a (list 'a 'b 'c 'a 'b 'c) :count 3) '(b c b c))
+(equal (remove 'a (list 'a 'b 'c 'a 'b 'c) :count 3 :from-end t) '(b c b c))
+(equal (remove 'a (list 'a 'b 'c 'a 'b 'c) :count 4) '(b c b c))
+(equal (remove 'a (list 'a 'b 'c 'a 'b 'c) :count 4 :from-end t) '(b c b c))
+(equal (remove 'a (list 'a 'b 'c 'a 'b 'c) :count -1) '(a b c a b c))
+(equal (remove 'a (list 'a 'b 'c 'a 'b 'c) :count -10) '(a b c a b c))
+(equal (remove 'a (list 'a 'b 'c 'a 'b 'c) :count -100) '(a b c a b c))
+(equal (remove 'a (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1)
+ '(a b c b c b c b c))
+(equal (remove 'a (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :count 1)
+ '(a b c b c a b c a b c))
+(equal (remove 'a (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :count 2)
+ '(a b c b c b c a b c))
+(equal (remove 'a (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :end nil :count 2)
+ '(a b c b c b c a b c))
+(equal (remove 'a (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :end 8)
+ '(a b c b c b c a b c))
+(equal (remove 'a (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :end 8 :count 1)
+ '(a b c b c a b c a b c))
+(equal (remove 'a (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :end 8 :count 1 :from-end t)
+ '(a b c a b c b c a b c))
+(equal (remove 'a (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :end 8 :count 0 :from-end t)
+ '(a b c a b c a b c a b c))
+(equal (remove 'a (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :end 8 :count -100 :from-end t)
+ '(a b c a b c a b c a b c))
+(equal (remove 'a (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :end 1)
+ '(a b c a b c a b c a b c))
+(equal (remove 'a (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 2 :end 2)
+ '(a b c a b c a b c a b c))
+(equal (remove 'a (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 12 :end 12)
+ '(a b c a b c a b c a b c))
+(equal (remove 'a (list '(a) '(b) '(c) '(a) '(b) '(c)) :key #'car)
+ '((b) (c) (b) (c)))
+(equal (remove 'a (list '(a . b) '(b . c) '(c . a)
+ '(a . b) '(b . c) '(c . a))
+ :key #'cdr)
+ '((a . b) (b . c) (a . b) (b . c)))
+(equal (remove "love" (list '("Love") '("LOve") '("LOVe") '("LOVE")) :key #'car)
+ '(("Love") ("LOve") ("LOVe") ("LOVE")))
+(equal (remove "love" (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count -10)
+ '(("Love") ("LOve") ("LOVe") ("LOVE")))
+(equal (remove "love" (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test #'string-equal)
+ '())
+(equal (remove "love" (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test-not (complement #'string-equal))
+ '())
+(equal (remove "love" (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test #'string-equal :count 1)
+ '(("LOve") ("LOVe") ("LOVE")))
+(equal (remove "love" (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test-not (complement #'string-equal) :count 1)
+ '(("LOve") ("LOVe") ("LOVE")))
+(equal (remove "love" (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test #'string-equal :count 1 :from-end t)
+ '(("Love") ("LOve") ("LOVe")))
+(equal (remove "love" (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test-not (complement #'string-equal)
+ :count 1 :from-end t)
+ '(("Love") ("LOve") ("LOVe")))
+(equal (remove "love" (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test #'string-equal :count 2 :from-end t)
+ '(("Love") ("LOve")))
+(equal (remove "love" (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test-not (complement #'string-equal)
+ :count 2 :from-end t)
+ '(("Love") ("LOve")))
+(equal (remove "love" (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test #'string-equal :start 1 :end 3)
+ '(("Love") ("LOVE")))
+(equal (remove "love" (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test-not (complement #'string-equal) :start 1 :end 3)
+ '(("Love") ("LOVE")))
+(equal (remove "love" (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test #'string-equal :count 1 :start 1 :end 3)
+ '(("Love") ("LOVe") ("LOVE")))
+(equal (remove "love" (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test-not (complement #'string-equal)
+ :count 1 :start 1 :end 3)
+ '(("Love") ("LOVe") ("LOVE")))
+(equal (remove "love" (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test #'string-equal :count 1 :from-end t
+ :start 1 :end 3)
+ '(("Love") ("LOve") ("LOVE")))
+(equal (remove "love" (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test-not (complement #'string-equal)
+ :count 1 :from-end t :start 1 :end 3)
+ '(("Love") ("LOve") ("LOVE")))
+(equal (remove "love" (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test #'string-equal :count 10 :from-end t
+ :start 1 :end 3)
+ '(("Love") ("LOVE")))
+(equal (remove "love" (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test-not (complement #'string-equal)
+ :count 10 :from-end t :start 1 :end 3)
+ '(("Love") ("LOVE")))
+
+
+(let* ((vector0 (vector 0 1 2 3 4))
+ (vector (remove 3 vector0)))
+ (and (not (eq vector0 vector))
+ (equalp vector0 #(0 1 2 3 4))
+ (equalp vector #(0 1 2 4))))
+(equalp (remove 'a (vector 'a 'b 'c 'a 'b 'c)) #(b c b c))
+(equalp (remove 'b (vector 'a 'b 'c 'a 'b 'c)) #(a c a c))
+(equalp (remove 'c (vector 'a 'b 'c 'a 'b 'c)) #(a b a b))
+(equalp (remove 'a (vector 'a 'a 'a)) #())
+(equalp (remove 'z (vector 'a 'b 'c)) #(a b c))
+(equalp (remove 'a #()) #())
+(equalp (remove 'a (vector 'a 'b 'c 'a 'b 'c) :count 0) #(a b c a b c))
+(equalp (remove 'a (vector 'a 'b 'c 'a 'b 'c) :count 1) #(b c a b c))
+(equalp (remove 'a (vector 'a 'b 'c 'a 'b 'c) :count 1 :from-end t) #(a b c b c))
+(equalp (remove 'a (vector 'a 'b 'c 'a 'b 'c) :count 2) #(b c b c))
+(equalp (remove 'a (vector 'a 'b 'c 'a 'b 'c) :count 2 :from-end t) #(b c b c))
+(equalp (remove 'a (vector 'a 'b 'c 'a 'b 'c) :count 3) #(b c b c))
+(equalp (remove 'a (vector 'a 'b 'c 'a 'b 'c) :count 3 :from-end t) #(b c b c))
+(equalp (remove 'a (vector 'a 'b 'c 'a 'b 'c) :count 4) #(b c b c))
+(equalp (remove 'a (vector 'a 'b 'c 'a 'b 'c) :count 4 :from-end t) #(b c b c))
+(equalp (remove 'a (vector 'a 'b 'c 'a 'b 'c) :count -1) #(a b c a b c))
+(equalp (remove 'a (vector 'a 'b 'c 'a 'b 'c) :count -10) #(a b c a b c))
+(equalp (remove 'a (vector 'a 'b 'c 'a 'b 'c) :count -100) #(a b c a b c))
+(equalp (remove 'a (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1)
+ #(a b c b c b c b c))
+(equalp (remove 'a (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :count 1)
+ #(a b c b c a b c a b c))
+(equalp (remove 'a (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :count 2)
+ #(a b c b c b c a b c))
+(equalp (remove 'a (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :end nil :count 2)
+ #(a b c b c b c a b c))
+(equalp (remove 'a (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :end 8)
+ #(a b c b c b c a b c))
+(equalp (remove 'a (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :end 8 :count 1)
+ #(a b c b c a b c a b c))
+(equalp (remove 'a (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :end 8 :count 1 :from-end t)
+ #(a b c a b c b c a b c))
+(equalp (remove 'a (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :end 8 :count 0 :from-end t)
+ #(a b c a b c a b c a b c))
+(equalp (remove 'a (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :end 8 :count -100 :from-end t)
+ #(a b c a b c a b c a b c))
+(equalp (remove 'a (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :end 1)
+ #(a b c a b c a b c a b c))
+(equalp (remove 'a (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 2 :end 2)
+ #(a b c a b c a b c a b c))
+(equalp (remove 'a (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 12 :end 12)
+ #(a b c a b c a b c a b c))
+(equalp (remove 'a (vector '(a) '(b) '(c) '(a) '(b) '(c)) :key #'car)
+ #((b) (c) (b) (c)))
+(equalp (remove 'a (vector '(a . b) '(b . c) '(c . a)
+ '(a . b) '(b . c) '(c . a))
+ :key #'cdr)
+ #((a . b) (b . c) (a . b) (b . c)))
+(equalp (remove "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car)
+ #(("Love") ("LOve") ("LOVe") ("LOVE")))
+(equalp (remove "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count -10)
+ #(("Love") ("LOve") ("LOVe") ("LOVE")))
+(equalp (remove "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test #'string-equal)
+ #())
+(equalp (remove "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test-not (complement #'string-equal))
+ #())
+(equalp (remove "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test #'string-equal :count 1)
+ #(("LOve") ("LOVe") ("LOVE")))
+(equalp (remove "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test-not (complement #'string-equal) :count 1)
+ #(("LOve") ("LOVe") ("LOVE")))
+(equalp (remove "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test #'string-equal :count 1 :from-end t)
+ #(("Love") ("LOve") ("LOVe")))
+(equalp (remove "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test-not (complement #'string-equal)
+ :count 1 :from-end t)
+ #(("Love") ("LOve") ("LOVe")))
+(equalp (remove "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test #'string-equal :count 2 :from-end t)
+ #(("Love") ("LOve")))
+(equalp (remove "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test-not (complement #'string-equal)
+ :count 2 :from-end t)
+ #(("Love") ("LOve")))
+(equalp (remove "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test #'string-equal :start 1 :end 3)
+ #(("Love") ("LOVE")))
+(equalp (remove "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test-not (complement #'string-equal) :start 1 :end 3)
+ #(("Love") ("LOVE")))
+(equalp (remove "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test #'string-equal :count 1 :start 1 :end 3)
+ #(("Love") ("LOVe") ("LOVE")))
+(equalp (remove "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test-not (complement #'string-equal)
+ :count 1 :start 1 :end 3)
+ #(("Love") ("LOVe") ("LOVE")))
+(equalp (remove "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test #'string-equal :count 1 :from-end t
+ :start 1 :end 3)
+ #(("Love") ("LOve") ("LOVE")))
+(equalp (remove "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test-not (complement #'string-equal)
+ :count 1 :from-end t :start 1 :end 3)
+ #(("Love") ("LOve") ("LOVE")))
+(equalp (remove "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test #'string-equal :count 10 :from-end t
+ :start 1 :end 3)
+ #(("Love") ("LOVE")))
+(equalp (remove "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test-not (complement #'string-equal)
+ :count 10 :from-end t :start 1 :end 3)
+ #(("Love") ("LOVE")))
+
+(string= (remove #\a (copy-seq "abcabc")) "bcbc")
+(string= (remove #\a (copy-seq "")) "")
+(string= (remove #\a (copy-seq "xyz")) "xyz")
+(string= (remove #\a (copy-seq "ABCABC")) "ABCABC")
+(string= (remove #\a (copy-seq "ABCABC") :key #'char-downcase) "BCBC")
+(string= (remove #\a (copy-seq "abcabc") :count 1) "bcabc")
+(string= (remove #\a (copy-seq "abcabc") :count 1 :from-end t) "abcbc")
+(string= (remove #\a (copy-seq "abcabc") :count 0) "abcabc")
+(string= (remove #\a (copy-seq "abcabc") :count -10) "abcabc")
+(let* ((str0 (copy-seq "abc"))
+ (str (remove #\a str0)))
+ (and (not (eq str0 str))
+ (string= str0 "abc")
+ (string= str "bc")))
+(string= (remove #\a (copy-seq "abcabc") :count 0) "abcabc")
+(string= (remove #\a (copy-seq "abcabc")) "bcbc")
+(string= (remove #\b (copy-seq "abcabc")) "acac")
+(string= (remove #\c (copy-seq "abcabc")) "abab")
+(string= (remove #\a (copy-seq "abcabc") :count 0) "abcabc")
+(string= (remove #\a (copy-seq "abcabc") :count 1) "bcabc")
+(string= (remove #\a (copy-seq "abcabc") :count 1 :from-end t) "abcbc")
+(string= (remove #\a (copy-seq "abcabc") :count 2) "bcbc")
+(string= (remove #\a (copy-seq "abcabc") :count 2 :from-end t) "bcbc")
+(string= (remove #\a (copy-seq "abcabc") :count 3) "bcbc")
+(string= (remove #\a (copy-seq "abcabc") :count 3 :from-end t) "bcbc")
+(string= (remove #\a (copy-seq "abcabc") :count 4) "bcbc")
+(string= (remove #\a (copy-seq "abcabc") :count 4 :from-end t) "bcbc")
+(string= (remove #\a (copy-seq "abcabc") :count -1) "abcabc")
+(string= (remove #\a (copy-seq "abcabc") :count -10) "abcabc")
+(string= (remove #\a (copy-seq "abcabc") :count -100) "abcabc")
+(string= (remove #\a (copy-seq "abcabcabcabc") :start 1) "abcbcbcbc")
+(string= (remove #\a (copy-seq "abcabcabcabc") :start 1 :count 1) "abcbcabcabc")
+(string= (remove #\a (copy-seq "abcabcabcabc") :start 1 :count 2) "abcbcbcabc")
+(string= (remove #\a (copy-seq "abcabcabcabc") :start 1 :end nil :count 2)
+ "abcbcbcabc")
+(string= (remove #\a (copy-seq "abcabcabcabc") :start 1 :end 8) "abcbcbcabc")
+(string= (remove #\a (copy-seq "abcabcabcabc") :start 1 :end 8 :count 1)
+ "abcbcabcabc")
+(string= (remove #\a (copy-seq "abcabcabcabc")
+ :start 1 :end 8 :count 1 :from-end t)
+ "abcabcbcabc")
+(string= (remove #\a (copy-seq "abcabcabcabc")
+ :start 1 :end 8 :count 0 :from-end t)
+ "abcabcabcabc")
+(string= (remove #\a (copy-seq "abcabcabcabc")
+ :start 1 :end 8 :count -100 :from-end t)
+ "abcabcabcabc")
+(string= (remove #\a (copy-seq "abcabcabcabc") :start 1 :end 1)
+ "abcabcabcabc")
+(string= (remove #\a (copy-seq "abcabcabcabc") :start 2 :end 2) "abcabcabcabc")
+(string= (remove #\a (copy-seq "abcabcabcabc") :start 12 :end 12) "abcabcabcabc")
+(equal (remove 0 #*0101) #*11)
+(equal (remove 0 #*01010101 :count 1) #*1010101)
+(equal (remove 0 #*01010101 :count 1 :from-end t) #*0101011)
+(equal (remove 0 #*01010101 :start 1) #*01111)
+(equal (remove 0 #*01010101 :start 1 :end nil) #*01111)
+(equal (remove 0 #*01010101 :start 1 :end 6) #*011101)
+(equal (remove 0 #*01010101 :start 1 :end 6 :count 1) #*0110101)
+(equal (remove 0 #*01010101 :start 1 :end 6 :count 1 :from-end t) #*0101101)
+(equal (remove 0 #*01010101
+ :start 1 :end 6 :count 1 :from-end t
+ :test #'(lambda (a b) (declare (ignore a)) (oddp b)))
+ #*0101001)
+(equal (remove 0 #*01010101
+ :start 1 :end 6 :count 1 :from-end t
+ :test-not #'(lambda (a b) (declare (ignore a)) (evenp b)))
+ #*0101001)
+(equal (remove 0 #*01010101
+ :start 1 :end 6 :count 1 :from-end t
+ :test #'(lambda (a b) (declare (ignore a)) (evenp b)))
+ #*0101101)
+(equal (remove 0 #*01010101
+ :start 1 :end 6 :count 1 :from-end t
+ :test-not #'(lambda (a b) (declare (ignore a)) (oddp b)))
+ #*0101101)
+(equal (remove 0 #*01010101
+ :start 1 :end 6 :count 1 :from-end t
+ :key #'(lambda (arg) (* arg 10))
+ :test #'(lambda (a b) (declare (ignore a)) (> b 1)))
+ #*0101001)
+
+
+(let* ((list0 (list 0 1 2 3 4))
+ (list (remove-if #'(lambda (arg) (eql arg 3)) list0)))
+ (and (not (eq list0 list))
+ (equal list0 '(0 1 2 3 4))
+ (equal list '(0 1 2 4))))
+(equal (remove-if #'(lambda (arg) (eql arg 'a)) (list 'a 'b 'c 'a 'b 'c))
+ '(b c b c))
+(equal (remove-if #'(lambda (arg) (eql arg 'b)) (list 'a 'b 'c 'a 'b 'c))
+ '(a c a c))
+(equal (remove-if #'(lambda (arg) (eql arg 'c)) (list 'a 'b 'c 'a 'b 'c))
+ '(a b a b))
+(equal (remove-if #'(lambda (arg) (eql arg 'a)) (list 'a 'a 'a)) '())
+(equal (remove-if #'(lambda (arg) (eql arg 'z)) (list 'a 'b 'c)) '(a b c))
+(equal (remove-if #'(lambda (arg) (eql arg 'a)) '()) '())
+(equal (remove-if #'(lambda (arg) (eql arg 'a)) (list 'a 'b 'c 'a 'b 'c)
+ :count 0) '(a b c a b c))
+(equal (remove-if #'(lambda (arg) (eql arg 'a)) (list 'a 'b 'c 'a 'b 'c)
+ :count 1) '(b c a b c))
+(equal (remove-if #'(lambda (arg) (eql arg 'a)) (list 'a 'b 'c 'a 'b 'c)
+ :count 1 :from-end t) '(a b c b c))
+(equal (remove-if #'(lambda (arg) (eql arg 'a)) (list 'a 'b 'c 'a 'b 'c)
+ :count 2) '(b c b c))
+(equal (remove-if #'(lambda (arg) (eql arg 'a)) (list 'a 'b 'c 'a 'b 'c)
+ :count 2 :from-end t) '(b c b c))
+(equal (remove-if #'(lambda (arg) (eql arg 'a)) (list 'a 'b 'c 'a 'b 'c)
+ :count 3) '(b c b c))
+(equal (remove-if #'(lambda (arg) (eql arg 'a)) (list 'a 'b 'c 'a 'b 'c)
+ :count 3 :from-end t) '(b c b c))
+(equal (remove-if #'(lambda (arg) (eql arg 'a)) (list 'a 'b 'c 'a 'b 'c)
+ :count 4) '(b c b c))
+(equal (remove-if #'(lambda (arg) (eql arg 'a)) (list 'a 'b 'c 'a 'b 'c)
+ :count 4 :from-end t) '(b c b c))
+(equal (remove-if #'(lambda (arg) (eql arg 'a)) (list 'a 'b 'c 'a 'b 'c)
+ :count -1) '(a b c a b c))
+(equal (remove-if #'(lambda (arg) (eql arg 'a)) (list 'a 'b 'c 'a 'b 'c)
+ :count -10) '(a b c a b c))
+(equal (remove-if #'(lambda (arg) (eql arg 'a)) (list 'a 'b 'c 'a 'b 'c)
+ :count -100) '(a b c a b c))
+(equal (remove-if #'(lambda (arg) (eql arg 'a))
+ (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1)
+ '(a b c b c b c b c))
+(equal (remove-if #'(lambda (arg) (eql arg 'a))
+ (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :count 1)
+ '(a b c b c a b c a b c))
+(equal (remove-if #'(lambda (arg) (eql arg 'a))
+ (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :count 2)
+ '(a b c b c b c a b c))
+(equal (remove-if #'(lambda (arg) (eql arg 'a))
+ (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :end nil :count 2)
+ '(a b c b c b c a b c))
+(equal (remove-if #'(lambda (arg) (eql arg 'a))
+ (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :end 8)
+ '(a b c b c b c a b c))
+(equal (remove-if #'(lambda (arg) (eql arg 'a))
+ (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :end 8 :count 1)
+ '(a b c b c a b c a b c))
+(equal (remove-if #'(lambda (arg) (eql arg 'a))
+ (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :end 8 :count 1 :from-end t)
+ '(a b c a b c b c a b c))
+(equal (remove-if #'(lambda (arg) (eql arg 'a))
+ (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :end 8 :count 0 :from-end t)
+ '(a b c a b c a b c a b c))
+(equal (remove-if #'(lambda (arg) (eql arg 'a))
+ (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :end 8 :count -100 :from-end t)
+ '(a b c a b c a b c a b c))
+(equal (remove-if #'(lambda (arg) (eql arg 'a))
+ (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :end 1)
+ '(a b c a b c a b c a b c))
+(equal (remove-if #'(lambda (arg) (eql arg 'a))
+ (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 2 :end 2)
+ '(a b c a b c a b c a b c))
+(equal (remove-if #'(lambda (arg) (eql arg 'a))
+ (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 12 :end 12)
+ '(a b c a b c a b c a b c))
+(equal (remove-if #'(lambda (arg) (eql arg 'a))
+ (list '(a) '(b) '(c) '(a) '(b) '(c)) :key #'car)
+ '((b) (c) (b) (c)))
+(equal (remove-if #'(lambda (arg) (eql arg 'a))
+ (list '(a . b) '(b . c) '(c . a)
+ '(a . b) '(b . c) '(c . a))
+ :key #'cdr)
+ '((a . b) (b . c) (a . b) (b . c)))
+(equal (remove-if #'(lambda (arg) (eql arg "love"))
+ (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car)
+ '(("Love") ("LOve") ("LOVe") ("LOVE")))
+(equal (remove-if #'(lambda (arg) (eql arg "love"))
+ (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count -10)
+ '(("Love") ("LOve") ("LOVe") ("LOVE")))
+(equal (remove-if #'(lambda (arg) (string-equal arg "love"))
+ (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car)
+ '())
+(equal (remove-if #'(lambda (arg) (string-equal arg "love"))
+ (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count 1)
+ '(("LOve") ("LOVe") ("LOVE")))
+(equal (remove-if #'(lambda (arg) (string-equal arg "love"))
+ (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count 1 :from-end t)
+ '(("Love") ("LOve") ("LOVe")))
+(equal (remove-if #'(lambda (arg) (string-equal arg "love"))
+ (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count 2 :from-end t)
+ '(("Love") ("LOve")))
+(equal (remove-if #'(lambda (arg) (string-equal arg "love"))
+ (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :start 1 :end 3)
+ '(("Love") ("LOVE")))
+(equal (remove-if #'(lambda (arg) (string-equal arg "love"))
+ (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count 1 :start 1 :end 3)
+ '(("Love") ("LOVe") ("LOVE")))
+(equal (remove-if #'(lambda (arg) (string-equal arg "love"))
+ (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count 1 :from-end t
+ :start 1 :end 3)
+ '(("Love") ("LOve") ("LOVE")))
+(equal (remove-if #'(lambda (arg) (string-equal arg "love"))
+ (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count 10 :from-end t :start 1 :end 3)
+ '(("Love") ("LOVE")))
+
+
+(let* ((vector0 (vector 0 1 2 3 4))
+ (vector (remove-if #'(lambda (arg) (eql arg 3)) vector0)))
+ (and (not (eq vector0 vector))
+ (equalp vector0 #(0 1 2 3 4))
+ (equalp vector #(0 1 2 4))))
+(equalp (remove-if #'(lambda (arg) (eql arg 'a))
+ (vector 'a 'b 'c 'a 'b 'c)) #(b c b c))
+(equalp (remove-if #'(lambda (arg) (eql arg 'b))
+ (vector 'a 'b 'c 'a 'b 'c)) #(a c a c))
+(equalp (remove-if #'(lambda (arg) (eql arg 'c))
+ (vector 'a 'b 'c 'a 'b 'c)) #(a b a b))
+(equalp (remove-if #'(lambda (arg) (eql arg 'a))
+ (vector 'a 'a 'a)) #())
+(equalp (remove-if #'(lambda (arg) (eql arg 'z))
+ (vector 'a 'b 'c)) #(a b c))
+(equalp (remove-if #'(lambda (arg) (eql arg 'a)) #()) #())
+(equalp (remove-if #'(lambda (arg) (eql arg 'a))
+ (vector 'a 'b 'c 'a 'b 'c) :count 0) #(a b c a b c))
+(equalp (remove-if #'(lambda (arg) (eql arg 'a))
+ (vector 'a 'b 'c 'a 'b 'c) :count 1) #(b c a b c))
+(equalp (remove-if #'(lambda (arg) (eql arg 'a))
+ (vector 'a 'b 'c 'a 'b 'c) :count 1 :from-end t) #(a b c b c))
+(equalp (remove-if #'(lambda (arg) (eql arg 'a))
+ (vector 'a 'b 'c 'a 'b 'c) :count 2) #(b c b c))
+(equalp (remove-if #'(lambda (arg) (eql arg 'a))
+ (vector 'a 'b 'c 'a 'b 'c) :count 2 :from-end t) #(b c b c))
+(equalp (remove-if #'(lambda (arg) (eql arg 'a))
+ (vector 'a 'b 'c 'a 'b 'c) :count 3) #(b c b c))
+(equalp (remove-if #'(lambda (arg) (eql arg 'a))
+ (vector 'a 'b 'c 'a 'b 'c) :count 3 :from-end t) #(b c b c))
+(equalp (remove-if #'(lambda (arg) (eql arg 'a))
+ (vector 'a 'b 'c 'a 'b 'c) :count 4) #(b c b c))
+(equalp (remove-if #'(lambda (arg) (eql arg 'a))
+ (vector 'a 'b 'c 'a 'b 'c) :count 4 :from-end t) #(b c b c))
+(equalp (remove-if #'(lambda (arg) (eql arg 'a))
+ (vector 'a 'b 'c 'a 'b 'c) :count -1) #(a b c a b c))
+(equalp (remove-if #'(lambda (arg) (eql arg 'a))
+ (vector 'a 'b 'c 'a 'b 'c) :count -10) #(a b c a b c))
+(equalp (remove-if #'(lambda (arg) (eql arg 'a))
+ (vector 'a 'b 'c 'a 'b 'c) :count -100) #(a b c a b c))
+(equalp (remove-if #'(lambda (arg) (eql arg 'a))
+ (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1)
+ #(a b c b c b c b c))
+(equalp (remove-if #'(lambda (arg) (eql arg 'a))
+ (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :count 1)
+ #(a b c b c a b c a b c))
+(equalp (remove-if #'(lambda (arg) (eql arg 'a))
+ (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :count 2)
+ #(a b c b c b c a b c))
+(equalp (remove-if #'(lambda (arg) (eql arg 'a))
+ (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :end nil :count 2)
+ #(a b c b c b c a b c))
+(equalp (remove-if #'(lambda (arg) (eql arg 'a))
+ (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :end 8)
+ #(a b c b c b c a b c))
+(equalp (remove-if #'(lambda (arg) (eql arg 'a))
+ (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :end 8 :count 1)
+ #(a b c b c a b c a b c))
+(equalp (remove-if #'(lambda (arg) (eql arg 'a))
+ (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :end 8 :count 1 :from-end t)
+ #(a b c a b c b c a b c))
+(equalp (remove-if #'(lambda (arg) (eql arg 'a))
+ (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :end 8 :count 0 :from-end t)
+ #(a b c a b c a b c a b c))
+(equalp (remove-if #'(lambda (arg) (eql arg 'a))
+ (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :end 8 :count -100 :from-end t)
+ #(a b c a b c a b c a b c))
+(equalp (remove-if #'(lambda (arg) (eql arg 'a))
+ (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :end 1)
+ #(a b c a b c a b c a b c))
+(equalp (remove-if #'(lambda (arg) (eql arg 'a))
+ (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 2 :end 2)
+ #(a b c a b c a b c a b c))
+(equalp (remove-if #'(lambda (arg) (eql arg 'a))
+ (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 12 :end 12)
+ #(a b c a b c a b c a b c))
+(equalp (remove-if #'(lambda (arg) (eql arg 'a))
+ (vector '(a) '(b) '(c) '(a) '(b) '(c)) :key #'car)
+ #((b) (c) (b) (c)))
+(equalp (remove-if #'(lambda (arg) (eql arg 'a))
+ (vector '(a . b) '(b . c) '(c . a)
+ '(a . b) '(b . c) '(c . a))
+ :key #'cdr)
+ #((a . b) (b . c) (a . b) (b . c)))
+(equalp (remove-if #'(lambda (arg) (eql arg "love"))
+ (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car)
+ #(("Love") ("LOve") ("LOVe") ("LOVE")))
+(equalp (remove-if #'(lambda (arg) (eql arg "love"))
+ (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count -10)
+ #(("Love") ("LOve") ("LOVe") ("LOVE")))
+(equalp (remove-if #'(lambda (arg) (string-equal arg "love"))
+ (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car)
+ #())
+(equalp (remove-if #'(lambda (arg) (string-equal arg "love"))
+ (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car)
+ #())
+(equalp (remove-if #'(lambda (arg) (string-equal arg "love"))
+ (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count 1)
+ #(("LOve") ("LOVe") ("LOVE")))
+(equalp (remove-if #'(lambda (arg) (string-equal arg "love"))
+ (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count 1)
+ #(("LOve") ("LOVe") ("LOVE")))
+(equalp (remove-if #'(lambda (arg) (string-equal arg "love"))
+ (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count 1 :from-end t)
+ #(("Love") ("LOve") ("LOVe")))
+(equalp (remove-if #'(lambda (arg) (string-equal arg "love"))
+ (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count 1 :from-end t)
+ #(("Love") ("LOve") ("LOVe")))
+(equalp (remove-if #'(lambda (arg) (string-equal arg "love"))
+ (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count 2 :from-end t)
+ #(("Love") ("LOve")))
+(equalp (remove-if #'(lambda (arg) (string-equal arg "love"))
+ (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count 2 :from-end t)
+ #(("Love") ("LOve")))
+(equalp (remove-if #'(lambda (arg) (string-equal arg "love"))
+ (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :start 1 :end 3)
+ #(("Love") ("LOVE")))
+(equalp (remove-if #'(lambda (arg) (string-equal arg "love"))
+ (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count 1 :start 1 :end 3)
+ #(("Love") ("LOVe") ("LOVE")))
+(equalp (remove-if #'(lambda (arg) (string-equal arg "love"))
+ (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count 1 :from-end t
+ :start 1 :end 3)
+ #(("Love") ("LOve") ("LOVE")))
+(equalp (remove-if #'(lambda (arg) (string-equal arg "love"))
+ (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count 10 :from-end t
+ :start 1 :end 3)
+ #(("Love") ("LOVE")))
+
+(string= (remove-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc"))
+ "bcbc")
+(string= (remove-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "")) "")
+(string= (remove-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "xyz"))
+ "xyz")
+(string= (remove-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "ABCABC")
+ :key #'char-downcase) "BCBC")
+(string= (remove-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc")
+ :count 1) "bcabc")
+(string= (remove-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc")
+ :count 1 :from-end t) "abcbc")
+(string= (remove-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc")
+ :count 0) "abcabc")
+(string= (remove-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc")
+ :count -10) "abcabc")
+(let* ((str0 (copy-seq "abc"))
+ (str (remove-if #'(lambda (arg) (string-equal arg #\a)) str0)))
+ (and (not (eq str0 str))
+ (string= str0 "abc")
+ (string= str "bc")))
+(string= (remove-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc")
+ :count 0) "abcabc")
+(string= (remove-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc"))
+ "bcbc")
+(string= (remove-if #'(lambda (arg) (string-equal arg #\b)) (copy-seq "abcabc"))
+ "acac")
+(string= (remove-if #'(lambda (arg) (string-equal arg #\c)) (copy-seq "abcabc"))
+ "abab")
+(string= (remove-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc")
+ :count 0) "abcabc")
+(string= (remove-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc")
+ :count 1) "bcabc")
+(string= (remove-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc")
+ :count 1 :from-end t) "abcbc")
+(string= (remove-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc")
+ :count 2) "bcbc")
+(string= (remove-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc")
+ :count 2 :from-end t) "bcbc")
+(string= (remove-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc")
+ :count 3) "bcbc")
+(string= (remove-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc")
+ :count 3 :from-end t) "bcbc")
+(string= (remove-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc")
+ :count 4) "bcbc")
+(string= (remove-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc")
+ :count 4 :from-end t) "bcbc")
+(string= (remove-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc")
+ :count -1) "abcabc")
+(string= (remove-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc")
+ :count -10) "abcabc")
+(string= (remove-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc")
+ :count -100) "abcabc")
+(string= (remove-if #'(lambda (arg) (string-equal arg #\a))
+ (copy-seq "abcabcabcabc") :start 1) "abcbcbcbc")
+(string= (remove-if #'(lambda (arg) (string-equal arg #\a))
+ (copy-seq "abcabcabcabc") :start 1 :count 1) "abcbcabcabc")
+(string= (remove-if #'(lambda (arg) (eql arg #\a)) (copy-seq "abcabcabcabc")
+ :start 1 :count 2)
+ "abcbcbcabc")
+(string= (remove-if #'(lambda (arg) (eql arg #\a)) (copy-seq "abcabcabcabc")
+ :start 1 :end nil :count 2)
+ "abcbcbcabc")
+(string= (remove-if #'(lambda (arg) (eql arg #\a)) (copy-seq "abcabcabcabc")
+ :start 1 :end 8) "abcbcbcabc")
+(string= (remove-if #'(lambda (arg) (eql arg #\a)) (copy-seq "abcabcabcabc")
+ :start 1 :end 8 :count 1)
+ "abcbcabcabc")
+(string= (remove-if #'(lambda (arg) (eql arg #\a)) (copy-seq "abcabcabcabc")
+ :start 1 :end 8 :count 1 :from-end t)
+ "abcabcbcabc")
+(string= (remove-if #'(lambda (arg) (eql arg #\a)) (copy-seq "abcabcabcabc")
+ :start 1 :end 8 :count 0 :from-end t)
+ "abcabcabcabc")
+(string= (remove-if #'(lambda (arg) (eql arg #\a)) (copy-seq "abcabcabcabc")
+ :start 1 :end 8 :count -100 :from-end t)
+ "abcabcabcabc")
+(string= (remove-if #'(lambda (arg) (eql arg #\a)) (copy-seq "abcabcabcabc")
+ :start 1 :end 1)
+ "abcabcabcabc")
+(string= (remove-if #'(lambda (arg) (eql arg #\a)) (copy-seq "abcabcabcabc")
+ :start 2 :end 2) "abcabcabcabc")
+(string= (remove-if #'(lambda (arg) (eql arg #\a)) (copy-seq "abcabcabcabc")
+ :start 12 :end 12) "abcabcabcabc")
+(equal (remove-if #'zerop #*0101) #*11)
+(equal (remove-if #'zerop #*01010101 :count 1) #*1010101)
+(equal (remove-if #'zerop #*01010101 :count 1 :from-end t) #*0101011)
+(equal (remove-if #'zerop #*01010101 :start 1) #*01111)
+(equal (remove-if #'zerop #*01010101 :start 1 :end nil) #*01111)
+(equal (remove-if #'zerop #*01010101 :start 1 :end 6) #*011101)
+(equal (remove-if #'zerop #*01010101 :start 1 :end 6 :count 1) #*0110101)
+(equal (remove-if #'zerop #*01010101 :start 1 :end 6 :count 1 :from-end t)
+ #*0101101)
+(equal (remove-if #'oddp #*01010101 :start 1 :end 6 :count 1 :from-end t)
+ #*0101001)
+(equal (remove-if #'evenp #*01010101 :start 1 :end 6 :count 1 :from-end t)
+ #*0101101)
+(equal (remove-if #'plusp #*01010101
+ :start 1 :end 6 :count 1 :from-end t
+ :key #'(lambda (arg) (* arg 10)))
+ #*0101001)
+
+
+(let* ((list0 (list 0 1 2 3 4))
+ (list (remove-if-not #'(lambda (arg) (not (eql arg 3))) list0)))
+ (and (not (eq list0 list))
+ (equal list0 '(0 1 2 3 4))
+ (equal list '(0 1 2 4))))
+(equal (remove-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (list 'a 'b 'c 'a 'b 'c))
+ '(b c b c))
+(equal (remove-if-not #'(lambda (arg) (not (eql arg 'b)))
+ (list 'a 'b 'c 'a 'b 'c))
+ '(a c a c))
+(equal (remove-if-not #'(lambda (arg) (not (eql arg 'c)))
+ (list 'a 'b 'c 'a 'b 'c))
+ '(a b a b))
+(equal (remove-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (list 'a 'a 'a)) '())
+(equal (remove-if-not #'(lambda (arg) (not (eql arg 'z)))
+ (list 'a 'b 'c)) '(a b c))
+(equal (remove-if-not #'(lambda (arg) (not (eql arg 'a))) '()) '())
+(equal (remove-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (list 'a 'b 'c 'a 'b 'c) :count 0) '(a b c a b c))
+(equal (remove-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (list 'a 'b 'c 'a 'b 'c) :count 1) '(b c a b c))
+(equal (remove-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (list 'a 'b 'c 'a 'b 'c) :count 1 :from-end t)
+ '(a b c b c))
+(equal (remove-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (list 'a 'b 'c 'a 'b 'c) :count 2)
+ '(b c b c))
+(equal (remove-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (list 'a 'b 'c 'a 'b 'c) :count 2 :from-end t)
+ '(b c b c))
+(equal (remove-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (list 'a 'b 'c 'a 'b 'c) :count 3)
+ '(b c b c))
+(equal (remove-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (list 'a 'b 'c 'a 'b 'c) :count 3 :from-end t)
+ '(b c b c))
+(equal (remove-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (list 'a 'b 'c 'a 'b 'c) :count 4)
+ '(b c b c))
+(equal (remove-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (list 'a 'b 'c 'a 'b 'c) :count 4 :from-end t)
+ '(b c b c))
+(equal (remove-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (list 'a 'b 'c 'a 'b 'c) :count -1)
+ '(a b c a b c))
+(equal (remove-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (list 'a 'b 'c 'a 'b 'c) :count -10)
+ '(a b c a b c))
+(equal (remove-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (list 'a 'b 'c 'a 'b 'c) :count -100)
+ '(a b c a b c))
+(equal (remove-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1)
+ '(a b c b c b c b c))
+(equal (remove-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :count 1)
+ '(a b c b c a b c a b c))
+(equal (remove-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :count 2)
+ '(a b c b c b c a b c))
+(equal (remove-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :end nil :count 2)
+ '(a b c b c b c a b c))
+(equal (remove-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :end 8)
+ '(a b c b c b c a b c))
+(equal (remove-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :end 8 :count 1)
+ '(a b c b c a b c a b c))
+(equal (remove-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :end 8 :count 1 :from-end t)
+ '(a b c a b c b c a b c))
+(equal (remove-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :end 8 :count 0 :from-end t)
+ '(a b c a b c a b c a b c))
+(equal (remove-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :end 8 :count -100 :from-end t)
+ '(a b c a b c a b c a b c))
+(equal (remove-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :end 1)
+ '(a b c a b c a b c a b c))
+(equal (remove-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 2 :end 2)
+ '(a b c a b c a b c a b c))
+(equal (remove-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 12 :end 12)
+ '(a b c a b c a b c a b c))
+(equal (remove-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (list '(a) '(b) '(c) '(a) '(b) '(c)) :key #'car)
+ '((b) (c) (b) (c)))
+(equal (remove-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (list '(a . b) '(b . c) '(c . a)
+ '(a . b) '(b . c) '(c . a))
+ :key #'cdr)
+ '((a . b) (b . c) (a . b) (b . c)))
+(equal (remove-if-not #'(lambda (arg) (not (eql arg "love")))
+ (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car)
+ '(("Love") ("LOve") ("LOVe") ("LOVE")))
+(equal (remove-if-not #'(lambda (arg) (not (eql arg "love")))
+ (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count -10)
+ '(("Love") ("LOve") ("LOVe") ("LOVE")))
+(equal (remove-if-not #'(lambda (arg) (not (string-equal arg "love")))
+ (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car)
+ '())
+(equal (remove-if-not #'(lambda (arg) (not (string-equal arg "love")))
+ (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count 1)
+ '(("LOve") ("LOVe") ("LOVE")))
+(equal (remove-if-not #'(lambda (arg) (not (string-equal arg "love")))
+ (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count 1 :from-end t)
+ '(("Love") ("LOve") ("LOVe")))
+(equal (remove-if-not #'(lambda (arg) (not (string-equal arg "love")))
+ (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count 2 :from-end t)
+ '(("Love") ("LOve")))
+(equal (remove-if-not #'(lambda (arg) (not (string-equal arg "love")))
+ (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :start 1 :end 3)
+ '(("Love") ("LOVE")))
+(equal (remove-if-not #'(lambda (arg) (not (string-equal arg "love")))
+ (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count 1 :start 1 :end 3)
+ '(("Love") ("LOVe") ("LOVE")))
+(equal (remove-if-not #'(lambda (arg) (not (string-equal arg "love")))
+ (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count 1 :from-end t
+ :start 1 :end 3)
+ '(("Love") ("LOve") ("LOVE")))
+(equal (remove-if-not #'(lambda (arg) (not (string-equal arg "love")))
+ (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count 10 :from-end t :start 1 :end 3)
+ '(("Love") ("LOVE")))
+
+
+(let* ((vector0 (vector 0 1 2 3 4))
+ (vector (remove-if-not #'(lambda (arg) (not (eql arg 3))) vector0)))
+ (and (not (eq vector0 vector))
+ (equalp vector0 #(0 1 2 3 4))
+ (equalp vector #(0 1 2 4))))
+(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (vector 'a 'b 'c 'a 'b 'c)) #(b c b c))
+(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'b)))
+ (vector 'a 'b 'c 'a 'b 'c)) #(a c a c))
+(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'c)))
+ (vector 'a 'b 'c 'a 'b 'c)) #(a b a b))
+(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (vector 'a 'a 'a)) #())
+(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'z)))
+ (vector 'a 'b 'c)) #(a b c))
+(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'a))) #()) #())
+(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (vector 'a 'b 'c 'a 'b 'c) :count 0) #(a b c a b c))
+(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (vector 'a 'b 'c 'a 'b 'c) :count 1) #(b c a b c))
+(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (vector 'a 'b 'c 'a 'b 'c) :count 1 :from-end t) #(a b c b c))
+(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (vector 'a 'b 'c 'a 'b 'c) :count 2) #(b c b c))
+(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (vector 'a 'b 'c 'a 'b 'c) :count 2 :from-end t) #(b c b c))
+(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (vector 'a 'b 'c 'a 'b 'c) :count 3) #(b c b c))
+(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (vector 'a 'b 'c 'a 'b 'c) :count 3 :from-end t) #(b c b c))
+(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (vector 'a 'b 'c 'a 'b 'c) :count 4) #(b c b c))
+(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (vector 'a 'b 'c 'a 'b 'c) :count 4 :from-end t) #(b c b c))
+(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (vector 'a 'b 'c 'a 'b 'c) :count -1) #(a b c a b c))
+(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (vector 'a 'b 'c 'a 'b 'c) :count -10) #(a b c a b c))
+(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (vector 'a 'b 'c 'a 'b 'c) :count -100) #(a b c a b c))
+(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1)
+ #(a b c b c b c b c))
+(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :count 1)
+ #(a b c b c a b c a b c))
+(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :count 2)
+ #(a b c b c b c a b c))
+(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :end nil :count 2)
+ #(a b c b c b c a b c))
+(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :end 8)
+ #(a b c b c b c a b c))
+(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :end 8 :count 1)
+ #(a b c b c a b c a b c))
+(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :end 8 :count 1 :from-end t)
+ #(a b c a b c b c a b c))
+(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :end 8 :count 0 :from-end t)
+ #(a b c a b c a b c a b c))
+(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :end 8 :count -100 :from-end t)
+ #(a b c a b c a b c a b c))
+(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :end 1)
+ #(a b c a b c a b c a b c))
+(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 2 :end 2)
+ #(a b c a b c a b c a b c))
+(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 12 :end 12)
+ #(a b c a b c a b c a b c))
+(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (vector '(a) '(b) '(c) '(a) '(b) '(c)) :key #'car)
+ #((b) (c) (b) (c)))
+(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (vector '(a . b) '(b . c) '(c . a)
+ '(a . b) '(b . c) '(c . a))
+ :key #'cdr)
+ #((a . b) (b . c) (a . b) (b . c)))
+(equalp (remove-if-not #'(lambda (arg) (not (eql arg "love")))
+ (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car)
+ #(("Love") ("LOve") ("LOVe") ("LOVE")))
+(equalp (remove-if-not #'(lambda (arg) (not (eql arg "love")))
+ (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count -10)
+ #(("Love") ("LOve") ("LOVe") ("LOVE")))
+(equalp (remove-if-not #'(lambda (arg) (not (string-equal arg "love")))
+ (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car)
+ #())
+(equalp (remove-if-not #'(lambda (arg) (not (string-equal arg "love")))
+ (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car)
+ #())
+(equalp (remove-if-not #'(lambda (arg) (not (string-equal arg "love")))
+ (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count 1)
+ #(("LOve") ("LOVe") ("LOVE")))
+(equalp (remove-if-not #'(lambda (arg) (not (string-equal arg "love")))
+ (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count 1)
+ #(("LOve") ("LOVe") ("LOVE")))
+(equalp (remove-if-not #'(lambda (arg) (not (string-equal arg "love")))
+ (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count 1 :from-end t)
+ #(("Love") ("LOve") ("LOVe")))
+(equalp (remove-if-not #'(lambda (arg) (not (string-equal arg "love")))
+ (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count 1 :from-end t)
+ #(("Love") ("LOve") ("LOVe")))
+(equalp (remove-if-not #'(lambda (arg) (not (string-equal arg "love")))
+ (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count 2 :from-end t)
+ #(("Love") ("LOve")))
+(equalp (remove-if-not #'(lambda (arg) (not (string-equal arg "love")))
+ (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count 2 :from-end t)
+ #(("Love") ("LOve")))
+(equalp (remove-if-not #'(lambda (arg) (not (string-equal arg "love")))
+ (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :start 1 :end 3)
+ #(("Love") ("LOVE")))
+(equalp (remove-if-not #'(lambda (arg) (not (string-equal arg "love")))
+ (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count 1 :start 1 :end 3)
+ #(("Love") ("LOVe") ("LOVE")))
+(equalp (remove-if-not #'(lambda (arg) (not (string-equal arg "love")))
+ (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count 1 :from-end t
+ :start 1 :end 3)
+ #(("Love") ("LOve") ("LOVE")))
+(equalp (remove-if-not #'(lambda (arg) (not (string-equal arg "love")))
+ (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count 10 :from-end t
+ :start 1 :end 3)
+ #(("Love") ("LOVE")))
+
+(string= (remove-if-not #'(lambda (arg) (not (string-equal arg #\a)))
+ (copy-seq "abcabc"))
+ "bcbc")
+(string= (remove-if-not #'(lambda (arg) (not (string-equal arg #\a)))
+ (copy-seq "")) "")
+(string= (remove-if-not #'(lambda (arg) (not (string-equal arg #\a)))
+ (copy-seq "xyz"))
+ "xyz")
+(string= (remove-if-not #'(lambda (arg) (not (string-equal arg #\a)))
+ (copy-seq "ABCABC")
+ :key #'char-downcase) "BCBC")
+(string= (remove-if-not #'(lambda (arg) (not (string-equal arg #\a)))
+ (copy-seq "abcabc")
+ :count 1) "bcabc")
+(string= (remove-if-not #'(lambda (arg) (not (string-equal arg #\a)))
+ (copy-seq "abcabc")
+ :count 1 :from-end t) "abcbc")
+(string= (remove-if-not #'(lambda (arg) (not (string-equal arg #\a)))
+ (copy-seq "abcabc")
+ :count 0) "abcabc")
+(string= (remove-if-not #'(lambda (arg) (not (string-equal arg #\a)))
+ (copy-seq "abcabc")
+ :count -10) "abcabc")
+(let* ((str0 (copy-seq "abc"))
+ (str (remove-if-not #'(lambda (arg) (not (string-equal arg #\a))) str0)))
+ (and (not (eq str0 str))
+ (string= str0 "abc")
+ (string= str "bc")))
+(string= (remove-if-not #'(lambda (arg) (not (string-equal arg #\a)))
+ (copy-seq "abcabc")
+ :count 0) "abcabc")
+(string= (remove-if-not #'(lambda (arg) (not (string-equal arg #\a)))
+ (copy-seq "abcabc"))
+ "bcbc")
+(string= (remove-if-not #'(lambda (arg) (not (string-equal arg #\b)))
+ (copy-seq "abcabc"))
+ "acac")
+(string= (remove-if-not #'(lambda (arg) (not (string-equal arg #\c)))
+ (copy-seq "abcabc"))
+ "abab")
+(string= (remove-if-not #'(lambda (arg) (not (string-equal arg #\a)))
+ (copy-seq "abcabc")
+ :count 0) "abcabc")
+(string= (remove-if-not #'(lambda (arg) (not (string-equal arg #\a)))
+ (copy-seq "abcabc")
+ :count 1) "bcabc")
+(string= (remove-if-not #'(lambda (arg) (not (string-equal arg #\a)))
+ (copy-seq "abcabc")
+ :count 1 :from-end t) "abcbc")
+(string= (remove-if-not #'(lambda (arg) (not (string-equal arg #\a)))
+ (copy-seq "abcabc")
+ :count 2) "bcbc")
+(string= (remove-if-not #'(lambda (arg) (not (string-equal arg #\a)))
+ (copy-seq "abcabc")
+ :count 2 :from-end t) "bcbc")
+(string= (remove-if-not #'(lambda (arg) (not (string-equal arg #\a)))
+ (copy-seq "abcabc")
+ :count 3) "bcbc")
+(string= (remove-if-not #'(lambda (arg) (not (string-equal arg #\a)))
+ (copy-seq "abcabc")
+ :count 3 :from-end t) "bcbc")
+(string= (remove-if-not #'(lambda (arg) (not (string-equal arg #\a)))
+ (copy-seq "abcabc")
+ :count 4) "bcbc")
+(string= (remove-if-not #'(lambda (arg) (not (string-equal arg #\a)))
+ (copy-seq "abcabc")
+ :count 4 :from-end t) "bcbc")
+(string= (remove-if-not #'(lambda (arg) (not (string-equal arg #\a)))
+ (copy-seq "abcabc")
+ :count -1) "abcabc")
+(string= (remove-if-not #'(lambda (arg) (not (string-equal arg #\a)))
+ (copy-seq "abcabc")
+ :count -10) "abcabc")
+(string= (remove-if-not #'(lambda (arg) (not (string-equal arg #\a)))
+ (copy-seq "abcabc")
+ :count -100) "abcabc")
+(string= (remove-if-not #'(lambda (arg) (not (string-equal arg #\a)))
+ (copy-seq "abcabcabcabc") :start 1) "abcbcbcbc")
+(string= (remove-if-not #'(lambda (arg) (not (string-equal arg #\a)))
+ (copy-seq "abcabcabcabc") :start 1 :count 1) "abcbcabcabc")
+(string= (remove-if-not #'(lambda (arg) (not (eql arg #\a)))
+ (copy-seq "abcabcabcabc") :start 1 :count 2)
+ "abcbcbcabc")
+(string= (remove-if-not #'(lambda (arg) (not (eql arg #\a)))
+ (copy-seq "abcabcabcabc") :start 1 :end nil :count 2)
+ "abcbcbcabc")
+(string= (remove-if-not #'(lambda (arg) (not (eql arg #\a)))
+ (copy-seq "abcabcabcabc") :start 1 :end 8) "abcbcbcabc")
+(string= (remove-if-not #'(lambda (arg) (not (eql arg #\a)))
+ (copy-seq "abcabcabcabc") :start 1 :end 8 :count 1)
+ "abcbcabcabc")
+(string= (remove-if-not #'(lambda (arg) (not (eql arg #\a)))
+ (copy-seq "abcabcabcabc")
+ :start 1 :end 8 :count 1 :from-end t)
+ "abcabcbcabc")
+(string= (remove-if-not #'(lambda (arg) (not (eql arg #\a)))
+ (copy-seq "abcabcabcabc")
+ :start 1 :end 8 :count 0 :from-end t)
+ "abcabcabcabc")
+(string= (remove-if-not #'(lambda (arg) (not (eql arg #\a)))
+ (copy-seq "abcabcabcabc")
+ :start 1 :end 8 :count -100 :from-end t)
+ "abcabcabcabc")
+(string= (remove-if-not #'(lambda (arg) (not (eql arg #\a)))
+ (copy-seq "abcabcabcabc") :start 1 :end 1)
+ "abcabcabcabc")
+(string= (remove-if-not #'(lambda (arg) (not (eql arg #\a)))
+ (copy-seq "abcabcabcabc")
+ :start 2 :end 2) "abcabcabcabc")
+(string= (remove-if-not #'(lambda (arg) (not (eql arg #\a)))
+ (copy-seq "abcabcabcabc")
+ :start 12 :end 12) "abcabcabcabc")
+(equal (remove-if-not (complement #'zerop) #*0101) #*11)
+(equal (remove-if-not (complement #'zerop) #*01010101 :count 1) #*1010101)
+(equal (remove-if-not (complement #'zerop) #*01010101 :count 1 :from-end t)
+ #*0101011)
+(equal (remove-if-not (complement #'zerop) #*01010101 :start 1) #*01111)
+(equal (remove-if-not (complement #'zerop) #*01010101 :start 1 :end nil) #*01111)
+(equal (remove-if-not (complement #'zerop) #*01010101 :start 1 :end 6) #*011101)
+(equal (remove-if-not (complement #'zerop) #*01010101 :start 1 :end 6 :count 1)
+ #*0110101)
+(equal (remove-if-not (complement #'zerop) #*01010101
+ :start 1 :end 6 :count 1 :from-end t)
+ #*0101101)
+(equal (remove-if-not (complement #'oddp) #*01010101
+ :start 1 :end 6 :count 1 :from-end t)
+ #*0101001)
+(equal (remove-if-not (complement #'evenp)
+ #*01010101 :start 1 :end 6 :count 1 :from-end t)
+ #*0101101)
+(equal (remove-if-not (complement #'plusp) #*01010101
+ :start 1 :end 6 :count 1 :from-end t
+ :key #'(lambda (arg) (* arg 10)))
+ #*0101001)
+
+
+(equal (delete 'a (list 'a 'b 'c 'a 'b 'c)) '(b c b c))
+(equal (delete 'b (list 'a 'b 'c 'a 'b 'c)) '(a c a c))
+(equal (delete 'c (list 'a 'b 'c 'a 'b 'c)) '(a b a b))
+(equal (delete 'a (list 'a 'a 'a)) '())
+(equal (delete 'z (list 'a 'b 'c)) '(a b c))
+(equal (delete 'a '()) '())
+(equal (delete 'a (list 'a 'b 'c 'a 'b 'c) :count 0) '(a b c a b c))
+(equal (delete 'a (list 'a 'b 'c 'a 'b 'c) :count 1) '(b c a b c))
+(equal (delete 'a (list 'a 'b 'c 'a 'b 'c) :count 1 :from-end t) '(a b c b c))
+(equal (delete 'a (list 'a 'b 'c 'a 'b 'c) :count 2) '(b c b c))
+(equal (delete 'a (list 'a 'b 'c 'a 'b 'c) :count 2 :from-end t) '(b c b c))
+(equal (delete 'a (list 'a 'b 'c 'a 'b 'c) :count 3) '(b c b c))
+(equal (delete 'a (list 'a 'b 'c 'a 'b 'c) :count 3 :from-end t) '(b c b c))
+(equal (delete 'a (list 'a 'b 'c 'a 'b 'c) :count 4) '(b c b c))
+(equal (delete 'a (list 'a 'b 'c 'a 'b 'c) :count 4 :from-end t) '(b c b c))
+(equal (delete 'a (list 'a 'b 'c 'a 'b 'c) :count -1) '(a b c a b c))
+(equal (delete 'a (list 'a 'b 'c 'a 'b 'c) :count -10) '(a b c a b c))
+(equal (delete 'a (list 'a 'b 'c 'a 'b 'c) :count -100) '(a b c a b c))
+(equal (delete 'a (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1)
+ '(a b c b c b c b c))
+(equal (delete 'a (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :count 1)
+ '(a b c b c a b c a b c))
+(equal (delete 'a (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :count 2)
+ '(a b c b c b c a b c))
+(equal (delete 'a (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :end nil :count 2)
+ '(a b c b c b c a b c))
+(equal (delete 'a (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :end 8)
+ '(a b c b c b c a b c))
+(equal (delete 'a (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :end 8 :count 1)
+ '(a b c b c a b c a b c))
+(equal (delete 'a (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :end 8 :count 1 :from-end t)
+ '(a b c a b c b c a b c))
+(equal (delete 'a (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :end 8 :count 0 :from-end t)
+ '(a b c a b c a b c a b c))
+(equal (delete 'a (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :end 8 :count -100 :from-end t)
+ '(a b c a b c a b c a b c))
+(equal (delete 'a (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :end 1)
+ '(a b c a b c a b c a b c))
+(equal (delete 'a (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 2 :end 2)
+ '(a b c a b c a b c a b c))
+(equal (delete 'a (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 12 :end 12)
+ '(a b c a b c a b c a b c))
+(equal (delete 'a (list '(a) '(b) '(c) '(a) '(b) '(c)) :key #'car)
+ '((b) (c) (b) (c)))
+(equal (delete 'a (list '(a . b) '(b . c) '(c . a)
+ '(a . b) '(b . c) '(c . a))
+ :key #'cdr)
+ '((a . b) (b . c) (a . b) (b . c)))
+(equal (delete "love" (list '("Love") '("LOve") '("LOVe") '("LOVE")) :key #'car)
+ '(("Love") ("LOve") ("LOVe") ("LOVE")))
+(equal (delete "love" (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count -10)
+ '(("Love") ("LOve") ("LOVe") ("LOVE")))
+(equal (delete "love" (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test #'string-equal)
+ '())
+(equal (delete "love" (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test-not (complement #'string-equal))
+ '())
+(equal (delete "love" (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test #'string-equal :count 1)
+ '(("LOve") ("LOVe") ("LOVE")))
+(equal (delete "love" (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test-not (complement #'string-equal) :count 1)
+ '(("LOve") ("LOVe") ("LOVE")))
+(equal (delete "love" (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test #'string-equal :count 1 :from-end t)
+ '(("Love") ("LOve") ("LOVe")))
+(equal (delete "love" (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test-not (complement #'string-equal)
+ :count 1 :from-end t)
+ '(("Love") ("LOve") ("LOVe")))
+(equal (delete "love" (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test #'string-equal :count 2 :from-end t)
+ '(("Love") ("LOve")))
+(equal (delete "love" (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test-not (complement #'string-equal)
+ :count 2 :from-end t)
+ '(("Love") ("LOve")))
+(equal (delete "love" (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test #'string-equal :start 1 :end 3)
+ '(("Love") ("LOVE")))
+(equal (delete "love" (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test-not (complement #'string-equal) :start 1 :end 3)
+ '(("Love") ("LOVE")))
+(equal (delete "love" (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test #'string-equal :count 1 :start 1 :end 3)
+ '(("Love") ("LOVe") ("LOVE")))
+(equal (delete "love" (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test-not (complement #'string-equal)
+ :count 1 :start 1 :end 3)
+ '(("Love") ("LOVe") ("LOVE")))
+(equal (delete "love" (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test #'string-equal :count 1 :from-end t
+ :start 1 :end 3)
+ '(("Love") ("LOve") ("LOVE")))
+(equal (delete "love" (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test-not (complement #'string-equal)
+ :count 1 :from-end t :start 1 :end 3)
+ '(("Love") ("LOve") ("LOVE")))
+(equal (delete "love" (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test #'string-equal :count 10 :from-end t
+ :start 1 :end 3)
+ '(("Love") ("LOVE")))
+(equal (delete "love" (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test-not (complement #'string-equal)
+ :count 10 :from-end t :start 1 :end 3)
+ '(("Love") ("LOVE")))
+
+
+(equalp (delete 'a (vector 'a 'b 'c 'a 'b 'c)) #(b c b c))
+(equalp (delete 'b (vector 'a 'b 'c 'a 'b 'c)) #(a c a c))
+(equalp (delete 'c (vector 'a 'b 'c 'a 'b 'c)) #(a b a b))
+(equalp (delete 'a (vector 'a 'a 'a)) #())
+(equalp (delete 'z (vector 'a 'b 'c)) #(a b c))
+(equalp (delete 'a #()) #())
+(equalp (delete 'a (vector 'a 'b 'c 'a 'b 'c) :count 0) #(a b c a b c))
+(equalp (delete 'a (vector 'a 'b 'c 'a 'b 'c) :count 1) #(b c a b c))
+(equalp (delete 'a (vector 'a 'b 'c 'a 'b 'c) :count 1 :from-end t) #(a b c b c))
+(equalp (delete 'a (vector 'a 'b 'c 'a 'b 'c) :count 2) #(b c b c))
+(equalp (delete 'a (vector 'a 'b 'c 'a 'b 'c) :count 2 :from-end t) #(b c b c))
+(equalp (delete 'a (vector 'a 'b 'c 'a 'b 'c) :count 3) #(b c b c))
+(equalp (delete 'a (vector 'a 'b 'c 'a 'b 'c) :count 3 :from-end t) #(b c b c))
+(equalp (delete 'a (vector 'a 'b 'c 'a 'b 'c) :count 4) #(b c b c))
+(equalp (delete 'a (vector 'a 'b 'c 'a 'b 'c) :count 4 :from-end t) #(b c b c))
+(equalp (delete 'a (vector 'a 'b 'c 'a 'b 'c) :count -1) #(a b c a b c))
+(equalp (delete 'a (vector 'a 'b 'c 'a 'b 'c) :count -10) #(a b c a b c))
+(equalp (delete 'a (vector 'a 'b 'c 'a 'b 'c) :count -100) #(a b c a b c))
+(equalp (delete 'a (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1)
+ #(a b c b c b c b c))
+(equalp (delete 'a (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :count 1)
+ #(a b c b c a b c a b c))
+(equalp (delete 'a (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :count 2)
+ #(a b c b c b c a b c))
+(equalp (delete 'a (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :end nil :count 2)
+ #(a b c b c b c a b c))
+(equalp (delete 'a (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :end 8)
+ #(a b c b c b c a b c))
+(equalp (delete 'a (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :end 8 :count 1)
+ #(a b c b c a b c a b c))
+(equalp (delete 'a (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :end 8 :count 1 :from-end t)
+ #(a b c a b c b c a b c))
+(equalp (delete 'a (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :end 8 :count 0 :from-end t)
+ #(a b c a b c a b c a b c))
+(equalp (delete 'a (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :end 8 :count -100 :from-end t)
+ #(a b c a b c a b c a b c))
+(equalp (delete 'a (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :end 1)
+ #(a b c a b c a b c a b c))
+(equalp (delete 'a (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 2 :end 2)
+ #(a b c a b c a b c a b c))
+(equalp (delete 'a (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 12 :end 12)
+ #(a b c a b c a b c a b c))
+(equalp (delete 'a (vector '(a) '(b) '(c) '(a) '(b) '(c)) :key #'car)
+ #((b) (c) (b) (c)))
+(equalp (delete 'a (vector '(a . b) '(b . c) '(c . a)
+ '(a . b) '(b . c) '(c . a))
+ :key #'cdr)
+ #((a . b) (b . c) (a . b) (b . c)))
+(equalp (delete "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car)
+ #(("Love") ("LOve") ("LOVe") ("LOVE")))
+(equalp (delete "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count -10)
+ #(("Love") ("LOve") ("LOVe") ("LOVE")))
+(equalp (delete "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test #'string-equal)
+ #())
+(equalp (delete "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test-not (complement #'string-equal))
+ #())
+(equalp (delete "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test #'string-equal :count 1)
+ #(("LOve") ("LOVe") ("LOVE")))
+(equalp (delete "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test-not (complement #'string-equal) :count 1)
+ #(("LOve") ("LOVe") ("LOVE")))
+(equalp (delete "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test #'string-equal :count 1 :from-end t)
+ #(("Love") ("LOve") ("LOVe")))
+(equalp (delete "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test-not (complement #'string-equal)
+ :count 1 :from-end t)
+ #(("Love") ("LOve") ("LOVe")))
+(equalp (delete "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test #'string-equal :count 2 :from-end t)
+ #(("Love") ("LOve")))
+(equalp (delete "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test-not (complement #'string-equal)
+ :count 2 :from-end t)
+ #(("Love") ("LOve")))
+(equalp (delete "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test #'string-equal :start 1 :end 3)
+ #(("Love") ("LOVE")))
+(equalp (delete "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test-not (complement #'string-equal) :start 1 :end 3)
+ #(("Love") ("LOVE")))
+(equalp (delete "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test #'string-equal :count 1 :start 1 :end 3)
+ #(("Love") ("LOVe") ("LOVE")))
+(equalp (delete "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test-not (complement #'string-equal)
+ :count 1 :start 1 :end 3)
+ #(("Love") ("LOVe") ("LOVE")))
+(equalp (delete "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test #'string-equal :count 1 :from-end t
+ :start 1 :end 3)
+ #(("Love") ("LOve") ("LOVE")))
+(equalp (delete "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test-not (complement #'string-equal)
+ :count 1 :from-end t :start 1 :end 3)
+ #(("Love") ("LOve") ("LOVE")))
+(equalp (delete "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test #'string-equal :count 10 :from-end t
+ :start 1 :end 3)
+ #(("Love") ("LOVE")))
+(equalp (delete "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :test-not (complement #'string-equal)
+ :count 10 :from-end t :start 1 :end 3)
+ #(("Love") ("LOVE")))
+
+(string= (delete #\a (copy-seq "abcabc")) "bcbc")
+(string= (delete #\a (copy-seq "")) "")
+(string= (delete #\a (copy-seq "xyz")) "xyz")
+(string= (delete #\a (copy-seq "ABCABC")) "ABCABC")
+(string= (delete #\a (copy-seq "ABCABC") :key #'char-downcase) "BCBC")
+(string= (delete #\a (copy-seq "abcabc") :count 1) "bcabc")
+(string= (delete #\a (copy-seq "abcabc") :count 1 :from-end t) "abcbc")
+(string= (delete #\a (copy-seq "abcabc") :count 0) "abcabc")
+(string= (delete #\a (copy-seq "abcabc") :count -10) "abcabc")
+(string= (delete #\a (copy-seq "abcabc") :count 0) "abcabc")
+(string= (delete #\a (copy-seq "abcabc")) "bcbc")
+(string= (delete #\b (copy-seq "abcabc")) "acac")
+(string= (delete #\c (copy-seq "abcabc")) "abab")
+(string= (delete #\a (copy-seq "abcabc") :count 0) "abcabc")
+(string= (delete #\a (copy-seq "abcabc") :count 1) "bcabc")
+(string= (delete #\a (copy-seq "abcabc") :count 1 :from-end t) "abcbc")
+(string= (delete #\a (copy-seq "abcabc") :count 2) "bcbc")
+(string= (delete #\a (copy-seq "abcabc") :count 2 :from-end t) "bcbc")
+(string= (delete #\a (copy-seq "abcabc") :count 3) "bcbc")
+(string= (delete #\a (copy-seq "abcabc") :count 3 :from-end t) "bcbc")
+(string= (delete #\a (copy-seq "abcabc") :count 4) "bcbc")
+(string= (delete #\a (copy-seq "abcabc") :count 4 :from-end t) "bcbc")
+(string= (delete #\a (copy-seq "abcabc") :count -1) "abcabc")
+(string= (delete #\a (copy-seq "abcabc") :count -10) "abcabc")
+(string= (delete #\a (copy-seq "abcabc") :count -100) "abcabc")
+(string= (delete #\a (copy-seq "abcabcabcabc") :start 1) "abcbcbcbc")
+(string= (delete #\a (copy-seq "abcabcabcabc") :start 1 :count 1) "abcbcabcabc")
+(string= (delete #\a (copy-seq "abcabcabcabc") :start 1 :count 2) "abcbcbcabc")
+(string= (delete #\a (copy-seq "abcabcabcabc") :start 1 :end nil :count 2)
+ "abcbcbcabc")
+(string= (delete #\a (copy-seq "abcabcabcabc") :start 1 :end 8) "abcbcbcabc")
+(string= (delete #\a (copy-seq "abcabcabcabc") :start 1 :end 8 :count 1)
+ "abcbcabcabc")
+(string= (delete #\a (copy-seq "abcabcabcabc")
+ :start 1 :end 8 :count 1 :from-end t)
+ "abcabcbcabc")
+(string= (delete #\a (copy-seq "abcabcabcabc")
+ :start 1 :end 8 :count 0 :from-end t)
+ "abcabcabcabc")
+(string= (delete #\a (copy-seq "abcabcabcabc")
+ :start 1 :end 8 :count -100 :from-end t)
+ "abcabcabcabc")
+(string= (delete #\a (copy-seq "abcabcabcabc") :start 1 :end 1)
+ "abcabcabcabc")
+(string= (delete #\a (copy-seq "abcabcabcabc") :start 2 :end 2) "abcabcabcabc")
+(string= (delete #\a (copy-seq "abcabcabcabc") :start 12 :end 12) "abcabcabcabc")
+(equal (delete 0 #*0101) #*11)
+(equal (delete 0 #*01010101 :count 1) #*1010101)
+(equal (delete 0 #*01010101 :count 1 :from-end t) #*0101011)
+(equal (delete 0 #*01010101 :start 1) #*01111)
+(equal (delete 0 #*01010101 :start 1 :end nil) #*01111)
+(equal (delete 0 #*01010101 :start 1 :end 6) #*011101)
+(equal (delete 0 #*01010101 :start 1 :end 6 :count 1) #*0110101)
+(equal (delete 0 #*01010101 :start 1 :end 6 :count 1 :from-end t) #*0101101)
+(equal (delete 0 #*01010101
+ :start 1 :end 6 :count 1 :from-end t
+ :test #'(lambda (a b) (declare (ignore a)) (oddp b)))
+ #*0101001)
+(equal (delete 0 #*01010101
+ :start 1 :end 6 :count 1 :from-end t
+ :test-not #'(lambda (a b) (declare (ignore a)) (evenp b)))
+ #*0101001)
+(equal (delete 0 #*01010101
+ :start 1 :end 6 :count 1 :from-end t
+ :test #'(lambda (a b) (declare (ignore a)) (evenp b)))
+ #*0101101)
+(equal (delete 0 #*01010101
+ :start 1 :end 6 :count 1 :from-end t
+ :test-not #'(lambda (a b) (declare (ignore a)) (oddp b)))
+ #*0101101)
+(equal (delete 0 #*01010101
+ :start 1 :end 6 :count 1 :from-end t
+ :key #'(lambda (arg) (* arg 10))
+ :test #'(lambda (a b) (declare (ignore a)) (> b 1)))
+ #*0101001)
+
+
+(equal (delete-if #'(lambda (arg) (eql arg 'a)) (list 'a 'b 'c 'a 'b 'c))
+ '(b c b c))
+(equal (delete-if #'(lambda (arg) (eql arg 'b)) (list 'a 'b 'c 'a 'b 'c))
+ '(a c a c))
+(equal (delete-if #'(lambda (arg) (eql arg 'c)) (list 'a 'b 'c 'a 'b 'c))
+ '(a b a b))
+(equal (delete-if #'(lambda (arg) (eql arg 'a)) (list 'a 'a 'a)) '())
+(equal (delete-if #'(lambda (arg) (eql arg 'z)) (list 'a 'b 'c)) '(a b c))
+(equal (delete-if #'(lambda (arg) (eql arg 'a)) '()) '())
+(equal (delete-if #'(lambda (arg) (eql arg 'a)) (list 'a 'b 'c 'a 'b 'c)
+ :count 0) '(a b c a b c))
+(equal (delete-if #'(lambda (arg) (eql arg 'a)) (list 'a 'b 'c 'a 'b 'c)
+ :count 1) '(b c a b c))
+(equal (delete-if #'(lambda (arg) (eql arg 'a)) (list 'a 'b 'c 'a 'b 'c)
+ :count 1 :from-end t) '(a b c b c))
+(equal (delete-if #'(lambda (arg) (eql arg 'a)) (list 'a 'b 'c 'a 'b 'c)
+ :count 2) '(b c b c))
+(equal (delete-if #'(lambda (arg) (eql arg 'a)) (list 'a 'b 'c 'a 'b 'c)
+ :count 2 :from-end t) '(b c b c))
+(equal (delete-if #'(lambda (arg) (eql arg 'a)) (list 'a 'b 'c 'a 'b 'c)
+ :count 3) '(b c b c))
+(equal (delete-if #'(lambda (arg) (eql arg 'a)) (list 'a 'b 'c 'a 'b 'c)
+ :count 3 :from-end t) '(b c b c))
+(equal (delete-if #'(lambda (arg) (eql arg 'a)) (list 'a 'b 'c 'a 'b 'c)
+ :count 4) '(b c b c))
+(equal (delete-if #'(lambda (arg) (eql arg 'a)) (list 'a 'b 'c 'a 'b 'c)
+ :count 4 :from-end t) '(b c b c))
+(equal (delete-if #'(lambda (arg) (eql arg 'a)) (list 'a 'b 'c 'a 'b 'c)
+ :count -1) '(a b c a b c))
+(equal (delete-if #'(lambda (arg) (eql arg 'a)) (list 'a 'b 'c 'a 'b 'c)
+ :count -10) '(a b c a b c))
+(equal (delete-if #'(lambda (arg) (eql arg 'a)) (list 'a 'b 'c 'a 'b 'c)
+ :count -100) '(a b c a b c))
+(equal (delete-if #'(lambda (arg) (eql arg 'a))
+ (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1)
+ '(a b c b c b c b c))
+(equal (delete-if #'(lambda (arg) (eql arg 'a))
+ (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :count 1)
+ '(a b c b c a b c a b c))
+(equal (delete-if #'(lambda (arg) (eql arg 'a))
+ (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :count 2)
+ '(a b c b c b c a b c))
+(equal (delete-if #'(lambda (arg) (eql arg 'a))
+ (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :end nil :count 2)
+ '(a b c b c b c a b c))
+(equal (delete-if #'(lambda (arg) (eql arg 'a))
+ (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :end 8)
+ '(a b c b c b c a b c))
+(equal (delete-if #'(lambda (arg) (eql arg 'a))
+ (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :end 8 :count 1)
+ '(a b c b c a b c a b c))
+(equal (delete-if #'(lambda (arg) (eql arg 'a))
+ (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :end 8 :count 1 :from-end t)
+ '(a b c a b c b c a b c))
+(equal (delete-if #'(lambda (arg) (eql arg 'a))
+ (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :end 8 :count 0 :from-end t)
+ '(a b c a b c a b c a b c))
+(equal (delete-if #'(lambda (arg) (eql arg 'a))
+ (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :end 8 :count -100 :from-end t)
+ '(a b c a b c a b c a b c))
+(equal (delete-if #'(lambda (arg) (eql arg 'a))
+ (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :end 1)
+ '(a b c a b c a b c a b c))
+(equal (delete-if #'(lambda (arg) (eql arg 'a))
+ (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 2 :end 2)
+ '(a b c a b c a b c a b c))
+(equal (delete-if #'(lambda (arg) (eql arg 'a))
+ (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 12 :end 12)
+ '(a b c a b c a b c a b c))
+(equal (delete-if #'(lambda (arg) (eql arg 'a))
+ (list '(a) '(b) '(c) '(a) '(b) '(c)) :key #'car)
+ '((b) (c) (b) (c)))
+(equal (delete-if #'(lambda (arg) (eql arg 'a))
+ (list '(a . b) '(b . c) '(c . a)
+ '(a . b) '(b . c) '(c . a))
+ :key #'cdr)
+ '((a . b) (b . c) (a . b) (b . c)))
+(equal (delete-if #'(lambda (arg) (eql arg "love"))
+ (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car)
+ '(("Love") ("LOve") ("LOVe") ("LOVE")))
+(equal (delete-if #'(lambda (arg) (eql arg "love"))
+ (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count -10)
+ '(("Love") ("LOve") ("LOVe") ("LOVE")))
+(equal (delete-if #'(lambda (arg) (string-equal arg "love"))
+ (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car)
+ '())
+(equal (delete-if #'(lambda (arg) (string-equal arg "love"))
+ (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count 1)
+ '(("LOve") ("LOVe") ("LOVE")))
+(equal (delete-if #'(lambda (arg) (string-equal arg "love"))
+ (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count 1 :from-end t)
+ '(("Love") ("LOve") ("LOVe")))
+(equal (delete-if #'(lambda (arg) (string-equal arg "love"))
+ (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count 2 :from-end t)
+ '(("Love") ("LOve")))
+(equal (delete-if #'(lambda (arg) (string-equal arg "love"))
+ (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :start 1 :end 3)
+ '(("Love") ("LOVE")))
+(equal (delete-if #'(lambda (arg) (string-equal arg "love"))
+ (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count 1 :start 1 :end 3)
+ '(("Love") ("LOVe") ("LOVE")))
+(equal (delete-if #'(lambda (arg) (string-equal arg "love"))
+ (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count 1 :from-end t
+ :start 1 :end 3)
+ '(("Love") ("LOve") ("LOVE")))
+(equal (delete-if #'(lambda (arg) (string-equal arg "love"))
+ (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count 10 :from-end t :start 1 :end 3)
+ '(("Love") ("LOVE")))
+
+
+(equalp (delete-if #'(lambda (arg) (eql arg 'a))
+ (vector 'a 'b 'c 'a 'b 'c)) #(b c b c))
+(equalp (delete-if #'(lambda (arg) (eql arg 'b))
+ (vector 'a 'b 'c 'a 'b 'c)) #(a c a c))
+(equalp (delete-if #'(lambda (arg) (eql arg 'c))
+ (vector 'a 'b 'c 'a 'b 'c)) #(a b a b))
+(equalp (delete-if #'(lambda (arg) (eql arg 'a))
+ (vector 'a 'a 'a)) #())
+(equalp (delete-if #'(lambda (arg) (eql arg 'z))
+ (vector 'a 'b 'c)) #(a b c))
+(equalp (delete-if #'(lambda (arg) (eql arg 'a)) #()) #())
+(equalp (delete-if #'(lambda (arg) (eql arg 'a))
+ (vector 'a 'b 'c 'a 'b 'c) :count 0) #(a b c a b c))
+(equalp (delete-if #'(lambda (arg) (eql arg 'a))
+ (vector 'a 'b 'c 'a 'b 'c) :count 1) #(b c a b c))
+(equalp (delete-if #'(lambda (arg) (eql arg 'a))
+ (vector 'a 'b 'c 'a 'b 'c) :count 1 :from-end t) #(a b c b c))
+(equalp (delete-if #'(lambda (arg) (eql arg 'a))
+ (vector 'a 'b 'c 'a 'b 'c) :count 2) #(b c b c))
+(equalp (delete-if #'(lambda (arg) (eql arg 'a))
+ (vector 'a 'b 'c 'a 'b 'c) :count 2 :from-end t) #(b c b c))
+(equalp (delete-if #'(lambda (arg) (eql arg 'a))
+ (vector 'a 'b 'c 'a 'b 'c) :count 3) #(b c b c))
+(equalp (delete-if #'(lambda (arg) (eql arg 'a))
+ (vector 'a 'b 'c 'a 'b 'c) :count 3 :from-end t) #(b c b c))
+(equalp (delete-if #'(lambda (arg) (eql arg 'a))
+ (vector 'a 'b 'c 'a 'b 'c) :count 4) #(b c b c))
+(equalp (delete-if #'(lambda (arg) (eql arg 'a))
+ (vector 'a 'b 'c 'a 'b 'c) :count 4 :from-end t) #(b c b c))
+(equalp (delete-if #'(lambda (arg) (eql arg 'a))
+ (vector 'a 'b 'c 'a 'b 'c) :count -1) #(a b c a b c))
+(equalp (delete-if #'(lambda (arg) (eql arg 'a))
+ (vector 'a 'b 'c 'a 'b 'c) :count -10) #(a b c a b c))
+(equalp (delete-if #'(lambda (arg) (eql arg 'a))
+ (vector 'a 'b 'c 'a 'b 'c) :count -100) #(a b c a b c))
+(equalp (delete-if #'(lambda (arg) (eql arg 'a))
+ (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1)
+ #(a b c b c b c b c))
+(equalp (delete-if #'(lambda (arg) (eql arg 'a))
+ (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :count 1)
+ #(a b c b c a b c a b c))
+(equalp (delete-if #'(lambda (arg) (eql arg 'a))
+ (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :count 2)
+ #(a b c b c b c a b c))
+(equalp (delete-if #'(lambda (arg) (eql arg 'a))
+ (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :end nil :count 2)
+ #(a b c b c b c a b c))
+(equalp (delete-if #'(lambda (arg) (eql arg 'a))
+ (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :end 8)
+ #(a b c b c b c a b c))
+(equalp (delete-if #'(lambda (arg) (eql arg 'a))
+ (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :end 8 :count 1)
+ #(a b c b c a b c a b c))
+(equalp (delete-if #'(lambda (arg) (eql arg 'a))
+ (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :end 8 :count 1 :from-end t)
+ #(a b c a b c b c a b c))
+(equalp (delete-if #'(lambda (arg) (eql arg 'a))
+ (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :end 8 :count 0 :from-end t)
+ #(a b c a b c a b c a b c))
+(equalp (delete-if #'(lambda (arg) (eql arg 'a))
+ (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :end 8 :count -100 :from-end t)
+ #(a b c a b c a b c a b c))
+(equalp (delete-if #'(lambda (arg) (eql arg 'a))
+ (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :end 1)
+ #(a b c a b c a b c a b c))
+(equalp (delete-if #'(lambda (arg) (eql arg 'a))
+ (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 2 :end 2)
+ #(a b c a b c a b c a b c))
+(equalp (delete-if #'(lambda (arg) (eql arg 'a))
+ (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 12 :end 12)
+ #(a b c a b c a b c a b c))
+(equalp (delete-if #'(lambda (arg) (eql arg 'a))
+ (vector '(a) '(b) '(c) '(a) '(b) '(c)) :key #'car)
+ #((b) (c) (b) (c)))
+(equalp (delete-if #'(lambda (arg) (eql arg 'a))
+ (vector '(a . b) '(b . c) '(c . a)
+ '(a . b) '(b . c) '(c . a))
+ :key #'cdr)
+ #((a . b) (b . c) (a . b) (b . c)))
+(equalp (delete-if #'(lambda (arg) (eql arg "love"))
+ (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car)
+ #(("Love") ("LOve") ("LOVe") ("LOVE")))
+(equalp (delete-if #'(lambda (arg) (eql arg "love"))
+ (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count -10)
+ #(("Love") ("LOve") ("LOVe") ("LOVE")))
+(equalp (delete-if #'(lambda (arg) (string-equal arg "love"))
+ (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car)
+ #())
+(equalp (delete-if #'(lambda (arg) (string-equal arg "love"))
+ (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car)
+ #())
+(equalp (delete-if #'(lambda (arg) (string-equal arg "love"))
+ (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count 1)
+ #(("LOve") ("LOVe") ("LOVE")))
+(equalp (delete-if #'(lambda (arg) (string-equal arg "love"))
+ (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count 1)
+ #(("LOve") ("LOVe") ("LOVE")))
+(equalp (delete-if #'(lambda (arg) (string-equal arg "love"))
+ (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count 1 :from-end t)
+ #(("Love") ("LOve") ("LOVe")))
+(equalp (delete-if #'(lambda (arg) (string-equal arg "love"))
+ (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count 1 :from-end t)
+ #(("Love") ("LOve") ("LOVe")))
+(equalp (delete-if #'(lambda (arg) (string-equal arg "love"))
+ (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count 2 :from-end t)
+ #(("Love") ("LOve")))
+(equalp (delete-if #'(lambda (arg) (string-equal arg "love"))
+ (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count 2 :from-end t)
+ #(("Love") ("LOve")))
+(equalp (delete-if #'(lambda (arg) (string-equal arg "love"))
+ (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :start 1 :end 3)
+ #(("Love") ("LOVE")))
+(equalp (delete-if #'(lambda (arg) (string-equal arg "love"))
+ (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count 1 :start 1 :end 3)
+ #(("Love") ("LOVe") ("LOVE")))
+(equalp (delete-if #'(lambda (arg) (string-equal arg "love"))
+ (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count 1 :from-end t
+ :start 1 :end 3)
+ #(("Love") ("LOve") ("LOVE")))
+(equalp (delete-if #'(lambda (arg) (string-equal arg "love"))
+ (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count 10 :from-end t
+ :start 1 :end 3)
+ #(("Love") ("LOVE")))
+
+(string= (delete-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc"))
+ "bcbc")
+(string= (delete-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "")) "")
+(string= (delete-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "xyz"))
+ "xyz")
+(string= (delete-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "ABCABC")
+ :key #'char-downcase) "BCBC")
+(string= (delete-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc")
+ :count 1) "bcabc")
+(string= (delete-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc")
+ :count 1 :from-end t) "abcbc")
+(string= (delete-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc")
+ :count 0) "abcabc")
+(string= (delete-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc")
+ :count -10) "abcabc")
+(string= (delete-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc")
+ :count 0) "abcabc")
+(string= (delete-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc"))
+ "bcbc")
+(string= (delete-if #'(lambda (arg) (string-equal arg #\b)) (copy-seq "abcabc"))
+ "acac")
+(string= (delete-if #'(lambda (arg) (string-equal arg #\c)) (copy-seq "abcabc"))
+ "abab")
+(string= (delete-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc")
+ :count 0) "abcabc")
+(string= (delete-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc")
+ :count 1) "bcabc")
+(string= (delete-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc")
+ :count 1 :from-end t) "abcbc")
+(string= (delete-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc")
+ :count 2) "bcbc")
+(string= (delete-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc")
+ :count 2 :from-end t) "bcbc")
+(string= (delete-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc")
+ :count 3) "bcbc")
+(string= (delete-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc")
+ :count 3 :from-end t) "bcbc")
+(string= (delete-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc")
+ :count 4) "bcbc")
+(string= (delete-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc")
+ :count 4 :from-end t) "bcbc")
+(string= (delete-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc")
+ :count -1) "abcabc")
+(string= (delete-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc")
+ :count -10) "abcabc")
+(string= (delete-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc")
+ :count -100) "abcabc")
+(string= (delete-if #'(lambda (arg) (string-equal arg #\a))
+ (copy-seq "abcabcabcabc") :start 1) "abcbcbcbc")
+(string= (delete-if #'(lambda (arg) (string-equal arg #\a))
+ (copy-seq "abcabcabcabc") :start 1 :count 1) "abcbcabcabc")
+(string= (delete-if #'(lambda (arg) (eql arg #\a)) (copy-seq "abcabcabcabc")
+ :start 1 :count 2)
+ "abcbcbcabc")
+(string= (delete-if #'(lambda (arg) (eql arg #\a)) (copy-seq "abcabcabcabc")
+ :start 1 :end nil :count 2)
+ "abcbcbcabc")
+(string= (delete-if #'(lambda (arg) (eql arg #\a)) (copy-seq "abcabcabcabc")
+ :start 1 :end 8) "abcbcbcabc")
+(string= (delete-if #'(lambda (arg) (eql arg #\a)) (copy-seq "abcabcabcabc")
+ :start 1 :end 8 :count 1)
+ "abcbcabcabc")
+(string= (delete-if #'(lambda (arg) (eql arg #\a)) (copy-seq "abcabcabcabc")
+ :start 1 :end 8 :count 1 :from-end t)
+ "abcabcbcabc")
+(string= (delete-if #'(lambda (arg) (eql arg #\a)) (copy-seq "abcabcabcabc")
+ :start 1 :end 8 :count 0 :from-end t)
+ "abcabcabcabc")
+(string= (delete-if #'(lambda (arg) (eql arg #\a)) (copy-seq "abcabcabcabc")
+ :start 1 :end 8 :count -100 :from-end t)
+ "abcabcabcabc")
+(string= (delete-if #'(lambda (arg) (eql arg #\a)) (copy-seq "abcabcabcabc")
+ :start 1 :end 1)
+ "abcabcabcabc")
+(string= (delete-if #'(lambda (arg) (eql arg #\a)) (copy-seq "abcabcabcabc")
+ :start 2 :end 2) "abcabcabcabc")
+(string= (delete-if #'(lambda (arg) (eql arg #\a)) (copy-seq "abcabcabcabc")
+ :start 12 :end 12) "abcabcabcabc")
+(equal (delete-if #'zerop #*0101) #*11)
+(equal (delete-if #'zerop #*01010101 :count 1) #*1010101)
+(equal (delete-if #'zerop #*01010101 :count 1 :from-end t) #*0101011)
+(equal (delete-if #'zerop #*01010101 :start 1) #*01111)
+(equal (delete-if #'zerop #*01010101 :start 1 :end nil) #*01111)
+(equal (delete-if #'zerop #*01010101 :start 1 :end 6) #*011101)
+(equal (delete-if #'zerop #*01010101 :start 1 :end 6 :count 1) #*0110101)
+(equal (delete-if #'zerop #*01010101 :start 1 :end 6 :count 1 :from-end t)
+ #*0101101)
+(equal (delete-if #'oddp #*01010101 :start 1 :end 6 :count 1 :from-end t)
+ #*0101001)
+(equal (delete-if #'evenp #*01010101 :start 1 :end 6 :count 1 :from-end t)
+ #*0101101)
+(equal (delete-if #'plusp #*01010101
+ :start 1 :end 6 :count 1 :from-end t
+ :key #'(lambda (arg) (* arg 10)))
+ #*0101001)
+
+
+(equal (delete-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (list 'a 'b 'c 'a 'b 'c))
+ '(b c b c))
+(equal (delete-if-not #'(lambda (arg) (not (eql arg 'b)))
+ (list 'a 'b 'c 'a 'b 'c))
+ '(a c a c))
+(equal (delete-if-not #'(lambda (arg) (not (eql arg 'c)))
+ (list 'a 'b 'c 'a 'b 'c))
+ '(a b a b))
+(equal (delete-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (list 'a 'a 'a)) '())
+(equal (delete-if-not #'(lambda (arg) (not (eql arg 'z)))
+ (list 'a 'b 'c)) '(a b c))
+(equal (delete-if-not #'(lambda (arg) (not (eql arg 'a))) '()) '())
+(equal (delete-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (list 'a 'b 'c 'a 'b 'c) :count 0) '(a b c a b c))
+(equal (delete-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (list 'a 'b 'c 'a 'b 'c) :count 1) '(b c a b c))
+(equal (delete-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (list 'a 'b 'c 'a 'b 'c) :count 1 :from-end t)
+ '(a b c b c))
+(equal (delete-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (list 'a 'b 'c 'a 'b 'c) :count 2)
+ '(b c b c))
+(equal (delete-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (list 'a 'b 'c 'a 'b 'c) :count 2 :from-end t)
+ '(b c b c))
+(equal (delete-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (list 'a 'b 'c 'a 'b 'c) :count 3)
+ '(b c b c))
+(equal (delete-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (list 'a 'b 'c 'a 'b 'c) :count 3 :from-end t)
+ '(b c b c))
+(equal (delete-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (list 'a 'b 'c 'a 'b 'c) :count 4)
+ '(b c b c))
+(equal (delete-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (list 'a 'b 'c 'a 'b 'c) :count 4 :from-end t)
+ '(b c b c))
+(equal (delete-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (list 'a 'b 'c 'a 'b 'c) :count -1)
+ '(a b c a b c))
+(equal (delete-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (list 'a 'b 'c 'a 'b 'c) :count -10)
+ '(a b c a b c))
+(equal (delete-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (list 'a 'b 'c 'a 'b 'c) :count -100)
+ '(a b c a b c))
+(equal (delete-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1)
+ '(a b c b c b c b c))
+(equal (delete-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :count 1)
+ '(a b c b c a b c a b c))
+(equal (delete-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :count 2)
+ '(a b c b c b c a b c))
+(equal (delete-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :end nil :count 2)
+ '(a b c b c b c a b c))
+(equal (delete-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :end 8)
+ '(a b c b c b c a b c))
+(equal (delete-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :end 8 :count 1)
+ '(a b c b c a b c a b c))
+(equal (delete-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :end 8 :count 1 :from-end t)
+ '(a b c a b c b c a b c))
+(equal (delete-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :end 8 :count 0 :from-end t)
+ '(a b c a b c a b c a b c))
+(equal (delete-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :end 8 :count -100 :from-end t)
+ '(a b c a b c a b c a b c))
+(equal (delete-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :end 1)
+ '(a b c a b c a b c a b c))
+(equal (delete-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 2 :end 2)
+ '(a b c a b c a b c a b c))
+(equal (delete-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 12 :end 12)
+ '(a b c a b c a b c a b c))
+(equal (delete-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (list '(a) '(b) '(c) '(a) '(b) '(c)) :key #'car)
+ '((b) (c) (b) (c)))
+(equal (delete-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (list '(a . b) '(b . c) '(c . a)
+ '(a . b) '(b . c) '(c . a))
+ :key #'cdr)
+ '((a . b) (b . c) (a . b) (b . c)))
+(equal (delete-if-not #'(lambda (arg) (not (eql arg "love")))
+ (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car)
+ '(("Love") ("LOve") ("LOVe") ("LOVE")))
+(equal (delete-if-not #'(lambda (arg) (not (eql arg "love")))
+ (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count -10)
+ '(("Love") ("LOve") ("LOVe") ("LOVE")))
+(equal (delete-if-not #'(lambda (arg) (not (string-equal arg "love")))
+ (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car)
+ '())
+(equal (delete-if-not #'(lambda (arg) (not (string-equal arg "love")))
+ (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count 1)
+ '(("LOve") ("LOVe") ("LOVE")))
+(equal (delete-if-not #'(lambda (arg) (not (string-equal arg "love")))
+ (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count 1 :from-end t)
+ '(("Love") ("LOve") ("LOVe")))
+(equal (delete-if-not #'(lambda (arg) (not (string-equal arg "love")))
+ (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count 2 :from-end t)
+ '(("Love") ("LOve")))
+(equal (delete-if-not #'(lambda (arg) (not (string-equal arg "love")))
+ (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :start 1 :end 3)
+ '(("Love") ("LOVE")))
+(equal (delete-if-not #'(lambda (arg) (not (string-equal arg "love")))
+ (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count 1 :start 1 :end 3)
+ '(("Love") ("LOVe") ("LOVE")))
+(equal (delete-if-not #'(lambda (arg) (not (string-equal arg "love")))
+ (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count 1 :from-end t
+ :start 1 :end 3)
+ '(("Love") ("LOve") ("LOVE")))
+(equal (delete-if-not #'(lambda (arg) (not (string-equal arg "love")))
+ (list '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count 10 :from-end t :start 1 :end 3)
+ '(("Love") ("LOVE")))
+
+
+(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (vector 'a 'b 'c 'a 'b 'c)) #(b c b c))
+(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'b)))
+ (vector 'a 'b 'c 'a 'b 'c)) #(a c a c))
+(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'c)))
+ (vector 'a 'b 'c 'a 'b 'c)) #(a b a b))
+(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (vector 'a 'a 'a)) #())
+(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'z)))
+ (vector 'a 'b 'c)) #(a b c))
+(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'a))) #()) #())
+(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (vector 'a 'b 'c 'a 'b 'c) :count 0) #(a b c a b c))
+(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (vector 'a 'b 'c 'a 'b 'c) :count 1) #(b c a b c))
+(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (vector 'a 'b 'c 'a 'b 'c) :count 1 :from-end t) #(a b c b c))
+(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (vector 'a 'b 'c 'a 'b 'c) :count 2) #(b c b c))
+(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (vector 'a 'b 'c 'a 'b 'c) :count 2 :from-end t) #(b c b c))
+(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (vector 'a 'b 'c 'a 'b 'c) :count 3) #(b c b c))
+(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (vector 'a 'b 'c 'a 'b 'c) :count 3 :from-end t) #(b c b c))
+(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (vector 'a 'b 'c 'a 'b 'c) :count 4) #(b c b c))
+(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (vector 'a 'b 'c 'a 'b 'c) :count 4 :from-end t) #(b c b c))
+(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (vector 'a 'b 'c 'a 'b 'c) :count -1) #(a b c a b c))
+(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (vector 'a 'b 'c 'a 'b 'c) :count -10) #(a b c a b c))
+(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (vector 'a 'b 'c 'a 'b 'c) :count -100) #(a b c a b c))
+(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1)
+ #(a b c b c b c b c))
+(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :count 1)
+ #(a b c b c a b c a b c))
+(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :count 2)
+ #(a b c b c b c a b c))
+(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :end nil :count 2)
+ #(a b c b c b c a b c))
+(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :end 8)
+ #(a b c b c b c a b c))
+(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :end 8 :count 1)
+ #(a b c b c a b c a b c))
+(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :end 8 :count 1 :from-end t)
+ #(a b c a b c b c a b c))
+(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :end 8 :count 0 :from-end t)
+ #(a b c a b c a b c a b c))
+(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 1 :end 8 :count -100 :from-end t)
+ #(a b c a b c a b c a b c))
+(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :end 1)
+ #(a b c a b c a b c a b c))
+(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 2 :end 2)
+ #(a b c a b c a b c a b c))
+(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c)
+ :start 12 :end 12)
+ #(a b c a b c a b c a b c))
+(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (vector '(a) '(b) '(c) '(a) '(b) '(c)) :key #'car)
+ #((b) (c) (b) (c)))
+(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'a)))
+ (vector '(a . b) '(b . c) '(c . a)
+ '(a . b) '(b . c) '(c . a))
+ :key #'cdr)
+ #((a . b) (b . c) (a . b) (b . c)))
+(equalp (delete-if-not #'(lambda (arg) (not (eql arg "love")))
+ (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car)
+ #(("Love") ("LOve") ("LOVe") ("LOVE")))
+(equalp (delete-if-not #'(lambda (arg) (not (eql arg "love")))
+ (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count -10)
+ #(("Love") ("LOve") ("LOVe") ("LOVE")))
+(equalp (delete-if-not #'(lambda (arg) (not (string-equal arg "love")))
+ (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car)
+ #())
+(equalp (delete-if-not #'(lambda (arg) (not (string-equal arg "love")))
+ (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car)
+ #())
+(equalp (delete-if-not #'(lambda (arg) (not (string-equal arg "love")))
+ (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count 1)
+ #(("LOve") ("LOVe") ("LOVE")))
+(equalp (delete-if-not #'(lambda (arg) (not (string-equal arg "love")))
+ (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count 1)
+ #(("LOve") ("LOVe") ("LOVE")))
+(equalp (delete-if-not #'(lambda (arg) (not (string-equal arg "love")))
+ (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count 1 :from-end t)
+ #(("Love") ("LOve") ("LOVe")))
+(equalp (delete-if-not #'(lambda (arg) (not (string-equal arg "love")))
+ (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count 1 :from-end t)
+ #(("Love") ("LOve") ("LOVe")))
+(equalp (delete-if-not #'(lambda (arg) (not (string-equal arg "love")))
+ (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count 2 :from-end t)
+ #(("Love") ("LOve")))
+(equalp (delete-if-not #'(lambda (arg) (not (string-equal arg "love")))
+ (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count 2 :from-end t)
+ #(("Love") ("LOve")))
+(equalp (delete-if-not #'(lambda (arg) (not (string-equal arg "love")))
+ (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :start 1 :end 3)
+ #(("Love") ("LOVE")))
+(equalp (delete-if-not #'(lambda (arg) (not (string-equal arg "love")))
+ (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count 1 :start 1 :end 3)
+ #(("Love") ("LOVe") ("LOVE")))
+(equalp (delete-if-not #'(lambda (arg) (not (string-equal arg "love")))
+ (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count 1 :from-end t
+ :start 1 :end 3)
+ #(("Love") ("LOve") ("LOVE")))
+(equalp (delete-if-not #'(lambda (arg) (not (string-equal arg "love")))
+ (vector '("Love") '("LOve") '("LOVe") '("LOVE"))
+ :key #'car :count 10 :from-end t
+ :start 1 :end 3)
+ #(("Love") ("LOVE")))
+
+(string= (delete-if-not #'(lambda (arg) (not (string-equal arg #\a)))
+ (copy-seq "abcabc"))
+ "bcbc")
+(string= (delete-if-not #'(lambda (arg) (not (string-equal arg #\a)))
+ (copy-seq "")) "")
+(string= (delete-if-not #'(lambda (arg) (not (string-equal arg #\a)))
+ (copy-seq "xyz"))
+ "xyz")
+(string= (delete-if-not #'(lambda (arg) (not (string-equal arg #\a)))
+ (copy-seq "ABCABC")
+ :key #'char-downcase) "BCBC")
+(string= (delete-if-not #'(lambda (arg) (not (string-equal arg #\a)))
+ (copy-seq "abcabc")
+ :count 1) "bcabc")
+(string= (delete-if-not #'(lambda (arg) (not (string-equal arg #\a)))
+ (copy-seq "abcabc")
+ :count 1 :from-end t) "abcbc")
+(string= (delete-if-not #'(lambda (arg) (not (string-equal arg #\a)))
+ (copy-seq "abcabc")
+ :count 0) "abcabc")
+(string= (delete-if-not #'(lambda (arg) (not (string-equal arg #\a)))
+ (copy-seq "abcabc")
+ :count -10) "abcabc")
+(string= (delete-if-not #'(lambda (arg) (not (string-equal arg #\a)))
+ (copy-seq "abcabc")
+ :count 0) "abcabc")
+(string= (delete-if-not #'(lambda (arg) (not (string-equal arg #\a)))
+ (copy-seq "abcabc"))
+ "bcbc")
+(string= (delete-if-not #'(lambda (arg) (not (string-equal arg #\b)))
+ (copy-seq "abcabc"))
+ "acac")
+(string= (delete-if-not #'(lambda (arg) (not (string-equal arg #\c)))
+ (copy-seq "abcabc"))
+ "abab")
+(string= (delete-if-not #'(lambda (arg) (not (string-equal arg #\a)))
+ (copy-seq "abcabc")
+ :count 0) "abcabc")
+(string= (delete-if-not #'(lambda (arg) (not (string-equal arg #\a)))
+ (copy-seq "abcabc")
+ :count 1) "bcabc")
+(string= (delete-if-not #'(lambda (arg) (not (string-equal arg #\a)))
+ (copy-seq "abcabc")
+ :count 1 :from-end t) "abcbc")
+(string= (delete-if-not #'(lambda (arg) (not (string-equal arg #\a)))
+ (copy-seq "abcabc")
+ :count 2) "bcbc")
+(string= (delete-if-not #'(lambda (arg) (not (string-equal arg #\a)))
+ (copy-seq "abcabc")
+ :count 2 :from-end t) "bcbc")
+(string= (delete-if-not #'(lambda (arg) (not (string-equal arg #\a)))
+ (copy-seq "abcabc")
+ :count 3) "bcbc")
+(string= (delete-if-not #'(lambda (arg) (not (string-equal arg #\a)))
+ (copy-seq "abcabc")
+ :count 3 :from-end t) "bcbc")
+(string= (delete-if-not #'(lambda (arg) (not (string-equal arg #\a)))
+ (copy-seq "abcabc")
+ :count 4) "bcbc")
+(string= (delete-if-not #'(lambda (arg) (not (string-equal arg #\a)))
+ (copy-seq "abcabc")
+ :count 4 :from-end t) "bcbc")
+(string= (delete-if-not #'(lambda (arg) (not (string-equal arg #\a)))
+ (copy-seq "abcabc")
+ :count -1) "abcabc")
+(string= (delete-if-not #'(lambda (arg) (not (string-equal arg #\a)))
+ (copy-seq "abcabc")
+ :count -10) "abcabc")
+(string= (delete-if-not #'(lambda (arg) (not (string-equal arg #\a)))
+ (copy-seq "abcabc")
+ :count -100) "abcabc")
+(string= (delete-if-not #'(lambda (arg) (not (string-equal arg #\a)))
+ (copy-seq "abcabcabcabc") :start 1) "abcbcbcbc")
+(string= (delete-if-not #'(lambda (arg) (not (string-equal arg #\a)))
+ (copy-seq "abcabcabcabc") :start 1 :count 1) "abcbcabcabc")
+(string= (delete-if-not #'(lambda (arg) (not (eql arg #\a)))
+ (copy-seq "abcabcabcabc") :start 1 :count 2)
+ "abcbcbcabc")
+(string= (delete-if-not #'(lambda (arg) (not (eql arg #\a)))
+ (copy-seq "abcabcabcabc") :start 1 :end nil :count 2)
+ "abcbcbcabc")
+(string= (delete-if-not #'(lambda (arg) (not (eql arg #\a)))
+ (copy-seq "abcabcabcabc") :start 1 :end 8) "abcbcbcabc")
+(string= (delete-if-not #'(lambda (arg) (not (eql arg #\a)))
+ (copy-seq "abcabcabcabc") :start 1 :end 8 :count 1)
+ "abcbcabcabc")
+(string= (delete-if-not #'(lambda (arg) (not (eql arg #\a)))
+ (copy-seq "abcabcabcabc")
+ :start 1 :end 8 :count 1 :from-end t)
+ "abcabcbcabc")
+(string= (delete-if-not #'(lambda (arg) (not (eql arg #\a)))
+ (copy-seq "abcabcabcabc")
+ :start 1 :end 8 :count 0 :from-end t)
+ "abcabcabcabc")
+(string= (delete-if-not #'(lambda (arg) (not (eql arg #\a)))
+ (copy-seq "abcabcabcabc")
+ :start 1 :end 8 :count -100 :from-end t)
+ "abcabcabcabc")
+(string= (delete-if-not #'(lambda (arg) (not (eql arg #\a)))
+ (copy-seq "abcabcabcabc") :start 1 :end 1)
+ "abcabcabcabc")
+(string= (delete-if-not #'(lambda (arg) (not (eql arg #\a)))
+ (copy-seq "abcabcabcabc")
+ :start 2 :end 2) "abcabcabcabc")
+(string= (delete-if-not #'(lambda (arg) (not (eql arg #\a)))
+ (copy-seq "abcabcabcabc")
+ :start 12 :end 12) "abcabcabcabc")
+(equal (delete-if-not (complement #'zerop) #*0101) #*11)
+(equal (delete-if-not (complement #'zerop) #*01010101 :count 1) #*1010101)
+(equal (delete-if-not (complement #'zerop) #*01010101 :count 1 :from-end t)
+ #*0101011)
+(equal (delete-if-not (complement #'zerop) #*01010101 :start 1) #*01111)
+(equal (delete-if-not (complement #'zerop) #*01010101 :start 1 :end nil) #*01111)
+(equal (delete-if-not (complement #'zerop) #*01010101 :start 1 :end 6) #*011101)
+(equal (delete-if-not (complement #'zerop) #*01010101 :start 1 :end 6 :count 1)
+ #*0110101)
+(equal (delete-if-not (complement #'zerop) #*01010101
+ :start 1 :end 6 :count 1 :from-end t)
+ #*0101101)
+(equal (delete-if-not (complement #'oddp) #*01010101
+ :start 1 :end 6 :count 1 :from-end t)
+ #*0101001)
+(equal (delete-if-not (complement #'evenp)
+ #*01010101 :start 1 :end 6 :count 1 :from-end t)
+ #*0101101)
+(equal (delete-if-not (complement #'plusp) #*01010101
+ :start 1 :end 6 :count 1 :from-end t
+ :key #'(lambda (arg) (* arg 10)))
+ #*0101001)
+
+
+(equal (remove-duplicates "aBcDAbCd" :test #'char-equal :from-end t) "aBcD")
+(equal (remove-duplicates '(a b c b d d e)) '(A C B D E))
+(equal (remove-duplicates '(a b c b d d e) :from-end t) '(A B C D E))
+(equal (remove-duplicates '((foo #\a) (bar #\%) (baz #\A))
+ :test #'char-equal :key #'cadr)
+ '((BAR #\%) (BAZ #\A)))
+(equal (remove-duplicates '((foo #\a) (bar #\%) (baz #\A))
+ :test #'char-equal :key #'cadr :from-end t)
+ '((FOO #\a) (BAR #\%)))
+(let* ((list0 (list 0 1 2 3 4 5 6))
+ (list (delete-duplicates list0 :key #'oddp :start 1 :end 6)))
+ (equal list '(0 4 5 6)))
+
+
+#-CLISP ;Bruno: The tests ignores ANSI CL "remove-duplicates returns a sequence
+ ; that may share with sequence or may be identical to sequence
+ ; if no elements need to be removed."
+(let* ((list0 (list 0 1 2))
+ (list (remove-duplicates list0)))
+ (and (not (eq list0 list))
+ (equal list0 '(0 1 2))
+ (equal list '(0 1 2))))
+(let* ((list0 (list 2 1 0 1 0 1 2))
+ (list (remove-duplicates list0)))
+ (and (not (eq list0 list))
+ (equal list0 '(2 1 0 1 0 1 2))
+ (equal list '(0 1 2))))
+#-CLISP ;Bruno: The tests ignores ANSI CL "remove-duplicates returns a sequence
+ ; that may share with sequence or may be identical to sequence if no
+ ; elements need to be removed."
+(let* ((vector0 (vector 0 1 2))
+ (vector (remove-duplicates vector0)))
+ (and (not (eq vector0 vector))
+ (equalp vector0 #(0 1 2))
+ (equalp vector #(0 1 2))))
+(let* ((vector0 (vector 2 1 0 1 0 1 2))
+ (vector (remove-duplicates vector0)))
+ (and (not (eq vector0 vector))
+ (equalp vector0 #(2 1 0 1 0 1 2))
+ (equalp vector #(0 1 2))))
+
+(equal (remove-duplicates (list 0 1 2 2 3 3 3)) '(0 1 2 3))
+(equal (remove-duplicates (list 0 0 0 2 0 1 1 2 2 2 1 1 1 1 2)) '(0 1 2))
+(equal (remove-duplicates (list 'a 'a 'b 'c 'c)) '(a b c))
+(equal (remove-duplicates (list 0 1 2)) '(0 1 2))
+(equal (remove-duplicates (list 2 0 2 1 1 1 0 0 0 1 2)) '(0 1 2))
+(equal (remove-duplicates (list)) '())
+(equal (remove-duplicates (list '(x . 0) '(y . 1) '(z . 2)
+ '(a . 0) '(b . 1) '(c . 2)) :key #'cdr)
+ '((a . 0) (b . 1) (c . 2)))
+(equal (remove-duplicates (list '(x . 0) '(y . 1) '(z . 2)
+ '(a . 0) '(b . 1) '(c . 2))
+ :key #'cdr
+ :test #'(lambda (a b) (and (oddp a) (oddp b))))
+ '((x . 0) (z . 2) (a . 0) (b . 1) (c . 2)))
+(equal (remove-duplicates (list '(x . 0) '(y . 1) '(z . 2)
+ '(a . 0) '(b . 1) '(c . 2))
+ :key #'cdr
+ :test-not #'(lambda (a b)
+ (not (and (oddp a) (oddp b)))))
+ '((x . 0) (z . 2) (a . 0) (b . 1) (c . 2)))
+(equal (remove-duplicates (list '(x . 0) '(y . 1) '(z . 2)
+ '(a . 0) '(b . 1) '(c . 2))
+ :key #'cdr
+ :test #'(lambda (a b) (and (evenp a) (evenp b))))
+ '((y . 1) (b . 1) (c . 2)))
+(equal (remove-duplicates (list '(x . 0) '(y . 1) '(z . 2)
+ '(a . 0) '(b . 1) '(c . 2))
+ :key #'cdr
+ :test-not #'(lambda (a b)
+ (not (and (evenp a) (evenp b)))))
+ '((y . 1) (b . 1) (c . 2)))
+(equal (remove-duplicates (list 0 1 2 0 1 2 0 1 2 0 1 2) :start 3 :end 9)
+ '(0 1 2 0 1 2 0 1 2))
+(equal (remove-duplicates (list '(0 . 0) '(1 . 1) '(2 . 2)
+ '(0 . 3) '(1 . 4) '(2 . 5)
+ '(0 . 6) '(1 . 7) '(2 . 8)
+ '(0 . 9) '(1 . 10) '(2 . 11)))
+ (list '(0 . 0) '(1 . 1) '(2 . 2)
+ '(0 . 3) '(1 . 4) '(2 . 5)
+ '(0 . 6) '(1 . 7) '(2 . 8)
+ '(0 . 9) '(1 . 10) '(2 . 11)))
+(equal (remove-duplicates (list '(0 . 0) '(1 . 1) '(2 . 2)
+ '(0 . 3) '(1 . 4) '(2 . 5)
+ '(0 . 6) '(1 . 7) '(2 . 8)
+ '(0 . 9) '(1 . 10) '(2 . 11))
+ :key #'car)
+ '((0 . 9) (1 . 10) (2 . 11)))
+(equal (remove-duplicates (list '(0 . 0) '(1 . 1) '(2 . 2)
+ '(0 . 3) '(1 . 4) '(2 . 5)
+ '(0 . 6) '(1 . 7) '(2 . 8)
+ '(0 . 9) '(1 . 10) '(2 . 11))
+ :key #'car :from-end t)
+ (list '(0 . 0) '(1 . 1) '(2 . 2)))
+(equal (remove-duplicates (list '(0 . 0) '(1 . 1) '(2 . 2)
+ '(0 . 3) '(1 . 4) '(2 . 5)
+ '(0 . 6) '(1 . 7) '(2 . 8)
+ '(0 . 9) '(1 . 10) '(2 . 11))
+ :start 3 :key #'car)
+ (list '(0 . 0) '(1 . 1) '(2 . 2)
+ '(0 . 9) '(1 . 10) '(2 . 11)))
+(equal (remove-duplicates (list '(0 . 0) '(1 . 1) '(2 . 2)
+ '(0 . 3) '(1 . 4) '(2 . 5)
+ '(0 . 6) '(1 . 7) '(2 . 8)
+ '(0 . 9) '(1 . 10) '(2 . 11))
+ :start 3 :key #'car :from-end t)
+ (list '(0 . 0) '(1 . 1) '(2 . 2)
+ '(0 . 3) '(1 . 4) '(2 . 5)))
+(equal (remove-duplicates (list '(0 . 0) '(1 . 1) '(2 . 2)
+ '(0 . 3) '(1 . 4) '(2 . 5)
+ '(0 . 6) '(1 . 7) '(2 . 8)
+ '(0 . 9) '(1 . 10) '(2 . 11))
+ :start 3 :end nil :key #'car)
+ (list '(0 . 0) '(1 . 1) '(2 . 2)
+ '(0 . 9) '(1 . 10) '(2 . 11)))
+(equal (remove-duplicates (list '(0 . 0) '(1 . 1) '(2 . 2)
+ '(0 . 3) '(1 . 4) '(2 . 5)
+ '(0 . 6) '(1 . 7) '(2 . 8)
+ '(0 . 9) '(1 . 10) '(2 . 11))
+ :start 3 :end 9 :key #'car)
+ '((0 . 0) (1 . 1) (2 . 2)
+ (0 . 6) (1 . 7) (2 . 8)
+ (0 . 9) (1 . 10) (2 . 11)))
+(equal (remove-duplicates (list '(0 . 0) '(1 . 1) '(2 . 2)
+ '(0 . 3) '(1 . 4) '(2 . 5)
+ '(0 . 6) '(1 . 7) '(2 . 8)
+ '(0 . 9) '(1 . 10) '(2 . 11))
+ :start 3 :end 9 :key #'car :from-end t)
+ (list '(0 . 0) '(1 . 1) '(2 . 2)
+ '(0 . 3) '(1 . 4) '(2 . 5)
+ '(0 . 9) '(1 . 10) '(2 . 11)))
+(equal (remove-duplicates (list "Monday" "Tuesday" "Wednesday" "Thursday"
+ "Friday" "Saturday" "Sunday")
+ :key #'length)
+ (list "Tuesday" "Wednesday" "Saturday" "Sunday"))
+(equal (remove-duplicates (list "Monday" "Tuesday" "Wednesday" "Thursday"
+ "Friday" "Saturday" "Sunday")
+ :key #'(lambda (arg) (char arg 0)) :test #'char=)
+ (list "Monday" "Wednesday" "Thursday" "Friday" "Sunday"))
+(equal (remove-duplicates (list "Monday" "Tuesday" "Wednesday" "Thursday"
+ "Friday" "Saturday" "Sunday")
+ :key #'(lambda (arg) (char arg 0))
+ :test-not (complement #'char=))
+ (list "Monday" "Wednesday" "Thursday" "Friday" "Sunday"))
+(equal (remove-duplicates (list #\a #\b #\c #\A #\B #\C) :key #'char-upcase)
+ '(#\A #\B #\C))
+(equal (remove-duplicates (list #\a #\b #\c #\A #\B #\C)
+ :key #'char-upcase :from-end t)
+ '(#\a #\b #\c))
+(equal (remove-duplicates (list #\a #\b #\c #\A #\B #\C) :test #'char=)
+ (list #\a #\b #\c #\A #\B #\C))
+(equal (remove-duplicates (list #\a #\b #\c #\A #\B #\C)
+ :test-not (complement #'char=))
+ (list #\a #\b #\c #\A #\B #\C))
+(equal (remove-duplicates (list #\a #\b #\c #\A #\B #\C) :test #'char-equal)
+ (list #\A #\B #\C))
+(equal (remove-duplicates (list #\a #\b #\c #\A #\B #\C)
+ :test-not (complement #'char-equal))
+ (list #\A #\B #\C))
+(equal (remove-duplicates (list #\a #\b #\c #\A #\B #\C)
+ :test #'char-equal :from-end t)
+ (list #\a #\b #\c))
+(equal (remove-duplicates (list #\a #\b #\c #\A #\B #\C)
+ :test-not (complement #'char-equal) :from-end t)
+ (list #\a #\b #\c))
+(equal (remove-duplicates (list #\a #\1 #\b #\1 #\2 #\c #\0 #\A #\0 #\B #\C #\9)
+ :key #'alpha-char-p)
+ (list #\C #\9))
+(equal (remove-duplicates (list #\a #\1 #\b #\1 #\2 #\c #\0 #\A #\0 #\B #\C #\9)
+ :key #'alphanumericp)
+ (list #\9))
+(equal (remove-duplicates (list '(#\A . 0) '(#\b . 1) '(#\C . 2)
+ '(#\a . 3) '(#\B . 4) '(#\c . 5)
+ '(#\A . 6) '(#\b . 7) '(#\C . 8)
+ '(#\a . 9) '(#\B . 10) '(#\c . 11)))
+ (list '(#\A . 0) '(#\b . 1) '(#\C . 2)
+ '(#\a . 3) '(#\B . 4) '(#\c . 5)
+ '(#\A . 6) '(#\b . 7) '(#\C . 8)
+ '(#\a . 9) '(#\B . 10) '(#\c . 11)))
+(equal (remove-duplicates (list '(#\A . 0) '(#\b . 1) '(#\C . 2)
+ '(#\a . 3) '(#\B . 4) '(#\c . 5)
+ '(#\A . 6) '(#\b . 7) '(#\C . 8)
+ '(#\a . 9) '(#\B . 10) '(#\c . 11))
+ :key #'car)
+ (list '(#\A . 6) '(#\b . 7) '(#\C . 8)
+ '(#\a . 9) '(#\B . 10) '(#\c . 11)))
+(equal (remove-duplicates (list '(#\A . 0) '(#\b . 1) '(#\C . 2)
+ '(#\a . 3) '(#\B . 4) '(#\c . 5)
+ '(#\A . 6) '(#\b . 7) '(#\C . 8)
+ '(#\a . 9) '(#\B . 10) '(#\c . 11))
+ :key #'car :start 3 :end 9)
+ (list '(#\A . 0) '(#\b . 1) '(#\C . 2)
+ '(#\a . 3) '(#\B . 4) '(#\c . 5)
+ '(#\A . 6) '(#\b . 7) '(#\C . 8)
+ '(#\a . 9) '(#\B . 10) '(#\c . 11)))
+(equal (remove-duplicates (list '(#\A . 0) '(#\b . 1) '(#\C . 2)
+ '(#\a . 3) '(#\B . 4) '(#\c . 5)
+ '(#\A . 6) '(#\b . 7) '(#\C . 8)
+ '(#\a . 9) '(#\B . 10) '(#\c . 11))
+ :key #'car :start 3 :end 9 :test #'char-equal)
+ (list '(#\A . 0) '(#\b . 1) '(#\C . 2)
+ '(#\A . 6) '(#\b . 7) '(#\C . 8)
+ '(#\a . 9) '(#\B . 10) '(#\c . 11)))
+(equal (remove-duplicates (list '(#\A . 0) '(#\b . 1) '(#\C . 2)
+ '(#\a . 3) '(#\B . 4) '(#\c . 5)
+ '(#\A . 6) '(#\b . 7) '(#\C . 8)
+ '(#\a . 9) '(#\B . 10) '(#\c . 11))
+ :key #'car :start 3 :end 9
+ :test-not (complement #'char-equal))
+ (list '(#\A . 0) '(#\b . 1) '(#\C . 2)
+ '(#\A . 6) '(#\b . 7) '(#\C . 8)
+ '(#\a . 9) '(#\B . 10) '(#\c . 11)))
+(equal (remove-duplicates (list '(#\A . 0) '(#\b . 1) '(#\C . 2)
+ '(#\a . 3) '(#\B . 4) '(#\c . 5)
+ '(#\A . 6) '(#\b . 7) '(#\C . 8)
+ '(#\a . 9) '(#\B . 10) '(#\c . 11))
+ :key #'car :start 3 :end 9 :test #'char-equal
+ :from-end t)
+ (list '(#\A . 0) '(#\b . 1) '(#\C . 2)
+ '(#\a . 3) '(#\B . 4) '(#\c . 5)
+ '(#\a . 9) '(#\B . 10) '(#\c . 11)))
+(equal (remove-duplicates (list '(#\A . 0) '(#\b . 1) '(#\C . 2)
+ '(#\a . 3) '(#\B . 4) '(#\c . 5)
+ '(#\A . 6) '(#\b . 7) '(#\C . 8)
+ '(#\a . 9) '(#\B . 10) '(#\c . 11))
+ :key #'car :start 3 :end 9
+ :test-not (complement #'char-equal) :from-end t)
+ (list '(#\A . 0) '(#\b . 1) '(#\C . 2)
+ '(#\a . 3) '(#\B . 4) '(#\c . 5)
+ '(#\a . 9) '(#\B . 10) '(#\c . 11)))
+(equal (remove-duplicates (list '(#\A . 0) '(#\b . 1) '(#\C . 2)
+ '(#\a . 3) '(#\B . 4) '(#\c . 5)
+ '(#\A . 6) '(#\b . 7) '(#\C . 8)
+ '(#\a . 9) '(#\B . 10) '(#\c . 11))
+ :key #'car :start 3)
+ (list '(#\A . 0) '(#\b . 1) '(#\C . 2)
+ '(#\A . 6) '(#\b . 7) '(#\C . 8)
+ '(#\a . 9) '(#\B . 10) '(#\c . 11)))
+(equal (remove-duplicates (list '(#\A . 0) '(#\b . 1) '(#\C . 2)
+ '(#\a . 3) '(#\B . 4) '(#\c . 5)
+ '(#\A . 6) '(#\b . 7) '(#\C . 8)
+ '(#\a . 9) '(#\B . 10) '(#\c . 11))
+ :key #'car :start 3 :end nil)
+ (list '(#\A . 0) '(#\b . 1) '(#\C . 2)
+ '(#\A . 6) '(#\b . 7) '(#\C . 8)
+ '(#\a . 9) '(#\B . 10) '(#\c . 11)))
+(equal (remove-duplicates (list '(#\A . 0) '(#\b . 1) '(#\C . 2)
+ '(#\a . 3) '(#\B . 4) '(#\c . 5)
+ '(#\A . 6) '(#\b . 7) '(#\C . 8)
+ '(#\a . 9) '(#\B . 10) '(#\c . 11))
+ :key #'car :start 3 :from-end t)
+ (list '(#\A . 0) '(#\b . 1) '(#\C . 2)
+ '(#\a . 3) '(#\B . 4) '(#\c . 5)
+ '(#\A . 6) '(#\b . 7) '(#\C . 8)))
+(equal (remove-duplicates (list '(#\A . 0) '(#\b . 1) '(#\C . 2)
+ '(#\a . 3) '(#\B . 4) '(#\c . 5)
+ '(#\A . 6) '(#\b . 7) '(#\C . 8)
+ '(#\a . 9) '(#\B . 10) '(#\c . 11))
+ :key #'car :end 9)
+ (list '(#\a . 3) '(#\B . 4) '(#\c . 5)
+ '(#\A . 6) '(#\b . 7) '(#\C . 8)
+ '(#\a . 9) '(#\B . 10) '(#\c . 11)))
+(equal (remove-duplicates (list '(#\A . 0) '(#\b . 1) '(#\C . 2)
+ '(#\a . 3) '(#\B . 4) '(#\c . 5)
+ '(#\A . 6) '(#\b . 7) '(#\C . 8)
+ '(#\a . 9) '(#\B . 10) '(#\c . 11))
+ :key #'car :end 9 :from-end t)
+ (list '(#\A . 0) '(#\b . 1) '(#\C . 2)
+ '(#\a . 3) '(#\B . 4) '(#\c . 5)
+ '(#\a . 9) '(#\B . 10) '(#\c . 11)))
+(equal (remove-duplicates (list '(#\A . 0) '(#\b . 1) '(#\C . 2)
+ '(#\a . 3) '(#\B . 4) '(#\c . 5)
+ '(#\A . 6) '(#\b . 7) '(#\C . 8)
+ '(#\a . 9) '(#\B . 10) '(#\c . 11))
+ :key #'car :start 0 :end 12 :test #'char-equal)
+ (list '(#\a . 9) '(#\B . 10) '(#\c . 11)))
+(equal (remove-duplicates (list '(#\A . 0) '(#\b . 1) '(#\C . 2)
+ '(#\a . 3) '(#\B . 4) '(#\c . 5)
+ '(#\A . 6) '(#\b . 7) '(#\C . 8)
+ '(#\a . 9) '(#\B . 10) '(#\c . 11))
+ :key #'car :start 0 :end 12
+ :test-not (complement #'char-equal))
+ (list '(#\a . 9) '(#\B . 10) '(#\c . 11)))
+(equal (remove-duplicates (list '(#\A . 0) '(#\b . 1) '(#\C . 2)
+ '(#\a . 3) '(#\B . 4) '(#\c . 5)
+ '(#\A . 6) '(#\b . 7) '(#\C . 8)
+ '(#\a . 9) '(#\B . 10) '(#\c . 11))
+ :key #'car :start 0 :end 12 :test #'char-equal
+ :from-end t)
+ '((#\A . 0) (#\b . 1) (#\C . 2)))
+(equal (remove-duplicates (list '(#\A . 0) '(#\b . 1) '(#\C . 2)
+ '(#\a . 3) '(#\B . 4) '(#\c . 5)
+ '(#\A . 6) '(#\b . 7) '(#\C . 8)
+ '(#\a . 9) '(#\B . 10) '(#\c . 11))
+ :key #'car :start 0 :end 12
+ :test-not (complement #'char-equal) :from-end t)
+ '((#\A . 0) (#\b . 1) (#\C . 2)))
+
+
+(equalp (remove-duplicates (vector 0 1 2 2 3 3 3)) #(0 1 2 3))
+(equalp (remove-duplicates (vector 0 0 0 2 0 1 1 2 2 2 1 1 1 1 2)) #(0 1 2))
+(equalp (remove-duplicates (vector 'a 'a 'b 'c 'c)) #(a b c))
+(equalp (remove-duplicates (vector 0 1 2)) #(0 1 2))
+(equalp (remove-duplicates (vector 2 0 2 1 1 1 0 0 0 1 2)) #(0 1 2))
+(equalp (remove-duplicates (vector)) #())
+(equalp (remove-duplicates (vector '(x . 0) '(y . 1) '(z . 2)
+ '(a . 0) '(b . 1) '(c . 2)) :key #'cdr)
+ #((a . 0) (b . 1) (c . 2)))
+(equalp (remove-duplicates (vector '(x . 0) '(y . 1) '(z . 2)
+ '(a . 0) '(b . 1) '(c . 2))
+ :key #'cdr
+ :test #'(lambda (a b) (and (oddp a) (oddp b))))
+ #((x . 0) (z . 2) (a . 0) (b . 1) (c . 2)))
+(equalp (remove-duplicates (vector '(x . 0) '(y . 1) '(z . 2)
+ '(a . 0) '(b . 1) '(c . 2))
+ :key #'cdr
+ :test-not #'(lambda (a b)
+ (not (and (oddp a) (oddp b)))))
+ #((x . 0) (z . 2) (a . 0) (b . 1) (c . 2)))
+(equalp (remove-duplicates (vector '(x . 0) '(y . 1) '(z . 2)
+ '(a . 0) '(b . 1) '(c . 2))
+ :key #'cdr
+ :test #'(lambda (a b) (and (evenp a) (evenp b))))
+ #((y . 1) (b . 1) (c . 2)))
+(equalp (remove-duplicates (vector '(x . 0) '(y . 1) '(z . 2)
+ '(a . 0) '(b . 1) '(c . 2))
+ :key #'cdr
+ :test-not #'(lambda (a b)
+ (not (and (evenp a) (evenp b)))))
+ #((y . 1) (b . 1) (c . 2)))
+(equalp (remove-duplicates (vector 0 1 2 0 1 2 0 1 2 0 1 2) :start 3 :end 9)
+ #(0 1 2 0 1 2 0 1 2))
+(equalp (remove-duplicates (vector '(0 . 0) '(1 . 1) '(2 . 2)
+ '(0 . 3) '(1 . 4) '(2 . 5)
+ '(0 . 6) '(1 . 7) '(2 . 8)
+ '(0 . 9) '(1 . 10) '(2 . 11)))
+ (vector '(0 . 0) '(1 . 1) '(2 . 2)
+ '(0 . 3) '(1 . 4) '(2 . 5)
+ '(0 . 6) '(1 . 7) '(2 . 8)
+ '(0 . 9) '(1 . 10) '(2 . 11)))
+(equalp (remove-duplicates (vector '(0 . 0) '(1 . 1) '(2 . 2)
+ '(0 . 3) '(1 . 4) '(2 . 5)
+ '(0 . 6) '(1 . 7) '(2 . 8)
+ '(0 . 9) '(1 . 10) '(2 . 11))
+ :key #'car)
+ #((0 . 9) (1 . 10) (2 . 11)))
+(equalp (remove-duplicates (vector '(0 . 0) '(1 . 1) '(2 . 2)
+ '(0 . 3) '(1 . 4) '(2 . 5)
+ '(0 . 6) '(1 . 7) '(2 . 8)
+ '(0 . 9) '(1 . 10) '(2 . 11))
+ :key #'car :from-end t)
+ (vector '(0 . 0) '(1 . 1) '(2 . 2)))
+(equalp (remove-duplicates (vector '(0 . 0) '(1 . 1) '(2 . 2)
+ '(0 . 3) '(1 . 4) '(2 . 5)
+ '(0 . 6) '(1 . 7) '(2 . 8)
+ '(0 . 9) '(1 . 10) '(2 . 11))
+ :start 3 :key #'car)
+ (vector '(0 . 0) '(1 . 1) '(2 . 2)
+ '(0 . 9) '(1 . 10) '(2 . 11)))
+(equalp (remove-duplicates (vector '(0 . 0) '(1 . 1) '(2 . 2)
+ '(0 . 3) '(1 . 4) '(2 . 5)
+ '(0 . 6) '(1 . 7) '(2 . 8)
+ '(0 . 9) '(1 . 10) '(2 . 11))
+ :start 3 :key #'car :from-end t)
+ (vector '(0 . 0) '(1 . 1) '(2 . 2)
+ '(0 . 3) '(1 . 4) '(2 . 5)))
+(equalp (remove-duplicates (vector '(0 . 0) '(1 . 1) '(2 . 2)
+ '(0 . 3) '(1 . 4) '(2 . 5)
+ '(0 . 6) '(1 . 7) '(2 . 8)
+ '(0 . 9) '(1 . 10) '(2 . 11))
+ :start 3 :end nil :key #'car)
+ (vector '(0 . 0) '(1 . 1) '(2 . 2)
+ '(0 . 9) '(1 . 10) '(2 . 11)))
+(equalp (remove-duplicates (vector '(0 . 0) '(1 . 1) '(2 . 2)
+ '(0 . 3) '(1 . 4) '(2 . 5)
+ '(0 . 6) '(1 . 7) '(2 . 8)
+ '(0 . 9) '(1 . 10) '(2 . 11))
+ :start 3 :end 9 :key #'car)
+ #((0 . 0) (1 . 1) (2 . 2)
+ (0 . 6) (1 . 7) (2 . 8)
+ (0 . 9) (1 . 10) (2 . 11)))
+(equalp (remove-duplicates (vector '(0 . 0) '(1 . 1) '(2 . 2)
+ '(0 . 3) '(1 . 4) '(2 . 5)
+ '(0 . 6) '(1 . 7) '(2 . 8)
+ '(0 . 9) '(1 . 10) '(2 . 11))
+ :start 3 :end 9 :key #'car :from-end t)
+ (vector '(0 . 0) '(1 . 1) '(2 . 2)
+ '(0 . 3) '(1 . 4) '(2 . 5)
+ '(0 . 9) '(1 . 10) '(2 . 11)))
+(equalp (remove-duplicates (vector "Monday" "Tuesday" "Wednesday" "Thursday"
+ "Friday" "Saturday" "Sunday")
+ :key #'length)
+ (vector "Tuesday" "Wednesday" "Saturday" "Sunday"))
+(equalp (remove-duplicates (vector "Monday" "Tuesday" "Wednesday" "Thursday"
+ "Friday" "Saturday" "Sunday")
+ :key #'(lambda (arg) (char arg 0)) :test #'char=)
+ (vector "Monday" "Wednesday" "Thursday" "Friday" "Sunday"))
+(equalp (remove-duplicates (vector "Monday" "Tuesday" "Wednesday" "Thursday"
+ "Friday" "Saturday" "Sunday")
+ :key #'(lambda (arg) (char arg 0))
+ :test-not (complement #'char=))
+ (vector "Monday" "Wednesday" "Thursday" "Friday" "Sunday"))
+(equalp (remove-duplicates (vector #\a #\b #\c #\A #\B #\C) :key #'char-upcase)
+ #(#\A #\B #\C))
+(equalp (remove-duplicates (vector #\a #\b #\c #\A #\B #\C)
+ :key #'char-upcase :from-end t)
+ #(#\a #\b #\c))
+(equalp (remove-duplicates (vector #\a #\b #\c #\A #\B #\C) :test #'char=)
+ (vector #\a #\b #\c #\A #\B #\C))
+(equalp (remove-duplicates (vector #\a #\b #\c #\A #\B #\C)
+ :test-not (complement #'char=))
+ (vector #\a #\b #\c #\A #\B #\C))
+(equalp (remove-duplicates (vector #\a #\b #\c #\A #\B #\C) :test #'char-equal)
+ (vector #\A #\B #\C))
+(equalp (remove-duplicates (vector #\a #\b #\c #\A #\B #\C)
+ :test-not (complement #'char-equal))
+ (vector #\A #\B #\C))
+(equalp (remove-duplicates (vector #\a #\b #\c #\A #\B #\C)
+ :test #'char-equal :from-end t)
+ (vector #\a #\b #\c))
+(equalp (remove-duplicates (vector #\a #\b #\c #\A #\B #\C)
+ :test-not (complement #'char-equal) :from-end t)
+ (vector #\a #\b #\c))
+
+(equalp (remove-duplicates
+ (vector #\a #\1 #\b #\1 #\2 #\c #\0 #\A #\0 #\B #\C #\9)
+ :key #'alpha-char-p)
+ (vector #\C #\9))
+(equalp (remove-duplicates
+ (vector #\a #\1 #\b #\1 #\2 #\c #\0 #\A #\0 #\B #\C #\9)
+ :key #'alphanumericp)
+ (vector #\9))
+(equalp (remove-duplicates (vector '(#\A . 0) '(#\b . 1) '(#\C . 2)
+ '(#\a . 3) '(#\B . 4) '(#\c . 5)
+ '(#\A . 6) '(#\b . 7) '(#\C . 8)
+ '(#\a . 9) '(#\B . 10) '(#\c . 11)))
+ (vector '(#\A . 0) '(#\b . 1) '(#\C . 2)
+ '(#\a . 3) '(#\B . 4) '(#\c . 5)
+ '(#\A . 6) '(#\b . 7) '(#\C . 8)
+ '(#\a . 9) '(#\B . 10) '(#\c . 11)))
+(equalp (remove-duplicates (vector '(#\A . 0) '(#\b . 1) '(#\C . 2)
+ '(#\a . 3) '(#\B . 4) '(#\c . 5)
+ '(#\A . 6) '(#\b . 7) '(#\C . 8)
+ '(#\a . 9) '(#\B . 10) '(#\c . 11))
+ :key #'car)
+ (vector '(#\A . 6) '(#\b . 7) '(#\C . 8)
+ '(#\a . 9) '(#\B . 10) '(#\c . 11)))
+(equalp (remove-duplicates (vector '(#\A . 0) '(#\b . 1) '(#\C . 2)
+ '(#\a . 3) '(#\B . 4) '(#\c . 5)
+ '(#\A . 6) '(#\b . 7) '(#\C . 8)
+ '(#\a . 9) '(#\B . 10) '(#\c . 11))
+ :key #'car :start 3 :end 9)
+ (vector '(#\A . 0) '(#\b . 1) '(#\C . 2)
+ '(#\a . 3) '(#\B . 4) '(#\c . 5)
+ '(#\A . 6) '(#\b . 7) '(#\C . 8)
+ '(#\a . 9) '(#\B . 10) '(#\c . 11)))
+(equalp (remove-duplicates (vector '(#\A . 0) '(#\b . 1) '(#\C . 2)
+ '(#\a . 3) '(#\B . 4) '(#\c . 5)
+ '(#\A . 6) '(#\b . 7) '(#\C . 8)
+ '(#\a . 9) '(#\B . 10) '(#\c . 11))
+ :key #'car :start 3 :end 9 :test #'char-equal)
+ (vector '(#\A . 0) '(#\b . 1) '(#\C . 2)
+ '(#\A . 6) '(#\b . 7) '(#\C . 8)
+ '(#\a . 9) '(#\B . 10) '(#\c . 11)))
+(equalp (remove-duplicates (vector '(#\A . 0) '(#\b . 1) '(#\C . 2)
+ '(#\a . 3) '(#\B . 4) '(#\c . 5)
+ '(#\A . 6) '(#\b . 7) '(#\C . 8)
+ '(#\a . 9) '(#\B . 10) '(#\c . 11))
+ :key #'car :start 3 :end 9
+ :test-not (complement #'char-equal))
+ (vector '(#\A . 0) '(#\b . 1) '(#\C . 2)
+ '(#\A . 6) '(#\b . 7) '(#\C . 8)
+ '(#\a . 9) '(#\B . 10) '(#\c . 11)))
+(equalp (remove-duplicates (vector '(#\A . 0) '(#\b . 1) '(#\C . 2)
+ '(#\a . 3) '(#\B . 4) '(#\c . 5)
+ '(#\A . 6) '(#\b . 7) '(#\C . 8)
+ '(#\a . 9) '(#\B . 10) '(#\c . 11))
+ :key #'car :start 3 :end 9 :test #'char-equal
+ :from-end t)
+ (vector '(#\A . 0) '(#\b . 1) '(#\C . 2)
+ '(#\a . 3) '(#\B . 4) '(#\c . 5)
+ '(#\a . 9) '(#\B . 10) '(#\c . 11)))
+(equalp (remove-duplicates (vector '(#\A . 0) '(#\b . 1) '(#\C . 2)
+ '(#\a . 3) '(#\B . 4) '(#\c . 5)
+ '(#\A . 6) '(#\b . 7) '(#\C . 8)
+ '(#\a . 9) '(#\B . 10) '(#\c . 11))
+ :key #'car :start 3 :end 9
+ :test-not (complement #'char-equal)
+ :from-end t)
+ (vector '(#\A . 0) '(#\b . 1) '(#\C . 2)
+ '(#\a . 3) '(#\B . 4) '(#\c . 5)
+ '(#\a . 9) '(#\B . 10) '(#\c . 11)))
+(equalp (remove-duplicates (vector '(#\A . 0) '(#\b . 1) '(#\C . 2)
+ '(#\a . 3) '(#\B . 4) '(#\c . 5)
+ '(#\A . 6) '(#\b . 7) '(#\C . 8)
+ '(#\a . 9) '(#\B . 10) '(#\c . 11))
+ :key #'car :start 3)
+ (vector '(#\A . 0) '(#\b . 1) '(#\C . 2)
+ '(#\A . 6) '(#\b . 7) '(#\C . 8)
+ '(#\a . 9) '(#\B . 10) '(#\c . 11)))
+(equalp (remove-duplicates (vector '(#\A . 0) '(#\b . 1) '(#\C . 2)
+ '(#\a . 3) '(#\B . 4) '(#\c . 5)
+ '(#\A . 6) '(#\b . 7) '(#\C . 8)
+ '(#\a . 9) '(#\B . 10) '(#\c . 11))
+ :key #'car :start 3 :end nil)
+ (vector '(#\A . 0) '(#\b . 1) '(#\C . 2)
+ '(#\A . 6) '(#\b . 7) '(#\C . 8)
+ '(#\a . 9) '(#\B . 10) '(#\c . 11)))
+(equalp (remove-duplicates (vector '(#\A . 0) '(#\b . 1) '(#\C . 2)
+ '(#\a . 3) '(#\B . 4) '(#\c . 5)
+ '(#\A . 6) '(#\b . 7) '(#\C . 8)
+ '(#\a . 9) '(#\B . 10) '(#\c . 11))
+ :key #'car :start 3 :from-end t)
+ (vector '(#\A . 0) '(#\b . 1) '(#\C . 2)
+ '(#\a . 3) '(#\B . 4) '(#\c . 5)
+ '(#\A . 6) '(#\b . 7) '(#\C . 8)))
+(equalp (remove-duplicates (vector '(#\A . 0) '(#\b . 1) '(#\C . 2)
+ '(#\a . 3) '(#\B . 4) '(#\c . 5)
+ '(#\A . 6) '(#\b . 7) '(#\C . 8)
+ '(#\a . 9) '(#\B . 10) '(#\c . 11))
+ :key #'car :end 9)
+ (vector '(#\a . 3) '(#\B . 4) '(#\c . 5)
+ '(#\A . 6) '(#\b . 7) '(#\C . 8)
+ '(#\a . 9) '(#\B . 10) '(#\c . 11)))
+(equalp (remove-duplicates (vector '(#\A . 0) '(#\b . 1) '(#\C . 2)
+ '(#\a . 3) '(#\B . 4) '(#\c . 5)
+ '(#\A . 6) '(#\b . 7) '(#\C . 8)
+ '(#\a . 9) '(#\B . 10) '(#\c . 11))
+ :key #'car :end 9 :from-end t)
+ (vector '(#\A . 0) '(#\b . 1) '(#\C . 2)
+ '(#\a . 3) '(#\B . 4) '(#\c . 5)
+ '(#\a . 9) '(#\B . 10) '(#\c . 11)))
+(equalp (remove-duplicates (vector '(#\A . 0) '(#\b . 1) '(#\C . 2)
+ '(#\a . 3) '(#\B . 4) '(#\c . 5)
+ '(#\A . 6) '(#\b . 7) '(#\C . 8)
+ '(#\a . 9) '(#\B . 10) '(#\c . 11))
+ :key #'car :start 0 :end 12 :test #'char-equal)
+ (vector '(#\a . 9) '(#\B . 10) '(#\c . 11)))
+(equalp (remove-duplicates (vector '(#\A . 0) '(#\b . 1) '(#\C . 2)
+ '(#\a . 3) '(#\B . 4) '(#\c . 5)
+ '(#\A . 6) '(#\b . 7) '(#\C . 8)
+ '(#\a . 9) '(#\B . 10) '(#\c . 11))
+ :key #'car :start 0 :end 12
+ :test-not (complement #'char-equal))
+ (vector '(#\a . 9) '(#\B . 10) '(#\c . 11)))
+(equalp (remove-duplicates (vector '(#\A . 0) '(#\b . 1) '(#\C . 2)
+ '(#\a . 3) '(#\B . 4) '(#\c . 5)
+ '(#\A . 6) '(#\b . 7) '(#\C . 8)
+ '(#\a . 9) '(#\B . 10) '(#\c . 11))
+ :key #'car :start 0 :end 12 :test #'char-equal
+ :from-end t)
+ #((#\A . 0) (#\b . 1) (#\C . 2)))
+(equalp (remove-duplicates (vector '(#\A . 0) '(#\b . 1) '(#\C . 2)
+ '(#\a . 3) '(#\B . 4) '(#\c . 5)
+ '(#\A . 6) '(#\b . 7) '(#\C . 8)
+ '(#\a . 9) '(#\B . 10) '(#\c . 11))
+ :key #'car :start 0 :end 12
+ :test-not (complement #'char-equal) :from-end t)
+ #((#\A . 0) (#\b . 1) (#\C . 2)))
+
+(string= (remove-duplicates (copy-seq "")) "")
+(string= (remove-duplicates (copy-seq "abc")) "abc")
+(string= (remove-duplicates (copy-seq "abcabc")) "abc")
+(string= (remove-duplicates (copy-seq "cbaabc")) "abc")
+(string= (remove-duplicates (copy-seq "cbaabc") :from-end t) "cba")
+(string= (remove-duplicates (copy-seq "cbaabcABCCBA")) "abcCBA")
+(string= (remove-duplicates (copy-seq "cbaabcABCCBA") :from-end t) "cbaABC")
+(string= (remove-duplicates (copy-seq "cbaabcABCCBA") :key #'char-downcase)
+ "CBA")
+(string= (remove-duplicates (copy-seq "cbaabcABCCBA")
+ :key #'char-downcase :from-end t)
+ "cba")
+(string= (remove-duplicates (copy-seq "cbaabcABCCBA") :start 3) "cbaabcCBA")
+(string= (remove-duplicates (copy-seq "cbaabcABCCBA") :start 3 :from-end t)
+ "cbaabcABC")
+(string= (remove-duplicates (copy-seq "cbaabcABCCBA") :start 3 :end 9)
+ "cbaabcABCCBA")
+(string= (remove-duplicates (copy-seq "cbaabcABCCBA")
+ :start 3 :end 9 :key #'char-upcase)
+ "cbaABCCBA")
+(string= (remove-duplicates (copy-seq "cbaabcABCCBA")
+ :start 3 :end 9 :key #'char-upcase :from-end t)
+ "cbaabcCBA")
+(string= (remove-duplicates (copy-seq "cbaabcABCCBA")
+ :start 3 :end 9 :test #'char-equal :from-end t)
+ "cbaabcCBA")
+(string= (remove-duplicates (copy-seq "cbaabcABCCBA")
+ :start 3 :end 9 :test-not (complement #'char-equal)
+ :from-end t)
+ "cbaabcCBA")
+(string= (remove-duplicates (copy-seq "cbaabcABCCBA")
+ :start 3 :end 9 :key #'upper-case-p :test #'eq)
+ "cbacCCBA")
+(string= (remove-duplicates (copy-seq "cbaabcABCCBA")
+ :start 3 :end 9 :key #'upper-case-p :test #'eq
+ :from-end t)
+ "cbaaACBA")
+(equal (remove-duplicates (copy-seq #*0011)) #*01)
+(equal (remove-duplicates (copy-seq #*0110)) #*10)
+(equal (remove-duplicates (copy-seq #*0110) :from-end t) #*01)
+(equal (remove-duplicates (copy-seq #*0110) :start 1) #*010)
+(equal (remove-duplicates (copy-seq #*0001111011000100010)) #*10)
+(equal (remove-duplicates (copy-seq #*0001111011000100010) :from-end t) #*01)
+(equal (remove-duplicates (copy-seq #*)) #*)
+(equal (remove-duplicates (copy-seq #*01)) #*01)
+(equal (remove-duplicates (copy-seq #*10)) #*10)
+(equal (remove-duplicates (copy-seq #*0)) #*0)
+(equal (remove-duplicates (copy-seq #*1)) #*1)
+(equal (remove-duplicates (copy-seq #*1001) :start 1 :end 3) #*101)
+(equal (remove-duplicates (copy-seq #*01011010) :start 2 :end 6) #*011010)
+(equal (remove-duplicates (copy-seq #*01011010) :start 2 :end 6 :from-end t)
+ #*010110)
+(equal (remove-duplicates (copy-seq #*01011010)
+ :start 2 :end 6 :from-end t
+ :key #'(lambda (arg) (char "aA" arg)))
+ #*010110)
+(equal (remove-duplicates (copy-seq #*01011010)
+ :start 2 :end 6 :from-end t
+ :key #'(lambda (arg) (char "aA" arg))
+ :test #'char-equal)
+ #*01010)
+(equal (remove-duplicates (copy-seq #*01011010)
+ :start 2 :end 6 :from-end t
+ :key #'(lambda (arg) (char "aA" arg))
+ :test-not (complement #'char-equal))
+ #*01010)
+(equal (remove-duplicates (copy-seq #*01011010)
+ :start 2 :end 6
+ :key #'(lambda (arg) (char "aA" arg))
+ :test #'char-equal)
+ #*01010)
+(equal (remove-duplicates (copy-seq #*01011010)
+ :start 2 :end 6
+ :key #'(lambda (arg) (char "aA" arg))
+ :test-not (complement #'char-equal))
+ #*01010)
diff --git a/Sacla/tests/must-sequence.patch b/Sacla/tests/must-sequence.patch
new file mode 100644
index 0000000..0c01d53
--- /dev/null
+++ b/Sacla/tests/must-sequence.patch
@@ -0,0 +1,26 @@
+*** sacla/lisp/test/must-sequence.lisp 2004-08-03 08:34:55.000000000 +0200
+--- CLISP/clisp-20040712/sacla-tests/must-sequence.lisp 2004-08-06 03:23:37.000000000 +0200
+***************
+*** 9545,9550 ****
+--- 9545,9553 ----
+ (equal list '(0 4 5 6)))
+
+
++ #-CLISP ; The tests ignores ANSI CL "remove-duplicates returns a sequence that
++ ; may share with sequence or may be identical to sequence if no elements
++ ; need to be removed."
+ (let* ((list0 (list 0 1 2))
+ (list (remove-duplicates list0)))
+ (and (not (eq list0 list))
+***************
+*** 9555,9560 ****
+--- 9558,9566 ----
+ (and (not (eq list0 list))
+ (equal list0 '(2 1 0 1 0 1 2))
+ (equal list '(0 1 2))))
++ #-CLISP ; The tests ignores ANSI CL "remove-duplicates returns a sequence that
++ ; may share with sequence or may be identical to sequence if no elements
++ ; need to be removed."
+ (let* ((vector0 (vector 0 1 2))
+ (vector (remove-duplicates vector0)))
+ (and (not (eq vector0 vector))
diff --git a/Sacla/tests/must-string.lisp b/Sacla/tests/must-string.lisp
new file mode 100644
index 0000000..763d747
--- /dev/null
+++ b/Sacla/tests/must-string.lisp
@@ -0,0 +1,608 @@
+;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
+;; ALL RIGHTS RESERVED.
+;;
+;; $Id: must-string.lisp,v 1.7 2004/02/20 07:23:42 yuji Exp $
+;;
+;; 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.
+;;
+;; 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.
+
+(simple-string-p "")
+(simple-string-p "abc")
+(not (simple-string-p 'not-a-string))
+(let ((str (make-array 3 :element-type 'character :fill-pointer t)))
+ (if (not (simple-vector-p str))
+ (not (simple-string-p str))
+ (simple-string-p str)))
+
+(char= (char "abc" 0) #\a)
+(char= (char "abc" 1) #\b)
+(char= (char "abc" 2) #\c)
+(char= (schar "abc" 0) #\a)
+(char= (schar "abc" 1) #\b)
+(char= (schar "abc" 2) #\c)
+(let ((str (make-array 10
+ :element-type 'character
+ :fill-pointer 3
+ :initial-contents "0123456789")))
+ (and (string= str "012")
+ (char= (char str 3) #\3)
+ (char= (char str 4) #\4)
+ (char= (char str 5) #\5)
+ (char= (char str 6) #\6)
+ (char= (char str 7) #\7)
+ (char= (char str 8) #\8)
+ (char= (char str 9) #\9)
+ (char= (vector-pop str) #\2)))
+
+(string= (string "") "")
+(string= (string "abc") "abc")
+(string= (string "a") "a")
+(string= (string 'abc) "ABC")
+(string= (string 'a) "A")
+(string= (string #\a) "a")
+
+
+(string= (string-upcase "abcde") "ABCDE")
+(string= (string-upcase "Dr. Livingston, I presume?")
+ "DR. LIVINGSTON, I PRESUME?")
+(string= (string-upcase "Dr. Livingston, I presume?" :start 6 :end 10)
+ "Dr. LiVINGston, I presume?")
+(string= (string-upcase 'Kludgy-HASH-Search) "KLUDGY-HASH-SEARCH")
+(string= (string-upcase "abcde" :start 2 :end nil) "abCDE")
+
+(string= (string-downcase "Dr. Livingston, I presume?")
+ "dr. livingston, i presume?")
+(string= (string-downcase 'Kludgy-HASH-Search) "kludgy-hash-search")
+(string= (string-downcase "A FOOL" :start 2 :end nil) "A fool")
+(string= (string-capitalize "elm 13c arthur;fig don't")
+ "Elm 13c Arthur;Fig Don'T")
+(string= (string-capitalize " hello ") " Hello ")
+(string= (string-capitalize
+ "occlUDeD cASEmenTs FOreSTAll iNADVertent DEFenestraTION")
+ "Occluded Casements Forestall Inadvertent Defenestration")
+(string= (string-capitalize 'kludgy-hash-search) "Kludgy-Hash-Search")
+(string= (string-capitalize "DON'T!") "Don'T!") ;not "Don't!"
+(string= (string-capitalize "pipe 13a, foo16c") "Pipe 13a, Foo16c")
+(string= (string-capitalize "a fool" :start 2 :end nil) "a Fool")
+
+(let ((str (copy-seq "0123ABCD890a")))
+ (and (string= (nstring-downcase str :start 5 :end 7) "0123AbcD890a")
+ (string= str "0123AbcD890a")))
+
+(let* ((str0 (copy-seq "abcde"))
+ (str (nstring-upcase str0)))
+ (and (eq str0 str)
+ (string= str "ABCDE")))
+(let* ((str0 (copy-seq "Dr. Livingston, I presume?"))
+ (str (nstring-upcase str0)))
+ (and (eq str0 str)
+ (string= str "DR. LIVINGSTON, I PRESUME?")))
+(let* ((str0 (copy-seq "Dr. Livingston, I presume?"))
+ (str (nstring-upcase str0 :start 6 :end 10)))
+ (and (eq str0 str)
+ (string= str "Dr. LiVINGston, I presume?")))
+
+(let* ((str0 (copy-seq "abcde"))
+ (str (nstring-upcase str0 :start 2 :end nil)))
+ (string= str "abCDE"))
+
+
+
+(let* ((str0 (copy-seq "Dr. Livingston, I presume?"))
+ (str (nstring-downcase str0)))
+ (and (eq str0 str)
+ (string= str "dr. livingston, i presume?")))
+(let* ((str0 (copy-seq "ABCDE"))
+ (str (nstring-downcase str0 :start 2 :end nil)))
+ (string= str "ABcde"))
+
+(let* ((str0 (copy-seq "elm 13c arthur;fig don't"))
+ (str (nstring-capitalize str0)))
+ (and (eq str0 str)
+ (string= str "Elm 13c Arthur;Fig Don'T")))
+
+(let* ((str0 (copy-seq " hello "))
+ (str (nstring-capitalize str0)))
+ (and (eq str0 str)
+ (string= str " Hello ")))
+(let* ((str0 (copy-seq
+ "occlUDeD cASEmenTs FOreSTAll iNADVertent DEFenestraTION"))
+ (str (nstring-capitalize str0)))
+ (and (eq str0 str)
+ (string= str
+ "Occluded Casements Forestall Inadvertent Defenestration")))
+(let* ((str0 (copy-seq "DON'T!"))
+ (str (nstring-capitalize str0)))
+ (and (eq str0 str)
+ (string= str "Don'T!"))) ;not "Don't!"
+(let* ((str0 (copy-seq "pipe 13a, foo16c"))
+ (str (nstring-capitalize str0)))
+ (and (eq str0 str)
+ (string= str "Pipe 13a, Foo16c")))
+(let* ((str0 (copy-seq "a fool"))
+ (str (nstring-capitalize str0 :start 2 :end nil)))
+ (string= str "a Fool"))
+
+
+
+(string= (string-trim "abc" "abcaakaaakabcaaa") "kaaak")
+(string= (string-trim '(#\Space #\Tab #\Newline) " garbanzo beans
+ ") "garbanzo beans")
+(string= (string-trim " (*)" " ( *three (silly) words* ) ")
+ "three (silly) words")
+(string= (string-left-trim "abc" "labcabcabc") "labcabcabc")
+(string= (string-left-trim " (*)" " ( *three (silly) words* ) ")
+ "three (silly) words* ) ")
+(string= (string-right-trim " (*)" " ( *three (silly) words* ) ")
+ " ( *three (silly) words")
+(string= (string-trim "ABC" "abc") "abc")
+(string= (string-trim "AABBCC" "abc") "abc")
+(string= (string-trim "" "abc") "abc")
+(string= (string-trim "ABC" "") "")
+(string= (string-trim "cba" "abc") "")
+(string= (string-trim "cba" "abccba") "")
+(string= (string-trim "ccbbba" "abccba") "")
+(string= (string-trim "cba" "abcxabc") "x")
+(string= (string-trim "xyz" "xxyabcxyyz") "abc")
+(string= (string-trim "CBA" 'abcxabc) "X")
+(string= (string-trim "a" #\a) "")
+
+
+(string= (string-left-trim "ABC" "abc") "abc")
+(string= (string-left-trim "" "abc") "abc")
+(string= (string-left-trim "ABC" "") "")
+(string= (string-left-trim "cba" "abc") "")
+(string= (string-left-trim "cba" "abccba") "")
+(string= (string-left-trim "cba" "abcxabc") "xabc")
+(string= (string-left-trim "xyz" "xxyabcxyz") "abcxyz")
+(string= (string-left-trim "CBA" 'abcxabc) "XABC")
+(string= (string-left-trim "a" #\a) "")
+
+(string= (string-right-trim "ABC" "abc") "abc")
+(string= (string-right-trim "" "abc") "abc")
+(string= (string-right-trim "ABC" "") "")
+(string= (string-right-trim "cba" "abc") "")
+(string= (string-right-trim "cba" "abccba") "")
+(string= (string-right-trim "cba" "abcxabc") "abcx")
+(string= (string-right-trim "xyz" "xxyabcxyz") "xxyabc")
+(string= (string-right-trim "CBA" 'abcxabc) "ABCX")
+(string= (string-right-trim "a" #\a) "")
+
+
+
+(string= (string "already a string") "already a string")
+(string= (string 'elm) "ELM")
+(string= (string #\c) "c")
+
+
+(string= "foo" "foo")
+(not (string= "foo" "Foo"))
+(not (string= "foo" "bar"))
+(string= "together" "frog" :start1 1 :end1 3 :start2 2)
+(string-equal "foo" "Foo")
+(string= "abcd" "01234abcd9012" :start2 5 :end2 9)
+(eql (string< "aaaa" "aaab") 3)
+(eql (string>= "aaaaa" "aaaa") 4)
+(eql (string-not-greaterp "Abcde" "abcdE") 5)
+(eql (string-lessp "012AAAA789" "01aaab6"
+ :start1 3 :end1 7
+ :start2 2 :end2 6) 6)
+(not (string-not-equal "AAAA" "aaaA"))
+
+
+(string= "" "")
+(string= (make-array 0 :element-type 'character)
+ (make-array 0 :element-type 'base-char))
+(not (string= "abc" ""))
+(not (string= "" "abc"))
+(not (string= "A" "a"))
+(string= "abc" "xyz" :start1 3 :start2 3)
+(string= "abc" "xyz" :start1 1 :end1 1 :start2 0 :end2 0)
+(string= "axyza" "xyz" :start1 1 :end1 4)
+(string= "axyza" "xyz" :start1 1 :end1 4 :start2 0 :end2 nil)
+(string= "abxyz" "xyabz" :end1 2 :start2 2 :end2 4)
+(not (string= "love" "hate"))
+(string= 'love 'love)
+(not (string= 'love "hate"))
+(string= #\a #\a)
+
+
+(not (string/= "" ""))
+(not (string/= (make-array 0 :element-type 'character)
+ (make-array 0 :element-type 'base-char)))
+(eql (string/= "abc" "") 0)
+(eql (string/= "" "abc") 0)
+(eql (string/= "A" "a") 0)
+(not (string/= "abc" "xyz" :start1 3 :start2 3))
+(not (string/= "abc" "xyz" :start1 1 :end1 1 :start2 0 :end2 0))
+(not (string/= "axyza" "xyz" :start1 1 :end1 4))
+(not (string/= "axyza" "xyz" :start1 1 :end1 4 :start2 0 :end2 nil))
+(not (string/= "abxyz" "xyabz" :end1 2 :start2 2 :end2 4))
+(eql (string/= "love" "hate") 0)
+(eql (string/= "love" "loVe") 2)
+(not (string/= "life" "death" :start1 3 :start2 1 :end2 2))
+(eql (string/= "abcxyz" "ABCxyZ" :start1 3 :start2 3) 5)
+(eql (string/= "abcxyz" "ABCxyZ" :start1 3 :end1 nil :start2 3 :end2 nil) 5)
+(eql (string/= "abcxyz" "ABCxyZ" :end1 nil :start2 3 :end2 3) 0)
+(eql (string/= "abc" "abcxyz") 3)
+(eql (string/= "abcxyz" "abc") 3)
+(eql (string/= "abcxyz" "") 0)
+(eql (string/= "AbcDef" "cdef" :start1 2) 3)
+(eql (string/= "cdef" "AbcDef" :start2 2) 1)
+(= (string/= 'love "hate") 0)
+(not (string/= 'love 'love))
+(not (string/= #\a #\a))
+(= (string/= #\a #\b) 0)
+
+(not (string< "" ""))
+(not (string< "dog" "dog"))
+(not (string< " " " "))
+(not (string< "abc" ""))
+(eql (string< "" "abc") 0)
+(eql (string< "ab" "abc") 2)
+(not (string< "abc" "ab"))
+(eql (string< "aaa" "aba") 1)
+(not (string< "aba" "aaa"))
+(not (string< "my cat food" "your dog food" :start1 6 :start2 8))
+(not (string< "cat food 2 dollars" "dog food 3 dollars"
+ :start1 3 :end1 9 :start2 3 :end2 9))
+(eql (string< "xyzabc" "abcd" :start1 3) 6)
+(eql (string< "abc" "abc" :end1 1) 1)
+(eql (string< "xyzabc" "abc" :start1 3 :end1 5) 5)
+(eql (string< "xyz" "abcxyzXYZ" :start2 3) 3)
+(not (string< "abc" "abcxyz" :end2 3))
+(eql (string< "xyz" "abcxyz" :end1 2 :start2 3) 2)
+(not (string< "xyzabc" "abcdef" :start1 3 :end2 3))
+(eql (string< "aaaa" "z") 0)
+(eql (string< "pppTTTaTTTqqq" "pTTTxTTT" :start1 3 :start2 1) 6)
+(eql (string< "pppTTTaTTTqqq" "pTTTxTTT"
+ :start1 6 :end1 7
+ :start2 4 :end2 5) 6)
+(not (string< (make-array 0 :element-type 'character)
+ (make-array 0 :element-type 'base-char)))
+(not (string< 'love 'hate))
+(= (string< 'peace 'war) 0)
+(not (string< 'love 'love))
+(not (string< #\a #\a))
+(= (string< #\a #\b) 0)
+
+
+(not (string> "" ""))
+(not (string> "dog" "dog"))
+(not (string> " " " "))
+(eql (string> "abc" "") 0)
+(not (string> "" "abc"))
+(not (string> "ab" "abc"))
+(eql (string> "abc" "ab") 2)
+(eql (string> "aba" "aaa") 1)
+(not (string> "aaa" "aba"))
+(not (string> "my cat food" "your dog food" :start1 6 :start2 8))
+(not (string> "cat food 2 dollars" "dog food 3 dollars"
+ :start1 3 :end1 9 :start2 3 :end2 9))
+(eql (string> "xyzabcde" "abcd" :start1 3) 7)
+(not (string> "abc" "abc" :end1 1))
+(eql (string> "xyzabc" "a" :start1 3 :end1 5) 4)
+(eql (string> "xyzXYZ" "abcxyz" :start2 3) 3)
+(eql (string> "abcxyz" "abcxyz" :end2 3) 3)
+(not (string> "xyzXYZ" "abcxyz" :end1 2 :start2 3))
+(not (string> "xyzabc" "abcdef" :start1 3 :end2 3))
+(eql (string> "z" "aaaa") 0)
+(eql (string> "pTTTxTTTqqq" "pppTTTaTTT" :start1 1 :start2 3) 4)
+(eql (string> "pppTTTxTTTqqq" "pTTTaTTT"
+ :start1 6 :end1 7
+ :start2 4 :end2 5) 6)
+(not (string> (make-array 0 :element-type 'character)
+ (make-array 0 :element-type 'base-char)))
+(= (string> 'love 'hate) 0)
+(not (string> 'peace 'war))
+(not (string> 'love 'love))
+(not (string> #\a #\a))
+(not (string> #\a #\b))
+(= (string> #\z #\a) 0)
+
+
+(eql (string<= "" "") 0)
+(eql (string<= "dog" "dog") 3)
+(eql (string<= " " " ") 1)
+(not (string<= "abc" ""))
+(eql (string<= "ab" "abc") 2)
+(eql (string<= "aaa" "aba") 1)
+(not (string<= "aba" "aaa"))
+(eql (string<= "my cat food" "your dog food" :start1 6 :start2 8) 11)
+(eql (string<= "cat food 2 dollars" "dog food 3 dollars"
+ :start1 3 :end1 9 :start2 3 :end2 9) 9)
+(eql (string<= "xyzabc" "abcd" :start1 3) 6)
+(eql (string<= "abc" "abc" :end1 1) 1)
+(eql (string<= "xyzabc" "abc" :start1 3 :end1 5) 5)
+(eql (string<= "xyz" "abcxyzXYZ" :start2 3) 3)
+(eql (string<= "abc" "abcxyz" :end2 3) 3)
+(eql (string<= "xyz" "abcxyz" :end1 2 :start2 3) 2)
+(eql (string<= "xyzabc" "abcdef" :start1 3 :end2 3) 6)
+(eql (string<= "aaaa" "z") 0)
+(eql (string<= "pppTTTaTTTqqq" "pTTTxTTT" :start1 3 :start2 1) 6)
+(eql (string<= "pppTTTaTTTqqq" "pTTTxTTT"
+ :start1 6 :end1 7
+ :start2 4 :end2 5) 6)
+(eql (string<= (make-array 0 :element-type 'character)
+ (make-array 0 :element-type 'base-char)) 0)
+(not (string<= 'love 'hate))
+(= (string<= 'peace 'war) 0)
+(= (string<= 'love 'love) 4)
+(= (string<= #\a #\a) 1)
+(= (string<= #\a #\b) 0)
+(not (string<= #\z #\a))
+
+
+(eql (string>= "" "") 0)
+(eql (string>= "dog" "dog") 3)
+(eql (string>= " " " ") 1)
+(eql (string>= "abc" "") 0)
+(not (string>= "" "abc"))
+(not (string>= "ab" "abc"))
+(eql (string>= "abc" "ab") 2)
+(eql (string>= "aba" "aaa") 1)
+(not (string>= "aaa" "aba"))
+(eql (string>= "my cat food" "your dog food" :start1 6 :start2 8) 11)
+(eql (string>= "cat food 2 dollars" "dog food 3 dollars"
+ :start1 3 :end1 9 :start2 3 :end2 9) 9)
+(eql (string>= "xyzabcde" "abcd" :start1 3) 7)
+(not (string>= "abc" "abc" :end1 1))
+(eql (string>= "xyzabc" "a" :start1 3 :end1 5) 4)
+(eql (string>= "xyzXYZ" "abcxyz" :start2 3) 3)
+(eql (string>= "abcxyz" "abcxyz" :end2 3) 3)
+(not (string>= "xyzXYZ" "abcxyz" :end1 2 :start2 3))
+(eql (string>= "xyzabc" "abcdef" :start1 3 :end2 3) 6)
+(eql (string>= "z" "aaaa") 0)
+(eql (string>= "pTTTxTTTqqq" "pppTTTaTTT" :start1 1 :start2 3) 4)
+(eql (string>= "pppTTTxTTTqqq" "pTTTaTTT"
+ :start1 6 :end1 7
+ :start2 4 :end2 5) 6)
+(eql (string>= (make-array 0 :element-type 'character)
+ (make-array 0 :element-type 'base-char)) 0)
+(= (string>= 'love 'hate) 0)
+(not (string>= 'peace 'war))
+(= (string>= 'love 'love) 4)
+(= (string>= #\a #\a) 1)
+(not (string>= #\a #\b))
+(= (string>= #\z #\a) 0)
+
+
+
+
+(string-equal "" "")
+(string-equal (make-array 0 :element-type 'character)
+ (make-array 0 :element-type 'base-char))
+(not (string-equal "abc" ""))
+(not (string-equal "" "abc"))
+(string-equal "A" "a")
+(string-equal "abc" "xyz" :start1 3 :start2 3)
+(string-equal "abc" "xyz" :start1 1 :end1 1 :start2 0 :end2 0)
+(string-equal "axyza" "xyz" :start1 1 :end1 4)
+(string-equal "axyza" "xyz" :start1 1 :end1 4 :start2 0 :end2 nil)
+(string-equal "abxyz" "xyabz" :end1 2 :start2 2 :end2 4)
+(not (string-equal "love" "hate"))
+(string-equal "xyz" "XYZ")
+(not (string-equal 'love 'hate))
+(not (string-equal 'peace 'war))
+(string-equal 'love 'love)
+(string-equal #\a #\a)
+(not (string-equal #\a #\b))
+(not (string-equal #\z #\a))
+
+
+(not (string-not-equal "" ""))
+(not (string-not-equal (make-array 0 :element-type 'character)
+ (make-array 0 :element-type 'base-char)))
+(eql (string-not-equal "abc" "") 0)
+(eql (string-not-equal "" "abc") 0)
+(not (string-not-equal "A" "a"))
+(not (string-not-equal "abc" "xyz" :start1 3 :start2 3))
+(not (string-not-equal "abc" "xyz" :start1 1 :end1 1 :start2 0 :end2 0))
+(not (string-not-equal "axyza" "xyz" :start1 1 :end1 4))
+(not (string-not-equal "axyza" "xyz" :start1 1 :end1 4 :start2 0 :end2 nil))
+(not (string-not-equal "abxyz" "xyabz" :end1 2 :start2 2 :end2 4))
+(eql (string-not-equal "love" "hate") 0)
+(not (string-not-equal "love" "loVe"))
+(not (string-not-equal "life" "death" :start1 3 :start2 1 :end2 2))
+(not (string-not-equal "abcxyz" "ABCxyZ" :start1 3 :start2 3))
+(not (string-not-equal "abcxyz" "ABCxyZ" :start1 3 :end1 nil :start2 3 :end2 nil))
+(eql (string-not-equal "abcxyz" "ABCxyZ" :end1 nil :start2 3 :end2 3) 0)
+(eql (string-not-equal "abc" "abcxyz") 3)
+(eql (string-not-equal "abcxyz" "abc") 3)
+(eql (string-not-equal "abcxyz" "") 0)
+(not (string-not-equal "AbcDef" "cdef" :start1 2))
+(not (string-not-equal "cdef" "AbcDef" :start2 2))
+(not (string-not-equal "ABC" "abc"))
+(= (string-not-equal 'love 'hate) 0)
+(= (string-not-equal 'peace 'war) 0)
+(not (string-not-equal 'love 'love))
+(not (string-not-equal #\a #\a))
+(= (string-not-equal #\a #\b) 0)
+(= (string-not-equal #\z #\a) 0)
+
+
+(not (string-lessp "" ""))
+(not (string-lessp "dog" "dog"))
+(not (string-lessp " " " "))
+(not (string-lessp "abc" ""))
+(eql (string-lessp "" "abc") 0)
+(eql (string-lessp "ab" "abc") 2)
+(not (string-lessp "abc" "ab"))
+(eql (string-lessp "aaa" "aba") 1)
+(not (string-lessp "aba" "aaa"))
+(not (string-lessp "my cat food" "your dog food" :start1 6 :start2 8))
+(not (string-lessp "cat food 2 dollars" "dog food 3 dollars"
+ :start1 3 :end1 9 :start2 3 :end2 9))
+(eql (string-lessp "xyzabc" "abcd" :start1 3) 6)
+(eql (string-lessp "abc" "abc" :end1 1) 1)
+(eql (string-lessp "xyzabc" "abc" :start1 3 :end1 5) 5)
+(eql (string-lessp "xyz" "abcxyzXYZ" :start2 3) 3)
+(not (string-lessp "abc" "abcxyz" :end2 3))
+(eql (string-lessp "xyz" "abcxyz" :end1 2 :start2 3) 2)
+(not (string-lessp "xyzabc" "abcdef" :start1 3 :end2 3))
+(eql (string-lessp "aaaa" "z") 0)
+(eql (string-lessp "pppTTTaTTTqqq" "pTTTxTTT" :start1 3 :start2 1) 6)
+(eql (string-lessp "pppTTTaTTTqqq" "pTTTxTTT"
+ :start1 6 :end1 7
+ :start2 4 :end2 5) 6)
+(not (string-lessp (make-array 0 :element-type 'character)
+ (make-array 0 :element-type 'base-char)))
+(and (not (string-lessp "abc" "ABC"))
+ (not (string-lessp "ABC" "abc")))
+(not (string-lessp 'love 'hate))
+(= (string-lessp 'peace 'war) 0)
+(not (string-lessp 'love 'love))
+(not (string-lessp #\a #\a))
+(= (string-lessp #\a #\b) 0)
+(not (string-lessp #\z #\a))
+
+
+(not (string-greaterp "" ""))
+(not (string-greaterp "dog" "dog"))
+(not (string-greaterp " " " "))
+(eql (string-greaterp "abc" "") 0)
+(not (string-greaterp "" "abc"))
+(not (string-greaterp "ab" "abc"))
+(eql (string-greaterp "abc" "ab") 2)
+(eql (string-greaterp "aba" "aaa") 1)
+(not (string-greaterp "aaa" "aba"))
+(not (string-greaterp "my cat food" "your dog food" :start1 6 :start2 8))
+(not (string-greaterp "cat food 2 dollars" "dog food 3 dollars"
+ :start1 3 :end1 9 :start2 3 :end2 9))
+(eql (string-greaterp "xyzabcde" "abcd" :start1 3) 7)
+(not (string-greaterp "abc" "abc" :end1 1))
+(eql (string-greaterp "xyzabc" "a" :start1 3 :end1 5) 4)
+(eql (string-greaterp "xyzXYZ" "abcxyz" :start2 3) 3)
+(eql (string-greaterp "abcxyz" "abcxyz" :end2 3) 3)
+(not (string-greaterp "xyzXYZ" "abcxyz" :end1 2 :start2 3))
+(not (string-greaterp "xyzabc" "abcdef" :start1 3 :end2 3))
+(eql (string-greaterp "z" "aaaa") 0)
+(eql (string-greaterp "pTTTxTTTqqq" "pppTTTaTTT" :start1 1 :start2 3) 4)
+(eql (string-greaterp "pppTTTxTTTqqq" "pTTTaTTT"
+ :start1 6 :end1 7
+ :start2 4 :end2 5) 6)
+(not (string-greaterp (make-array 0 :element-type 'character)
+ (make-array 0 :element-type 'base-char)))
+(and (not (string-greaterp "abc" "ABC"))
+ (not (string-greaterp "ABC" "abc")))
+(= (string-greaterp 'love 'hate) 0)
+(not (string-greaterp 'peace 'war))
+(not (string-greaterp 'love 'love))
+(not (string-greaterp #\a #\a))
+(not (string-greaterp #\a #\b))
+(= (string-greaterp #\z #\a) 0)
+
+
+(eql (string-not-greaterp "" "") 0)
+(eql (string-not-greaterp "dog" "dog") 3)
+(eql (string-not-greaterp " " " ") 1)
+(not (string-not-greaterp "abc" ""))
+(eql (string-not-greaterp "ab" "abc") 2)
+(eql (string-not-greaterp "aaa" "aba") 1)
+(not (string-not-greaterp "aba" "aaa"))
+(eql (string-not-greaterp "my cat food" "your dog food" :start1 6 :start2 8) 11)
+(eql (string-not-greaterp "cat food 2 dollars" "dog food 3 dollars"
+ :start1 3 :end1 9 :start2 3 :end2 9) 9)
+(eql (string-not-greaterp "xyzabc" "abcd" :start1 3) 6)
+(eql (string-not-greaterp "abc" "abc" :end1 1) 1)
+(eql (string-not-greaterp "xyzabc" "abc" :start1 3 :end1 5) 5)
+(eql (string-not-greaterp "xyz" "abcxyzXYZ" :start2 3) 3)
+(eql (string-not-greaterp "abc" "abcxyz" :end2 3) 3)
+(eql (string-not-greaterp "xyz" "abcxyz" :end1 2 :start2 3) 2)
+(eql (string-not-greaterp "xyzabc" "abcdef" :start1 3 :end2 3) 6)
+(eql (string-not-greaterp "aaaa" "z") 0)
+(eql (string-not-greaterp "pppTTTaTTTqqq" "pTTTxTTT" :start1 3 :start2 1) 6)
+(eql (string-not-greaterp "pppTTTaTTTqqq" "pTTTxTTT"
+ :start1 6 :end1 7
+ :start2 4 :end2 5) 6)
+(eql (string-not-greaterp (make-array 0 :element-type 'character)
+ (make-array 0 :element-type 'base-char)) 0)
+(and (eql (string-not-greaterp "abc" "ABC") 3)
+ (eql (string-not-greaterp "ABC" "abc") 3))
+(not (string-not-greaterp 'love 'hate))
+(= (string-not-greaterp 'peace 'war) 0)
+(= (string-not-greaterp 'love 'love) 4)
+(= (string-not-greaterp #\a #\a) 1)
+(= (string-not-greaterp #\a #\b) 0)
+(not (string-not-greaterp #\z #\a))
+
+
+(eql (string-not-lessp "" "") 0)
+(eql (string-not-lessp "dog" "dog") 3)
+(eql (string-not-lessp " " " ") 1)
+(eql (string-not-lessp "abc" "") 0)
+(not (string-not-lessp "" "abc"))
+(not (string-not-lessp "ab" "abc"))
+(eql (string-not-lessp "abc" "ab") 2)
+(eql (string-not-lessp "aba" "aaa") 1)
+(not (string-not-lessp "aaa" "aba"))
+(eql (string-not-lessp "my cat food" "your dog food" :start1 6 :start2 8) 11)
+(eql (string-not-lessp "cat food 2 dollars" "dog food 3 dollars"
+ :start1 3 :end1 9 :start2 3 :end2 9) 9)
+(eql (string-not-lessp "xyzabcde" "abcd" :start1 3) 7)
+(not (string-not-lessp "abc" "abc" :end1 1))
+(eql (string-not-lessp "xyzabc" "a" :start1 3 :end1 5) 4)
+(eql (string-not-lessp "xyzXYZ" "abcxyz" :start2 3) 3)
+(eql (string-not-lessp "abcxyz" "abcxyz" :end2 3) 3)
+(not (string-not-lessp "xyzXYZ" "abcxyz" :end1 2 :start2 3))
+(eql (string-not-lessp "xyzabc" "abcdef" :start1 3 :end2 3) 6)
+(eql (string-not-lessp "z" "aaaa") 0)
+(eql (string-not-lessp "pTTTxTTTqqq" "pppTTTaTTT" :start1 1 :start2 3) 4)
+(eql (string-not-lessp "pppTTTxTTTqqq" "pTTTaTTT"
+ :start1 6 :end1 7
+ :start2 4 :end2 5) 6)
+(eql (string-not-lessp (make-array 0 :element-type 'character)
+ (make-array 0 :element-type 'base-char)) 0)
+(and (eql (string-not-lessp "abc" "ABC") 3)
+ (eql (string-not-lessp "ABC" "abc") 3))
+(= (string-not-lessp 'love 'hate) 0)
+(not (string-not-lessp 'peace 'war))
+(= (string-not-lessp 'love 'love) 4)
+(= (string-not-lessp #\a #\a) 1)
+(not (string-not-lessp #\a #\b))
+(= (string-not-lessp #\z #\a) 0)
+
+
+
+(stringp "aaaaaa")
+(stringp (make-array 0 :element-type 'character))
+(stringp (make-array 0 :element-type 'base-char))
+(stringp (make-array 0 :element-type 'standard-char))
+(not (stringp #\a))
+(not (stringp 'a))
+(not (stringp '(string)))
+
+(string= (make-string 3 :initial-element #\a) "aaa")
+(let ((str (make-string 3)))
+ (and (simple-string-p str)
+ (setf (schar str 0) #\x)
+ (setf (schar str 1) #\y)
+ (setf (schar str 2) #\z)
+ (string= str "xyz")))
+(string= (make-string 1 :initial-element #\Space) " ")
+(string= (make-string 0) "")
+
+(subtypep (upgraded-array-element-type
+ (array-element-type (make-string 3 :element-type 'standard-char)))
+ 'character)
+
diff --git a/Sacla/tests/must-symbol.lisp b/Sacla/tests/must-symbol.lisp
new file mode 100644
index 0000000..74d8176
--- /dev/null
+++ b/Sacla/tests/must-symbol.lisp
@@ -0,0 +1,459 @@
+;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
+;; ALL RIGHTS RESERVED.
+;;
+;; $Id: must-symbol.lisp,v 1.7 2004/02/20 07:23:42 yuji Exp $
+;;
+;; 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.
+;;
+;; 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.
+
+(symbolp 'elephant)
+(not (symbolp 12))
+(symbolp nil)
+(symbolp '())
+(symbolp :test)
+(not (symbolp "hello"))
+
+(not (keywordp 'elephant))
+(not (keywordp 12))
+(keywordp :test)
+(keywordp ':test)
+(not (keywordp nil))
+(keywordp :nil)
+(not (keywordp '(:test)))
+(not (keywordp "hello"))
+(not (keywordp ":hello"))
+(not (keywordp '&optional))
+
+
+(let ((new (make-symbol "symbol")))
+ (string= (symbol-name new) "symbol"))
+
+(let ((new (make-symbol "symbol")))
+ (not (boundp new)))
+
+(let ((new (make-symbol "symbol")))
+ (not (fboundp new)))
+
+(let ((new (make-symbol "symbol")))
+ (null (symbol-plist new)))
+
+(let ((new (make-symbol "symbol")))
+ (null (symbol-package new)))
+
+(let ((new (make-symbol "symbol")))
+ (not (member new (find-all-symbols "symbol"))))
+
+(every #'identity
+ (mapcar
+ #'(lambda (name)
+ (let ((new (make-symbol name)))
+ (and (string= (symbol-name new) name)
+ (not (boundp new))
+ (not (fboundp new))
+ (null (symbol-plist new))
+ (not (member new (find-all-symbols name))))))
+ '("" "Symbol" "eat-this" "SYMBOL" ":S:Y:M:B:O:L:")))
+
+
+(let ((copy (copy-symbol 'cl:car)))
+ (string= (symbol-name copy) (symbol-name 'cl:car)))
+
+(let ((copy (copy-symbol 'cl:car)))
+ (not (boundp copy)))
+
+(let ((copy (copy-symbol 'cl:car)))
+ (not (fboundp copy)))
+
+(let ((copy (copy-symbol 'cl:car)))
+ (null (symbol-plist copy)))
+
+(let ((copy (copy-symbol 'cl:car)))
+ (null (symbol-package copy)))
+
+
+(let ((copy (copy-symbol 'cl:car "copy properties too")))
+ (string= (symbol-name copy) (symbol-name 'cl:car)))
+
+(let ((copy (copy-symbol 'cl:car "copy properties too")))
+ (if (boundp 'cl:car)
+ (boundp copy)
+ (not (boundp copy))))
+
+(let ((copy (copy-symbol 'cl:car "copy properties too")))
+ (eq (symbol-function copy) (symbol-function 'cl:car)))
+
+(let ((copy (copy-symbol 'cl:car "copy properties too")))
+ (equal (symbol-plist copy) (symbol-plist 'cl:car)))
+
+(let ((copy (copy-symbol 'cl:car "copy properties too")))
+ (null (symbol-package copy)))
+
+
+
+(every #'identity
+ (mapcar
+ #'(lambda (symbol)
+ (let ((copy1 (copy-symbol symbol))
+ (copy2 (copy-symbol symbol "copy-properties")))
+ (and (string= (symbol-name copy1) (symbol-name symbol))
+ (string= (symbol-name copy2) (symbol-name symbol))
+ (not (boundp copy1))
+ (if (boundp symbol)
+ (boundp copy2)
+ (not (boundp copy2)))
+ (not (fboundp copy1))
+ (if (fboundp symbol)
+ (fboundp copy2)
+ (not (fboundp copy2)))
+ (null (symbol-plist copy1))
+ (equal (symbol-plist copy2) (symbol-plist symbol))
+ (null (symbol-package copy1))
+ (null (symbol-package copy2))
+ (not (member copy1 (find-all-symbols symbol)))
+ (not (member copy2 (find-all-symbols symbol))))))
+ '(nil cl:cdr cl:*package* cl:list symbol weird-symbol)))
+
+
+(let ((new (gensym)))
+ (not (boundp new)))
+
+(let ((new (gensym)))
+ (not (fboundp new)))
+
+(let ((new (gensym)))
+ (null (symbol-plist new)))
+
+(let ((new (gensym)))
+ (null (symbol-package new)))
+
+
+(let ((new (gensym "How about this")))
+ (not (boundp new)))
+
+(let ((new (gensym "How about this")))
+ (not (fboundp new)))
+
+(let ((new (gensym "How about this")))
+ (null (symbol-plist new)))
+
+(let ((new (gensym "How about this")))
+ (null (symbol-package new)))
+
+
+(let ((new (gensym 100)))
+ (not (boundp new)))
+
+(let ((new (gensym 10)))
+ (not (fboundp new)))
+
+(let ((new (gensym 9)))
+ (null (symbol-plist new)))
+
+(let ((new (gensym 8)))
+ (null (symbol-package new)))
+
+
+(let* ((counter *gensym-counter*)
+ (new (gensym)))
+ (string= (symbol-name new)
+ (with-output-to-string (stream)
+ (format stream "G~D" counter))))
+
+(let* ((counter *gensym-counter*)
+ (new (gensym "JJ")))
+ (string= (symbol-name new)
+ (with-output-to-string (stream)
+ (format stream "JJ~D" counter))))
+
+(let* ((counter *gensym-counter*)
+ (new (gensym "")))
+ (string= (symbol-name new)
+ (with-output-to-string (stream)
+ (format stream "~D" counter))))
+
+(let ((new (gensym 0)))
+ (string= (symbol-name new) "G0"))
+
+(let ((new (gensym 1000)))
+ (string= (symbol-name new) "G1000"))
+
+
+
+(let ((symbol (gentemp)))
+ (char= (aref (symbol-name symbol) 0) #\T))
+
+(let ((symbol (gentemp)))
+ (not (boundp symbol)))
+
+(let ((symbol (gentemp)))
+ (not (fboundp symbol)))
+
+(let ((symbol (gentemp)))
+ (null (symbol-plist symbol)))
+
+(let ((symbol (gentemp)))
+ (multiple-value-bind (symbol-found status)
+ (find-symbol (symbol-name symbol))
+ (and (eq symbol-found symbol)
+ (if (eq *package* (find-package "KEYWORD"))
+ (eq status :external)
+ (eq status :internal)))))
+
+(let ((symbol-1 (gentemp))
+ (symbol-2 (gentemp)))
+ (not (string= (symbol-name symbol-1) (symbol-name symbol-2))))
+
+(let ((symbol (gentemp "prefix")))
+ (string= (subseq (symbol-name symbol) 0 6) "prefix"))
+
+(let ((symbol (gentemp "prefix")))
+ (not (boundp symbol)))
+
+(let ((symbol (gentemp "prefix")))
+ (not (fboundp symbol)))
+
+(let ((symbol (gentemp "prefix")))
+ (null (symbol-plist symbol)))
+
+(let ((symbol (gentemp "prefix")))
+ (multiple-value-bind (symbol-found status)
+ (find-symbol (symbol-name symbol))
+ (and (eq symbol-found symbol)
+ (if (eq *package* (find-package "KEYWORD"))
+ (eq status :external)
+ (eq status :internal)))))
+
+
+(let* ((package (defpackage "TEST-PACKAGE-FOR-GENTEMP"))
+ (symbol (gentemp "prefix" package)))
+ (string= (subseq (symbol-name symbol) 0 6) "prefix"))
+
+(let* ((package (defpackage "TEST-PACKAGE-FOR-GENTEMP"))
+ (symbol (gentemp "prefix" package)))
+ (not (boundp symbol)))
+
+(let* ((package (defpackage "TEST-PACKAGE-FOR-GENTEMP"))
+ (symbol (gentemp "prefix" package)))
+ (not (fboundp symbol)))
+
+(let* ((package (defpackage "TEST-PACKAGE-FOR-GENTEMP"))
+ (symbol (gentemp "prefix" package)))
+ (null (symbol-plist symbol)))
+
+(let* ((package (defpackage "TEST-PACKAGE-FOR-GENTEMP"))
+ (symbol (gentemp "prefix" package)))
+ (multiple-value-bind (symbol-found status)
+ (find-symbol (symbol-name symbol) package)
+ (and (eq symbol-found symbol)
+ (eq status :internal))))
+
+
+
+(functionp (symbol-function 'cl:car))
+(eq (symbol-function 'cl:car) (fdefinition 'cl:car))
+(progn (setf (symbol-function 'symbol-for-test) #'car)
+ (eq (symbol-for-test '(a)) 'a))
+
+(let ((f #'(lambda (a) a)))
+ (setf (symbol-function 'symbol-for-test) f)
+ (eq (symbol-function 'symbol-for-test) f))
+
+
+(stringp (symbol-name 'symbol))
+(string= (symbol-name (intern "TEST-SYMBOL")) "TEST-SYMBOL")
+
+
+(eq (symbol-package 'cl:car) (find-package "COMMON-LISP"))
+(eq (symbol-package ':key) (find-package "KEYWORD"))
+(null (symbol-package (make-symbol "temp")))
+(null (symbol-package (gensym)))
+(packagep (symbol-package 'a))
+(packagep (symbol-package 'my-symbol))
+
+
+(listp (symbol-plist 'car))
+(listp (symbol-plist 'cdr))
+(null (symbol-plist (gensym)))
+(null (symbol-plist (gentemp)))
+
+(let ((symbol (gensym)))
+ (setf (symbol-plist symbol) (list 'a 1 'b 2 'c 3))
+ (equal (symbol-plist symbol) '(a 1 b 2 c 3)))
+
+(let ((symbol (gensym)))
+ (setf (symbol-plist symbol) (list 'a 1 'b 2 'c 3))
+ (setf (symbol-plist symbol) '())
+ (null (symbol-plist symbol)))
+
+
+(progn (setf (symbol-value 'a) 1)
+ (eql (symbol-value 'a) 1))
+
+(progn
+ (setf (symbol-value 'a) 1)
+ (let ((a 2))
+ (eql (symbol-value 'a) 1)))
+
+(progn
+ (setf (symbol-value 'a) 1)
+ (let ((a 2))
+ (setq a 3)
+ (eql (symbol-value 'a) 1)))
+
+(progn
+ (setf (symbol-value 'a) 1)
+ (let ((a 2))
+ (declare (special a))
+ (eql (symbol-value 'a) 2)))
+
+(progn
+ (setf (symbol-value 'a) 1)
+ (let ((a 2))
+ (declare (special a))
+ (setq a 3)
+ (eql (symbol-value 'a) 3)))
+
+(progn
+ (setf (symbol-value 'a) 1)
+ (and (eql (let ((a 2))
+ (setf (symbol-value 'a) 3)
+ a)
+ 2)
+ (eql a 3)))
+
+(progn
+ (setf (symbol-value 'a) 1)
+ (let ((a 4))
+ (declare (special a))
+ (let ((b (symbol-value 'a)))
+ (setf (symbol-value 'a) 5)
+ (and (eql a 5)
+ (eql b 4)))))
+
+(eq (symbol-value :any-keyword) :any-keyword)
+(eq (symbol-value 'nil) nil)
+(eq (symbol-value '()) nil)
+(eq (symbol-value t) t)
+
+
+(let ((symbol (gensym)))
+ (setf (symbol-plist symbol) (list 'a 1 'b 2 'c 3))
+ (and (eql (get symbol 'a) 1)
+ (eql (get symbol 'b) 2)
+ (eql (get symbol 'c) 3)
+ (eql (get symbol 'd) nil)
+ (eql (get symbol 'e 9) 9)))
+
+(let ((symbol (gensym)))
+ (setf (symbol-plist symbol) (list 'a 1 'b 2 'c 3))
+ (and (eql (setf (get symbol 'a) 9) 9)
+ (eql (get symbol 'a) 9)
+ (eql (setf (get symbol 'b) 8) 8)
+ (eql (get symbol 'b) 8)
+ (eql (setf (get symbol 'c) 7) 7)
+ (eql (get symbol 'c) 7)
+ (eql (setf (get symbol 'd) 6) 6)
+ (eql (get symbol 'd) 6)
+ (eql (setf (get symbol 'e) 5) 5)
+ (eql (get symbol 'e) 5)))
+
+(let ((symbol (gensym))
+ tmp)
+ (and (null (get symbol 'a))
+ (setf (get symbol 'a (setq tmp 1)) tmp)
+ (eql (get symbol 'a) 1)))
+
+(let ((symbol (gensym)))
+ (setf (symbol-plist symbol) (list 'a 1 'b 2 'c 3 'a 9))
+ (and (eql (setf (get symbol 'a) 5) 5)
+ (eql (get symbol 'a) 5)))
+
+
+(let ((symbol (gensym)))
+ (setf (symbol-plist symbol) (list 'a 1 'b 2 'c 3))
+ (and (remprop symbol 'a)
+ (eq (get symbol 'a 'not-found) 'not-found)))
+
+(let ((symbol (gensym)))
+ (not (remprop symbol 'a)))
+
+(let ((symbol (gensym)))
+ (setf (symbol-plist symbol) (list 'a 1 'b 2 'c 3 'a 9))
+ (and (remprop symbol 'a)
+ (eql (get symbol 'a) 9)))
+
+(let ((symbol (gensym)))
+ (setf (symbol-plist symbol) (list 'a 1 'b 2 'c 3 'a 9))
+ (and (remprop symbol 'a)
+ (eql (get symbol 'a) 9)
+ (remprop symbol 'a)
+ (eq (get symbol 'a 'not-found) 'not-found)))
+
+
+(not (boundp (gensym)))
+(let ((symbol (gensym)))
+ (set symbol 1)
+ (boundp symbol))
+
+(let ((test-symbol 1))
+ (not (boundp 'test-symbol)))
+
+(let ((test-symbol 1))
+ (declare (special test-symbol))
+ (boundp 'test-symbol))
+
+
+(not (boundp (makunbound (gensym))))
+
+(let ((test-symbol 0))
+ (declare (special test-symbol))
+ (and (let ((test-symbol 1))
+ (declare (special test-symbol))
+ (not (boundp (makunbound 'test-symbol))))
+ (boundp 'test-symbol)))
+
+
+(let ((test-symbol 0))
+ (declare (special test-symbol))
+ (and (let ((test-symbol 1))
+ (makunbound 'test-symbol)
+ (eql test-symbol 1))
+ (not (boundp 'test-symbol))))
+
+
+(let ((test-symbol 0))
+ (declare (special test-symbol))
+ (and
+ (eql test-symbol 0)
+ (setf (symbol-value 'test-symbol) 1)
+ (eql test-symbol 1)
+ (eql (set 'test-symbol 10) 10)
+ (eql test-symbol 10)))
+
+(let ((test-symbol 0))
+ (declare (special test-symbol))
+ (and (let ((test-symbol 1))
+ (set 'test-symbol 100)
+ (eql test-symbol 1))
+ (eql test-symbol 100)))
+
diff --git a/Sacla/tests/should-array.lisp b/Sacla/tests/should-array.lisp
new file mode 100644
index 0000000..ce72337
--- /dev/null
+++ b/Sacla/tests/should-array.lisp
@@ -0,0 +1,229 @@
+;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
+;; ALL RIGHTS RESERVED.
+;;
+;; $Id: should-array.lisp,v 1.12 2004/08/09 02:49:55 yuji Exp $
+;;
+;; 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.
+;;
+;; 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.
+
+(HANDLER-CASE (PROGN (ADJUST-ARRAY (MAKE-ARRAY '(3 3)) '(1 9) :FILL-POINTER 1))
+ (ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+#-CLISP ;Bruno: Why expect an error? A string _is_ an array.
+(progn
+ #-(or cmu clispxxx)
+ (HANDLER-CASE (PROGN (ADJUSTABLE-ARRAY-P "not-a-symbol"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+ #+(or cmu clispxxx) 'skipped)
+
+(progn
+ #-cmu
+ (HANDLER-CASE (PROGN (ADJUSTABLE-ARRAY-P #\a))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+ #+cmu 'skipped)
+
+(progn
+ #-cmu
+ (HANDLER-CASE (PROGN (ADJUSTABLE-ARRAY-P '(NIL)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+ #+cmu 'skipped)
+
+(HANDLER-CASE (PROGN (ARRAY-DIMENSIONS 'NOT-AN-ARRAY))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (ARRAY-DIMENSIONS #\a))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (ARRAY-DIMENSIONS '(NIL)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+
+(HANDLER-CASE (PROGN (ARRAY-ELEMENT-TYPE 'NOT-AN-ARRAY))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (ARRAY-ELEMENT-TYPE #\a))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (ARRAY-ELEMENT-TYPE '(NIL)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(progn
+ #-cmu
+ (HANDLER-CASE (PROGN (ARRAY-HAS-FILL-POINTER-P 'NOT-AN-ARRAY))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+ #+cmu 'skipped)
+
+(progn
+ #-cmu
+ (HANDLER-CASE (PROGN (ARRAY-HAS-FILL-POINTER-P #\a))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+ #+cmu 'skipped)
+
+(progn
+ #-cmu
+ (HANDLER-CASE (PROGN (ARRAY-HAS-FILL-POINTER-P '(NIL)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+ #+cmu 'skipped)
+
+(progn
+ #-cmu
+ (HANDLER-CASE (PROGN (ARRAY-DISPLACEMENT 'NOT-AN-ARRAY))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+ #+cmu 'skipped)
+
+(progn
+ #-cmu
+ (HANDLER-CASE (PROGN (ARRAY-DISPLACEMENT #\a))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+ #+cmu 'skipped)
+
+(progn
+ #-cmu
+ (HANDLER-CASE (PROGN (ARRAY-DISPLACEMENT '(NIL)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+ #+cmu 'skipped)
+
+(HANDLER-CASE (PROGN (ARRAY-RANK 'NOT-AN-ARRAY))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (ARRAY-RANK #\a))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (ARRAY-RANK '(NIL)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (ARRAY-TOTAL-SIZE 'NOT-AN-ARRAY))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (ARRAY-TOTAL-SIZE #\a))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (ARRAY-TOTAL-SIZE '(NIL)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (FILL-POINTER 'NOT-AN-ARRAY))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (FILL-POINTER #\a))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (FILL-POINTER '(NIL)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(let ((vector (make-array 10 :fill-pointer nil)))
+ (or (not (array-has-fill-pointer-p vector))
+ (HANDLER-CASE (PROGN (FILL-POINTER VECTOR))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))))
+
+(let ((vector (make-array 10 :fill-pointer nil)))
+ (or (not (array-has-fill-pointer-p vector))
+ (HANDLER-CASE (PROGN (SETF (FILL-POINTER VECTOR) 0))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))))
+
+(progn
+ #-(or cmu clisp)
+ (HANDLER-CASE (PROGN (VECTOR-POP (MAKE-ARRAY 10 :FILL-POINTER NIL)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+ #+(or cmu clisp) 'skipped)
+
+(HANDLER-CASE (PROGN (VECTOR-POP (MAKE-ARRAY 10 :FILL-POINTER 0)))
+ (ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(let ((vec (make-array 3 :fill-pointer t :initial-contents '(a b c))))
+ (and (eq (vector-pop vec) 'c)
+ (eq (vector-pop vec) 'b)
+ (eq (vector-pop vec) 'a)
+ (HANDLER-CASE (PROGN (VECTOR-POP VEC))
+ (ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))))
+
+
+(let ((vector (make-array 10 :fill-pointer nil)))
+ (or (not (array-has-fill-pointer-p vector))
+ (HANDLER-CASE (PROGN (VECTOR-PUSH 'A VECTOR))
+ (ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))))
+
+(let ((vector (make-array 10 :fill-pointer nil)))
+ (or (not (array-has-fill-pointer-p vector))
+ (HANDLER-CASE (PROGN (VECTOR-PUSH-EXTEND 'A VECTOR))
+ (ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))))
+
+(let ((vector (make-array 1 :fill-pointer t :adjustable nil)))
+ (or (adjustable-array-p vector)
+ (HANDLER-CASE (PROGN (VECTOR-PUSH-EXTEND 'A VECTOR))
+ (ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))))
+
diff --git a/Sacla/tests/should-array.patch b/Sacla/tests/should-array.patch
new file mode 100644
index 0000000..113e1c7
--- /dev/null
+++ b/Sacla/tests/should-array.patch
@@ -0,0 +1,32 @@
+*** sacla/lisp/test/should-array.lisp 2004-08-03 08:34:55.000000000 +0200
+--- CLISP/clisp-20040712/sacla-tests/should-array.lisp 2004-08-06 03:27:42.000000000 +0200
+***************
+*** 31,43 ****
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+ (progn
+! #-(or cmu clisp)
+ (HANDLER-CASE (PROGN (ADJUSTABLE-ARRAY-P "not-a-symbol"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+! #+(or cmu clisp) 'skipped)
+
+ (progn
+ #-cmu
+--- 31,44 ----
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
++ #-CLISP ; Why expect an error? A string _is_ an array.
+ (progn
+! #-(or cmu clispxxx)
+ (HANDLER-CASE (PROGN (ADJUSTABLE-ARRAY-P "not-a-symbol"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+! #+(or cmu clispxxx) 'skipped)
+
+ (progn
+ #-cmu
diff --git a/Sacla/tests/should-character.lisp b/Sacla/tests/should-character.lisp
new file mode 100644
index 0000000..40643ad
--- /dev/null
+++ b/Sacla/tests/should-character.lisp
@@ -0,0 +1,252 @@
+;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
+;; ALL RIGHTS RESERVED.
+;;
+;; $Id: should-character.lisp,v 1.10 2004/02/20 07:23:42 yuji Exp $
+;;
+;; 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.
+;;
+;; 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.
+
+(HANDLER-CASE (PROGN (CHAR=))
+ (PROGRAM-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (CHAR/=))
+ (PROGRAM-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (CHAR<))
+ (PROGRAM-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (CHAR>))
+ (PROGRAM-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (CHAR<=))
+ (PROGRAM-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (CHAR>=))
+ (PROGRAM-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (CHAR-EQUAL))
+ (PROGRAM-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (CHAR-NOT-EQUAL))
+ (PROGRAM-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (CHAR-LESSP))
+ (PROGRAM-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (CHAR-GREATERP))
+ (PROGRAM-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (CHAR-NOT-GREATERP))
+ (PROGRAM-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (CHAR-NOT-LESSP))
+ (PROGRAM-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+
+(HANDLER-CASE (PROGN (CHARACTER "abc"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (CHARACTER 'MORE-THAN-ONE))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (CHARACTER '(NIL)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (ALPHA-CHAR-P "abc"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (ALPHA-CHAR-P 'NOT-A-CHAR))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (ALPHA-CHAR-P '(NIL)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (ALPHANUMERICP "abc"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (ALPHANUMERICP 'NOT-A-CHAR))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (ALPHANUMERICP '(NIL)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(progn
+ #-cmu
+ (HANDLER-CASE (PROGN (GRAPHIC-CHAR-P "abc"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+ #+cmu 'skipped)
+
+(progn
+ #-cmu
+ (HANDLER-CASE (PROGN (GRAPHIC-CHAR-P 'NOT-A-CHAR))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+ #+cmu 'skipped)
+
+(progn
+ #-cmu
+ (HANDLER-CASE (PROGN (GRAPHIC-CHAR-P '(NIL)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+ #+cmu 'skipped)
+
+(HANDLER-CASE (PROGN (STANDARD-CHAR-P "abc"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (STANDARD-CHAR-P 'NOT-A-CHAR))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (STANDARD-CHAR-P '(NIL)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (CHAR-UPCASE "abc"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (CHAR-UPCASE 'NOT-A-CHAR))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (CHAR-UPCASE '(NIL)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (CHAR-DOWNCASE "abc"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (CHAR-DOWNCASE 'NOT-A-CHAR))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (CHAR-DOWNCASE '(NIL)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (UPPER-CASE-P "abc"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (UPPER-CASE-P 'NOT-A-CHAR))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (UPPER-CASE-P '(NIL)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (LOWER-CASE-P "abc"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (LOWER-CASE-P 'NOT-A-CHAR))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (LOWER-CASE-P '(NIL)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (BOTH-CASE-P "abc"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (BOTH-CASE-P 'NOT-A-CHAR))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (BOTH-CASE-P '(NIL)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (CHAR-CODE "abc"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (CHAR-CODE 'NOT-A-CHAR))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (CHAR-CODE '(NIL)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (CHAR-NAME "abc"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (CHAR-NAME 'NOT-A-CHAR))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (CHAR-NAME '(NIL)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (NAME-CHAR '(NIL)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
diff --git a/Sacla/tests/should-cons.lisp b/Sacla/tests/should-cons.lisp
new file mode 100644
index 0000000..1d58d06
--- /dev/null
+++ b/Sacla/tests/should-cons.lisp
@@ -0,0 +1,631 @@
+;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
+;; ALL RIGHTS RESERVED.
+;;
+;; $Id: should-cons.lisp,v 1.4 2004/02/20 07:23:42 yuji Exp $
+;;
+;; 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.
+;;
+;; 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.
+
+(HANDLER-CASE (PROGN (RPLACA NIL 1))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (RPLACA "NOT A CONS" 1))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (RPLACD NIL 1))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (RPLACD "NOT A CONS" 1))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (CAR "NOT A CONS"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (CDR "NOT A CONS"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (CAAR "NOT A CONS"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (CADR "NOT A CONS"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (CDAR "NOT A CONS"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (CDDR "NOT A CONS"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (CAAAR "NOT A CONS"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (CAADR "NOT A CONS"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (CADAR "NOT A CONS"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (CADDR "NOT A CONS"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (CDAAR "NOT A CONS"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (CDADR "NOT A CONS"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (CDDAR "NOT A CONS"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (CDDDR "NOT A CONS"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (CAAAAR "NOT A CONS"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (CAAADR "NOT A CONS"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (CAADAR "NOT A CONS"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (CAADDR "NOT A CONS"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (CADAAR "NOT A CONS"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (CADADR "NOT A CONS"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (CADDAR "NOT A CONS"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (CADDDR "NOT A CONS"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (CDAAAR "NOT A CONS"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (CDAADR "NOT A CONS"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (CDADAR "NOT A CONS"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (CDADDR "NOT A CONS"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (CDDAAR "NOT A CONS"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (CDDADR "NOT A CONS"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (CDDDAR "NOT A CONS"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (CDDDDR "NOT A CONS"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (LIST-LENGTH '(1 . 2)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (LIST-LENGTH "NEITHER A PROPER LIST NOR A CIRCULAR LIST"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (LIST-LENGTH 'NEITHER-A-PROPER-LIST-NOR-A-CIRCULAR-LIST))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+
+(HANDLER-CASE (PROGN (MAKE-LIST NIL))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (MAKE-LIST -1))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (MAKE-LIST 1.2))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (MAKE-LIST 'A))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (MAKE-LIST "NOT A NON-NEGATIVE INTEGER"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+
+(HANDLER-CASE (PROGN (FIRST "NOT A CONS"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (SECOND "NOT A CONS"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (THIRD "NOT A CONS"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (FOURTH "NOT A CONS"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (FIFTH "NOT A CONS"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (SIXTH "NOT A CONS"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (SEVENTH "NOT A CONS"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (NINTH "NOT A CONS"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (TENTH "NOT A CONS"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (NTHCDR -1 '(1 2 3)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (NTHCDR 1.1 '(1 2 3)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (NTHCDR #\a '(1 2 3)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (NTHCDR 3 '(1 . 2)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (NTH -1 '(1 2)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (NTH "" '(1 2)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (NTH 3 '(1 . 2)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (ENDP 1))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (ENDP #\z))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (ENDP 'NOT-A-LIST))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (ENDP "not-a-list"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (BUTLAST 'NOT-A-LIST))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (BUTLAST 'NOT-A-LIST 'NOT-A-INTEGER))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (BUTLAST '(1 2 3 4 5) -1))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (BUTLAST '(1 2 3 4 5) 'A))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (NBUTLAST 'NOT-A-LIST))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (NBUTLAST 'NOT-A-LIST 'NOT-A-INTEGER))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (NBUTLAST '(1 2 3 4 5) -1))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (NBUTLAST '(1 2 3 4 5) 'A))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+
+(HANDLER-CASE (PROGN (LDIFF 'NOT-A-LIST 'OBJ))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (TAILP 'OBJ 'NOT-A-LIST))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (REST "NOT A CONS"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (MEMBER 'A 'NOT-A-SET))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (MEMBER 'A '(1 . 2)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (MEMBER 'A '(1 2 3 4 . 5)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (MEMBER-IF #'ATOM 'NOT-A-SET))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (MEMBER-IF #'CONSP '(1 . 2)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (MEMBER-IF #'CONSP '(1 2 3 4 . 5)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (MEMBER-IF-NOT (COMPLEMENT #'ATOM) 'NOT-A-SET))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (MEMBER-IF-NOT (COMPLEMENT #'CONSP) '(1 . 2)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (MEMBER-IF-NOT (COMPLEMENT #'CONSP) '(1 2 3 4 . 5)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (MAPCAR #'CAR 'NOT-A-LIST))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (MAPCAR #'LIST '(0 1) 'NOT-A-LIST))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (MAPCAR #'LIST '(0 . 1)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (MAPC #'CAR 'NOT-A-LIST))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (MAPC #'LIST '(0 1) 'NOT-A-LIST))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (MAPC #'LIST '(0 . 1)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (MAPCAN #'CAR 'NOT-A-LIST))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (MAPCAN #'LIST '(0 1) 'NOT-A-LIST))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (MAPCAN #'LIST '(0 . 1)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (MAPLIST #'CAR 'NOT-A-LIST))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (MAPLIST #'LIST '(0 1) 'NOT-A-LIST))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (MAPLIST #'LIST '(0 . 1)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (MAPL #'CAR 'NOT-A-LIST))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (MAPL #'LIST '(0 1) 'NOT-A-LIST))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (MAPL #'LIST '(0 . 1)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (MAPCON #'CAR 'NOT-A-LIST))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (MAPCON #'LIST '(0 1) 'NOT-A-LIST))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (MAPCON #'LIST '(0 . 1)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+
+(HANDLER-CASE (PROGN (ASSOC 'KEY '(A B C)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (ASSOC-IF #'NUMBERP '(A B C)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (ASSOC-IF-NOT #'NUMBERP '(A B C)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (ASSOC 'KEY '0))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (ASSOC-IF #'NUMBERP '0))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (ASSOC-IF-NOT #'NUMBERP '0))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (ASSOC 'KEY 'NOT-AN-ALIST))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (ASSOC-IF 'IDENTITY 'NOT-AN-ALIST))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (ASSOC-IF-NOT 'IDENTITY 'NOT-AN-ALIST))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (PAIRLIS 'NOT-A-LIST 'NOT-A-LIST '((A . B))))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (PAIRLIS '0 '(0 1 2) '((KEY . DATUM))))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (PAIRLIS '(0) '1 '((KEY . DATUM))))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (INTERSECTION '(0) '1))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (INTERSECTION '(0) '1 :TEST #'EQUALP))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (INTERSECTION #\a '(1 2 3) :TEST #'=))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (INTERSECTION 0 1))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (INTERSECTION #\a #\b))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (INTERSECTION 0 1 :TEST #'=))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (INTERSECTION #\a #\b :TEST-NOT (COMPLEMENT #'CHAR=)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (INTERSECTION '(1 2 3 . 4) '(2 3)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (INTERSECTION '(1 2 3 . 4) '(2 3) :TEST #'=))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (INTERSECTION '(1 2 3) '(2 . 3) :TEST #'=))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE
+ (PROGN (INTERSECTION '((1) (2) (3)) '((2) 3) :TEST #'= :KEY #'CAR))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (NINTERSECTION (LIST 0) '1))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (NINTERSECTION (LIST 0) '1 :TEST #'EQUALP))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (NINTERSECTION #\a '(1 2 3) :TEST #'=))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (NINTERSECTION 0 1))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (NINTERSECTION #\a #\b))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (NINTERSECTION 0 1 :TEST #'=))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (INTERSECTION #\a #\b :TEST-NOT (COMPLEMENT #'CHAR=)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (NINTERSECTION (LIST* 1 2 3 4) '(2 3)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (NINTERSECTION (LIST* 1 2 3 4) '(2 3) :TEST #'=))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (NINTERSECTION (LIST 1 2 3) '(2 . 3) :TEST #'=))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE
+ (PROGN (NINTERSECTION (LIST '(1) '(2) '(3)) '((2) 3) :TEST #'= :KEY #'CAR))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+
+(HANDLER-CASE (PROGN (ADJOIN 'A 'A))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (ADJOIN 'X '(A . B)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+
+(HANDLER-CASE (PROGN (SET-DIFFERENCE 'NOT-A-LIST 'NOT-A-LIST))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (NSET-DIFFERENCE 'NOT-A-LIST 'NOT-A-LIST))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (SET-EXCLUSIVE-OR 'NOT-A-LIST 'NOT-A-LIST))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (NSET-EXCLUSIVE-OR 'NOT-A-LIST 'NOT-A-LIST))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (UNION 'NOT-A-LIST 'NOT-A-LIST))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
diff --git a/Sacla/tests/should-data-and-control.lisp b/Sacla/tests/should-data-and-control.lisp
new file mode 100644
index 0000000..5a3e28a
--- /dev/null
+++ b/Sacla/tests/should-data-and-control.lisp
@@ -0,0 +1,49 @@
+;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
+;; ALL RIGHTS RESERVED.
+;;
+;; $Id: should-data-and-control.lisp,v 1.9 2004/02/20 07:23:42 yuji Exp $
+;;
+;; 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.
+;;
+;; 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.
+
+(HANDLER-CASE (PROGN (FUNCALL (GENSYM) 0 1 2))
+ (UNDEFINED-FUNCTION NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+;; (HANDLER-CASE (PROGN (FUNCALL 'IF T NIL T))
+;; (UNDEFINED-FUNCTION NIL T)
+;; (ERROR NIL NIL)
+;; (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (VALUES-LIST 'NOT-A-LIST))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (VALUES-LIST #\a))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (VALUES-LIST '(A . B)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
diff --git a/Sacla/tests/should-eval.lisp b/Sacla/tests/should-eval.lisp
new file mode 100644
index 0000000..c441400
--- /dev/null
+++ b/Sacla/tests/should-eval.lisp
@@ -0,0 +1,40 @@
+;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
+;; ALL RIGHTS RESERVED.
+;;
+;; $Id: should-eval.lisp,v 1.7 2004/02/20 07:23:42 yuji Exp $
+;;
+;; 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.
+;;
+;; 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.
+
+(HANDLER-CASE (PROGN (SPECIAL-OPERATOR-P '(IF T NIL T)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (SPECIAL-OPERATOR-P '(NOT A SYMBOL)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+
+
diff --git a/Sacla/tests/should-hash-table.lisp b/Sacla/tests/should-hash-table.lisp
new file mode 100644
index 0000000..2b5f98d
--- /dev/null
+++ b/Sacla/tests/should-hash-table.lisp
@@ -0,0 +1,48 @@
+;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
+;; ALL RIGHTS RESERVED.
+;;
+;; $Id: should-hash-table.lisp,v 1.7 2004/02/20 07:23:42 yuji Exp $
+;;
+;; 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.
+;;
+;; 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.
+
+(HANDLER-CASE (PROGN (HASH-TABLE-REHASH-SIZE 'NOT-A-HASH-TABLE))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (HASH-TABLE-REHASH-THRESHOLD 'NOT-A-HASH-TABLE))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (HASH-TABLE-TEST 'NOT-A-HASH-TABLE))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+
+
+
+
+
diff --git a/Sacla/tests/should-package.lisp b/Sacla/tests/should-package.lisp
new file mode 100644
index 0000000..fc68915
--- /dev/null
+++ b/Sacla/tests/should-package.lisp
@@ -0,0 +1,53 @@
+;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
+;; ALL RIGHTS RESERVED.
+;;
+;; $Id: should-package.lisp,v 1.8 2004/02/20 07:23:42 yuji Exp $
+;;
+;; 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.
+;;
+;; 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.
+
+(HANDLER-CASE (PROGN (PACKAGE-NAME '(NOT A PACKAGE DESIGNATOR)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (PACKAGE-NICKNAMES '(NOT A PACKAGE DESIGNATOR)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (PACKAGE-SHADOWING-SYMBOLS '(NOT A PACKAGE DESIGNATOR)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (PACKAGE-USE-LIST '(NOT A PACKAGE DESIGNATOR)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (PACKAGE-USED-BY-LIST '(NOT A PACKAGE DESIGNATOR)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (EVAL (MACROEXPAND '(WITH-PACKAGE-ITERATOR (GET 'CL)))))
+ (PROGRAM-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
diff --git a/Sacla/tests/should-sequence.lisp b/Sacla/tests/should-sequence.lisp
new file mode 100644
index 0000000..455a941
--- /dev/null
+++ b/Sacla/tests/should-sequence.lisp
@@ -0,0 +1,375 @@
+;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
+;; ALL RIGHTS RESERVED.
+;;
+;; $Id: should-sequence.lisp,v 1.18 2004/02/20 07:23:42 yuji Exp $
+;;
+;; 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.
+;;
+;; 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.
+
+(HANDLER-CASE (PROGN (LENGTH 'NOT-A-SEQ))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+
+
+(HANDLER-CASE (PROGN (COPY-SEQ 'NOT-A-SEQ))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (COPY-SEQ #2A((#\a #\b #\c) (#\x #\y #\z))))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (COPY-SEQ #\a))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (COPY-SEQ '(A . B)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+
+(HANDLER-CASE (PROGN (ELT 'NOT-A-SEQ 0))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (ELT #\a 0))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (ELT '(0 1 . 2) 2))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+;; (HANDLER-CASE (PROGN (ELT '#1=(0 1 . #1#) 3))
+;; (TYPE-ERROR NIL T)
+;; (ERROR NIL NIL)
+;; (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (SETF (ELT 'NOT-A-SEQ 0) 0))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (SETF (ELT #\a 0) 0))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (SETF (ELT '(0 1 . 2) 2) 0))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+;; (HANDLER-CASE (PROGN (SETF (ELT '#1=(0 1 . #1#) 3) 0))
+;; (TYPE-ERROR NIL T)
+;; (ERROR NIL NIL)
+;; (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (ELT "012" -1))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (ELT "012" 'INDEX))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (ELT "012" "xyz"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (ELT "012" 100))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (ELT #(A B C D) 100))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (ELT '(0 1 2) 100))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE
+ (PROGN
+ (ELT (MAKE-ARRAY 10 :FILL-POINTER 3
+ :INITIAL-CONTENTS '(0 1 2 3 4 5 6 7 8 9))
+ 3))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+
+
+(HANDLER-CASE (PROGN (SETF (ELT (COPY-SEQ "012") -1) #\a))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (SETF (ELT (COPY-SEQ "012") 'INDEX) #\a))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (SETF (ELT (COPY-SEQ "012") "xyz") #\a))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (SETF (ELT (COPY-SEQ "012") 100) #\a))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (SETF (ELT (LIST 0 1 2) 100) 0))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (SETF (ELT (LIST 0 1 2) -1) 0))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+
+(HANDLER-CASE (PROGN (FILL 'NOT-A-SEQ 'A))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (FILL #\a 'A))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (FILL (LIST 0 1 2) 'A :START 'NOT-A-INT))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (FILL (LIST 0 1 2) 'A :START -1))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (FILL (LIST 0 1 2) 'A :END 'NOT-A-INT))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (FILL (LIST 0 1 2) 'A :END -1))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (MAKE-SEQUENCE '(VECTOR * 2) 3))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (MAKE-SEQUENCE '(VECTOR * 4) 3))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (MAKE-SEQUENCE '(ARRAY * 3) 2))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (MAKE-SEQUENCE '(ARRAY * (1 2 3)) 2))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (MAKE-SEQUENCE 'SYMBOL 2))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+
+(HANDLER-CASE (PROGN (SUBSEQ 'NOT-A-SEQ 0))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (SUBSEQ #\a 0))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (SETF (SUBSEQ (LIST 0 1 2 3) 1) 'NOT-A-SEQ))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (SETF (SUBSEQ (VECTOR 0 1 2 3) 1) 'NOT-A-SEQ))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (MAP '(VECTOR T 10) #'+ '(0 1) '(1 0)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (MAP 'LIST #'+ '(0 1) '(1 0) 'NOT-A-SEQ))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(progn
+ #-cmu
+ (HANDLER-CASE (PROGN (MAP '(VECTOR * 4) #'CONS "abc" "de"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+ #+cmu 'skipped)
+(progn
+ #-(or cmu clisp)
+ (HANDLER-CASE (PROGN (MAP 'NULL #'CONS "abc" "de"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+ #+(or cmu clisp) 'skipped)
+(progn
+ #-cmu
+ (HANDLER-CASE (PROGN (MAP '(CONS * NULL) #'CONS "abc" "de"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+ #+cmu 'skipped)
+
+
+(HANDLER-CASE (PROGN (MAP-INTO 'NOT-A-SEQ #'+ '(0 1 2)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(progn
+ #-cmu
+ (HANDLER-CASE (PROGN (MAP-INTO (LIST 0 1 2 3) #'+ 'NOT-A-SEQ))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+ #+cmu 'skipped)
+(progn
+ #-cmu
+ (HANDLER-CASE (PROGN (MAP-INTO (LIST 0 1 2 3) #'+ '(0 1) 'NOT-A-SEQ))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+ #+cmu 'skipped)
+
+(HANDLER-CASE (PROGN (REDUCE #'LIST 'NOT-A-SEQUENCE))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (COUNT 0 'NOT-A-SEQUENCE))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (COUNT 0 #\a))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (COUNT-IF #'NUMBERP 'NOT-A-SEQUENCE))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (COUNT-IF #'NUMBERP #\a))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (COUNT-IF-NOT #'NUMBERP 'NOT-A-SEQUENCE))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (COUNT-IF-NOT #'NUMBERP #\a))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (REVERSE 'NOT-A-SEQUENCE))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (NREVERSE 'NOT-A-SEQUENCE))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+
+(HANDLER-CASE (PROGN (FIND 'ITEM 'NOT-A-SEQUENCE))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (FIND-IF (CONSTANTLY NIL) 'NOT-A-SEQUENCE))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (FIND-IF-NOT (CONSTANTLY T) 'NOT-A-SEQUENCE))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (POSITION 'ITEM 'NOT-A-SEQUENCE))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (POSITION-IF (CONSTANTLY NIL) 'NOT-A-SEQUENCE))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (POSITION-IF-NOT (CONSTANTLY T) 'NOT-A-SEQUENCE))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (CONCATENATE '(VECTOR * 2) "a" "bc"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (MERGE '(VECTOR * 4) '(1 5) '(2 4 6) #'<))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (REMOVE 'A 'NOT-A-SEQUENCE))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (REMOVE-IF (CONSTANTLY T) 'NOT-A-SEQUENCE))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE
+ (PROGN (REMOVE-IF-NOT (COMPLEMENT (CONSTANTLY T)) 'NOT-A-SEQUENCE))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (DELETE 'A 'NOT-A-SEQUENCE))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (DELETE-IF (CONSTANTLY T) 'NOT-A-SEQUENCE))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE
+ (PROGN (DELETE-IF-NOT (COMPLEMENT (CONSTANTLY T)) 'NOT-A-SEQUENCE))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (REMOVE-DUPLICATES 'NOT-A-SEQUENCE))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (DELETE-DUPLICATES 'NOT-A-SEQUENCE))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
diff --git a/Sacla/tests/should-string.lisp b/Sacla/tests/should-string.lisp
new file mode 100644
index 0000000..53a4c8b
--- /dev/null
+++ b/Sacla/tests/should-string.lisp
@@ -0,0 +1,28 @@
+;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
+;; ALL RIGHTS RESERVED.
+;;
+;; $Id: should-string.lisp,v 1.8 2004/02/20 07:23:42 yuji Exp $
+;;
+;; 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.
+;;
+;; 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.
+
diff --git a/Sacla/tests/should-symbol.lisp b/Sacla/tests/should-symbol.lisp
new file mode 100644
index 0000000..9628622
--- /dev/null
+++ b/Sacla/tests/should-symbol.lisp
@@ -0,0 +1,227 @@
+;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
+;; ALL RIGHTS RESERVED.
+;;
+;; $Id: should-symbol.lisp,v 1.7 2004/02/20 07:23:42 yuji Exp $
+;;
+;; 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.
+;;
+;; 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.
+
+(HANDLER-CASE (PROGN (MAKE-SYMBOL 'NOT-A-STRING))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (MAKE-SYMBOL #\a))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (MAKE-SYMBOL '(NAME)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (COPY-SYMBOL "NOT A SYMBOL"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (COPY-SYMBOL #\a))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (COPY-SYMBOL '(NAME)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+
+(HANDLER-CASE (PROGN (GENSYM 'EAT-THIS))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (GENSYM -1))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (GENSYM #\a))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+
+(HANDLER-CASE (PROGN (GENTEMP 'NOT-A-STRING))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (GENTEMP #\a))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (GENTEMP "TEMP" '(NIL)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+
+(HANDLER-CASE (PROGN (SYMBOL-FUNCTION "not-a-function"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (SYMBOL-FUNCTION #\a))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (SYMBOL-FUNCTION '(NIL)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE
+ (PROGN (FMAKUNBOUND 'SYMBOL-FOR-TEST) (SYMBOL-FUNCTION 'SYMBOL-FOR-TEST))
+ (UNDEFINED-FUNCTION NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (SYMBOL-NAME "not-a-symbol"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (SYMBOL-NAME #\a))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (SYMBOL-NAME '(NIL)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (SYMBOL-PACKAGE "not-a-symbol"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (SYMBOL-PACKAGE #\a))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (SYMBOL-PACKAGE '(NIL)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (SYMBOL-PLIST "not-a-symbol"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (SYMBOL-PLIST #\a))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (SYMBOL-PLIST '(NIL)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (SYMBOL-VALUE "not-a-symbol"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (SYMBOL-VALUE #\a))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (SYMBOL-VALUE '(NIL)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (PROGN (MAKUNBOUND 'A) (SYMBOL-VALUE 'A)))
+ (UNBOUND-VARIABLE NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+
+
+(HANDLER-CASE (PROGN (GET "not-a-symbol" 'A))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (GET #\a 'A))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (GET '(NIL) 'A))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+
+
+(HANDLER-CASE (PROGN (REMPROP "not-a-symbol" 'A))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (REMPROP #\a 'A))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (REMPROP '(NIL) 'A))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (BOUNDP "not-a-symbol"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (BOUNDP #\a))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (BOUNDP '(NIL)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (MAKUNBOUND "not-a-symbol"))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (MAKUNBOUND #\a))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (MAKUNBOUND '(NIL)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (SET "not-a-symbol" 1))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (SET #\a 0))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (SET '(NIL) 2))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
diff --git a/Sacla/tests/x-sequence.lisp b/Sacla/tests/x-sequence.lisp
new file mode 100644
index 0000000..1c43652
--- /dev/null
+++ b/Sacla/tests/x-sequence.lisp
@@ -0,0 +1,300 @@
+;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
+;; ALL RIGHTS RESERVED.
+;;
+;; $Id: x-sequence.lisp,v 1.11 2004/02/20 07:23:42 yuji Exp $
+;;
+;; 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.
+;;
+;; 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.
+
+(HANDLER-CASE (PROGN (SUBSEQ '(0 1 . 2) 1))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (SUBSEQ '#1=(0 1 . #1#) 3))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (MAP 'LIST #'+ '(0 1 . 2) '(1 0 -1 -2)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (REDUCE #'LIST '(1 . 2)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (REDUCE #'LIST '#1=(1 2 3 4 5 6 7 8 9 . #1#)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (REDUCE #'LIST '(A . #1=(1 2 3 4 5 6 7 8 9 . #1#))))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (REDUCE #'LIST '(A B . #1=(1 2 3 4 5 6 7 8 9 . #1#))))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (REDUCE #'LIST '(A B C . #1=(1 2 3 4 5 6 7 8 9 . #1#))))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (REDUCE #'LIST '(A B C D . #1=(1 2 3 4 5 6 7 8 9 . #1#))))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE
+ (PROGN (REDUCE #'LIST '(A B C D E . #1=(1 2 3 4 5 6 7 8 9 . #1#))))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE
+ (PROGN (REDUCE #'LIST '(A B C D E F . #1=(1 2 3 4 5 6 7 8 9 . #1#))))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE
+ (PROGN (REDUCE #'LIST '(A B C D E F G . #1=(1 2 3 4 5 6 7 8 9 . #1#))))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE
+ (PROGN (REDUCE #'LIST '(A B C D E F G H . #1=(1 2 3 4 5 6 7 8 9 . #1#))))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE
+ (PROGN (REDUCE #'LIST '(A B C D E F G H I . #1=(1 2 3 4 5 6 7 8 9 . #1#))))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE
+ (PROGN (REDUCE #'LIST '(A B C D E F G H I J . #1=(1 2 3 4 5 6 7 8 9 . #1#))))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE
+ (PROGN
+ (REDUCE #'LIST '(A B C D E F G H I J K . #1=(1 2 3 4 5 6 7 8 9 . #1#))))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+
+(HANDLER-CASE (PROGN (LENGTH '(A . B)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (LENGTH '#1=(0 1 . #1#)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (REDUCE #'LIST '(1 . 2)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (REDUCE #'LIST '#1=(1 2 3 4 5 6 7 8 9 . #1#)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (LENGTH '(A . #1=(1 2 3 4 5 6 7 8 9 . #1#))))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (LENGTH '(A B . #1=(1 2 3 4 5 6 7 8 9 . #1#))))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (LENGTH '(A B C . #1=(1 2 3 4 5 6 7 8 9 . #1#))))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (LENGTH '(A B C D . #1=(1 2 3 4 5 6 7 8 9 . #1#))))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (LENGTH '(A B C D E . #1=(1 2 3 4 5 6 7 8 9 . #1#))))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (LENGTH '(A B C D E F . #1=(1 2 3 4 5 6 7 8 9 . #1#))))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (LENGTH '(A B C D E F G . #1=(1 2 3 4 5 6 7 8 9 . #1#))))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE
+ (PROGN (LENGTH '(A B C D E F G H . #1=(1 2 3 4 5 6 7 8 9 . #1#))))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE
+ (PROGN (LENGTH '(A B C D E F G H I . #1=(1 2 3 4 5 6 7 8 9 . #1#))))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE
+ (PROGN (LENGTH '(A B C D E F G H I J . #1=(1 2 3 4 5 6 7 8 9 . #1#))))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE
+ (PROGN (LENGTH '(A B C D E F G H I J K . #1=(1 2 3 4 5 6 7 8 9 . #1#))))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+
+(HANDLER-CASE (PROGN (REVERSE '(A . B)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (REVERSE '#1=(0 1 . #1#)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (REVERSE '#1=(1 2 3 4 5 6 7 8 9 . #1#)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (REVERSE '(A . #1=(1 2 3 4 5 6 7 8 9 . #1#))))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (REVERSE '(A B . #1=(1 2 3 4 5 6 7 8 9 . #1#))))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (REVERSE '(A B C . #1=(1 2 3 4 5 6 7 8 9 . #1#))))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (REVERSE '(A B C D . #1=(1 2 3 4 5 6 7 8 9 . #1#))))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (REVERSE '(A B C D E . #1=(1 2 3 4 5 6 7 8 9 . #1#))))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (REVERSE '(A B C D E F . #1=(1 2 3 4 5 6 7 8 9 . #1#))))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (REVERSE '(A B C D E F G . #1=(1 2 3 4 5 6 7 8 9 . #1#))))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE
+ (PROGN (REVERSE '(A B C D E F G H . #1=(1 2 3 4 5 6 7 8 9 . #1#))))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE
+ (PROGN (REVERSE '(A B C D E F G H I . #1=(1 2 3 4 5 6 7 8 9 . #1#))))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE
+ (PROGN (REVERSE '(A B C D E F G H I J . #1=(1 2 3 4 5 6 7 8 9 . #1#))))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE
+ (PROGN (REVERSE '(A B C D E F G H I J K . #1=(1 2 3 4 5 6 7 8 9 . #1#))))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+
+(HANDLER-CASE (PROGN (NREVERSE (CONS 'A 'B)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE
+ (PROGN
+ (LET ((A (LIST 0 1)))
+ (SETF (CDDR A) A)
+ (NREVERSE A)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE
+ (PROGN
+ (LET ((A (LIST 0 1 2 3)))
+ (SETF (CDR (NTHCDR 3 A)) A)
+ (NREVERSE A)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE
+ (PROGN
+ (LET ((A (LIST 0 1 2 3 4)))
+ (SETF (CDR (NTHCDR 4 A)) (CDDR A))
+ (NREVERSE A)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (FIND 'ITEM '(A B . C)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (FIND-IF (CONSTANTLY NIL) '(A B . C)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (FIND-IF-NOT (CONSTANTLY T) '(A B . C)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (FIND 'ITEM '#1=(A B . #1#)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (FIND-IF (CONSTANTLY NIL) '#1=(A B . #1#)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (FIND-IF-NOT (CONSTANTLY T) '#1=(A B . #1#)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+
+(HANDLER-CASE (PROGN (POSITION 'ITEM '#1=(A B . #1#)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (POSITION-IF (CONSTANTLY NIL) '#1=(A B . #1#)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))
+(HANDLER-CASE (PROGN (POSITION-IF-NOT (CONSTANTLY T) '#1=(A B . #1#)))
+ (TYPE-ERROR NIL T)
+ (ERROR NIL NIL)
+ (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))