Add Sacla to the repository.

59 files changed, 44041 insertions, 0 deletions

diff --git a/COPYING.Sacla b/COPYING.Sacla
new file mode 100644
index 0000000..293e28c
--- /dev/null
+++ b/COPYING.Sacla
@@ -0,0 +1,35 @@
+*** IMPORTANT: The following license applies to the Sacla source code in
+the Sacla/ subdirectory.  For everything else, see the file COPYING. ***
+
+Sacla is a common lisp implementation wannabe.
+It is very much a work in progress.
+See Sacla/init.lisp for how to play with the current sacla.
+
+Sacla's license is a so called 2 clause BSD license.
+
+;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
+;; ALL RIGHTS RESERVED.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions
+;; are met:
+;; 
+;;  * Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;;  * Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in
+;;    the documentation and/or other materials provided with the
+;;    distribution.
+;; 
+;; 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/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))