diff options
Diffstat (limited to 'Sacla')
58 files changed, 44006 insertions, 0 deletions
diff --git a/Sacla/array.lisp b/Sacla/array.lisp new file mode 100644 index 0000000..4fd0147 --- /dev/null +++ b/Sacla/array.lisp @@ -0,0 +1,137 @@ +;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp> +;; ALL RIGHTS RESERVED. +;; +;; $Id: array.lisp,v 1.4 2004/02/20 07:12:10 yuji Exp $ +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; * Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; * Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + +(defun aref (array &rest subscripts) + "Access an element of ARRAY specified by SUBSCRIPTS." + (row-major-aref array (apply #'array-row-major-index array subscripts))) + +(defsetf aref (array &rest subscripts) (value) + "Set VALUE onto the element of ARRAY specified by SUBSCRIPTS." + `(setf (row-major-aref ,array (array-row-major-index ,array ,@subscripts)) + ,value)) + +(defun array-dimension (array axis-number) + "Return AXIS-NUMBER dimension of ARRAY." + (nth axis-number (array-dimensions array))) + +(defun array-in-bounds-p (array &rest subscripts) + "Return true if SUBSCRIPTS are all in bounds for ARRAY, otherwise false." + (and (not (some #'minusp subscripts)) + (every #'< subscripts (array-dimensions array)))) + +(defun array-rank (array) + "Return the number of dimensions of ARRAY." + (length (array-dimensions array))) + +(defun array-row-major-index (array &rest subscripts) + "Compute the row-major index of the element of ARRAY specified by SUBSCRIPTS." + (assert (apply #'array-in-bounds-p array subscripts)) + (apply #'+ (maplist #'(lambda (x y) + (* (car x) (apply #'* (cdr y)))) + subscripts + (array-dimensions array)))) + +(defun array-total-size (array) + "Return the total number of elements in ARRAY." + (apply #'* (array-dimensions array))) + + +(defun vector (&rest objects) + "Create a fresh simple general vector whose elements are OBJECTS." + (make-array (length objects) + :element-type t + :initial-contents objects)) + +(defun vector-pop (vector) + "Decrease the fill pointer of VECTOR by one and return the top element." + (check-type vector vector) + (assert (and (array-has-fill-pointer-p vector) + (plusp (fill-pointer vector)))) + (aref vector (setf (fill-pointer vector) (1- (fill-pointer vector))))) + +(defun vector-push (new-element vector) + "Try to store NEW-ELEMENT in VECTOR's element designated by the fill pointer." + (let ((fill-pointer (fill-pointer vector))) + (when (< fill-pointer (array-dimension vector 0)) + (setf (aref vector fill-pointer) new-element) + (setf (fill-pointer vector) (1+ fill-pointer)) + fill-pointer))) + +(defun vector-push-extend (new-element vector &optional + (extension (1+ (length vector)))) + "Do the same thing as vector-push but extend VECTOR when space is lacking." + (when (>= (fill-pointer vector) (array-dimension vector 0)) + (assert (adjustable-array-p vector)) + (adjust-array vector (+ (fill-pointer vector) extension))) + (vector-push new-element vector)) + +(defun vectorp (object) + "Return true if OBJECT is of type vector; otherwise, return false." + (and (arrayp object) + (eql (array-rank object) 1))) + + +(defun bit-andc1 (bit-array1 bit-array2 &optional opt-arg) + "And complement of BIT-ARRAY1 with BIT-ARRAY2." + (bit-and (bit-not bit-array1 opt-arg) bit-array2 opt-arg)) + +(defun bit-andc2 (bit-array1 bit-array2 &optional opt-arg) + "And BIT-ARRAY1 with complement of BIT-ARRAY2." + (bit-and bit-array1 (bit-not bit-array2) opt-arg)) + +(defun bit-eqv (bit-array1 bit-array2 &optional opt-arg) + "Exclusive nor (equivalence) between BIT-ARRAY1 and BIT-ARRAY2." + (bit-not (bit-xor bit-array1 bit-array2 opt-arg) opt-arg)) + +(defun bit-nand (bit-array1 bit-array2 &optional opt-arg) + "Complement of BIT-ARRAY1 and BIT-ARRAY2." + (bit-not (bit-and bit-array1 bit-array2 opt-arg) opt-arg)) + +(defun bit-nor (bit-array1 bit-array2 &optional opt-arg) + "Complement of BIT-ARRAY1 or BIT-ARRAY2." + (bit-not (bit-ior bit-array1 bit-array2 opt-arg) opt-arg)) + +(defun bit-orc1 (bit-array1 bit-array2 &optional opt-arg) + "Or complement of BIT-ARRAY1 with BIT-ARRAY2." + (bit-ior (bit-not bit-array1 opt-arg) bit-array2 opt-arg)) + +(defun bit-orc2 (bit-array1 bit-array2 &optional opt-arg) + "Or BIT-ARRAY1 with complement of BIT-ARRAY2." + (bit-ior bit-array1 (bit-not bit-array2) opt-arg)) + + +(defun bit-vector-p (object) + "Return true if OBJECT is of type bit-vector; otherwise, return false." + (and (vectorp object) + (eq (array-element-type object) 'bit))) + +(defun simple-bit-vector-p (object) + "Return true if OBJECT is of type simple-bit-vector; otherwise, return false." + (and (bit-vector-p object) + (typep object 'simple-array))) diff --git a/Sacla/character.lisp b/Sacla/character.lisp new file mode 100644 index 0000000..9a7e34c --- /dev/null +++ b/Sacla/character.lisp @@ -0,0 +1,152 @@ +;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp> +;; ALL RIGHTS RESERVED. +;; +;; $Id: character.lisp,v 1.6 2004/02/20 07:23:42 yuji Exp $ +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; * Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; * Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(defun char/= (character &rest more-characters) + "Return true if all characters are different; otherwise, return false." + (do ((c character) + (list more-characters (cdr list))) + ((atom list) t) + (when (member c list :test #'char=) + (return nil)) + (setq c (car list)))) + +(defun char> (character &rest more-characters) + "Return true if the characters are monotonically decreasing." + (do ((c character) + (list more-characters (cdr list))) + ((atom list) t) + (when (or (char= c (car list)) (char< c (car list))) + (return nil)) + (setq c (car list)))) + +(defun char<= (character &rest more-characters) + "Return true if the characters are monotonically nondecreasing;" + (do ((c character) + (list more-characters (cdr list))) + ((atom list) t) + (when (char> c (car list)) + (return nil)) + (setq c (car list)))) + +(defun char>= (character &rest more-characters) + "Return true if the characters are monotonically nonincreasing." + (do ((c character) + (list more-characters (cdr list))) + ((atom list) t) + (when (char< c (car list)) + (return nil)) + (setq c (car list)))) + +(defun char-equal (character &rest more-characters) + "Return true if all characters are the same when ignoring the case." + (do ((c character) + (list more-characters (cdr list))) + ((atom list) t) + (unless (char= (char-upcase c) (char-upcase (car list))) + (return nil)) + (setq c (car list)))) + +(defun char-not-equal (character &rest more-characters) + "Return true if all characters are different when ignoring the case." + (do ((c character) + (list more-characters (cdr list))) + ((atom list) t) + (when (member c list :test #'char-equal) + (return nil)) + (setq c (car list)))) + +(defun char-lessp (character &rest more-characters) + "Return true if the chars are monotonically increasing when ignoring the case." + (do ((c character) + (list more-characters (cdr list))) + ((atom list) t) + (unless (char< (char-upcase c) (char-upcase (car list))) + (return nil)) + (setq c (car list)))) + +(defun char-greaterp (character &rest more-characters) + "Return true if the chars are monotonically decreasing when ignoring the case." + (do ((c character) + (list more-characters (cdr list))) + ((atom list) t) + (unless (char> (char-upcase c) (char-upcase (car list))) + (return nil)) + (setq c (car list)))) + +(defun char-not-greaterp (character &rest more-characters) + "Return true if the chars are monotonically nondecreasing when ignoring the case." + (do ((c character) + (list more-characters (cdr list))) + ((atom list) t) + (when (char-greaterp c (car list)) + (return nil)) + (setq c (car list)))) + + +(defun char-not-lessp (character &rest more-characters) + "Return true if the characters are monotonically nonincreasing." + (do ((c character) + (list more-characters (cdr list))) + ((atom list) t) + (when (char-lessp c (car list)) + (return nil)) + (setq c (car list)))) + + +(defun character (designator) + "Return the character denoted by the character designator CHARACTER." + (etypecase designator + (character designator) + ((string 1) (char designator 0)) + (character-designator-simbol (char (symbol-name designator) 0)))) + + +(defun digit-char (weight &optional (radix 10)) + "Return a character which has WEIGHT when considered as a digit in RADIX." + (check-type radix (integer 2 36)) + (if (>= weight radix) + nil + (schar "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" weight))) + +(defun digit-char-p (char &optional (radix 10)) + "Test whether CHAR is a digit in RADIX. If it is, return its weight." + (check-type radix (integer 2 36)) + (position (char-upcase char) + "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" + :end radix)) + +(defconstant standard-chars + " !\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_'abcdefghijklmnopqrstuvwxyz{|}~ +" + "Standard characters") + +(defun standard-char-p (character) + "Return true if CHARACTER is of type standard-char; otherwise, return false." + (check-type character character) + (find character standard-chars :test #'char=)) + diff --git a/Sacla/clos.lisp b/Sacla/clos.lisp new file mode 100644 index 0000000..5805a87 --- /dev/null +++ b/Sacla/clos.lisp @@ -0,0 +1,2539 @@ +;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp> +;; ALL RIGHTS RESERVED. +;; +;; $Id: clos.lisp,v 1.28 2004/09/24 07:31:33 yuji Exp $ +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; * Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; * Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;; Non conformance points to CLOS. +;; * (defmethod allocate-instance ((class structure-class) &rest initargs)) +;; is not implemented. +;; +;; Non conformance points to MOP. +;; * +;; + + +(defparameter *mop-working-p* nil) +(defparameter *symbol-function-is-funcallable-object-p* t) + + + +(defstruct %standard-object + class + (version nil) + storage) + +(defun swap-%standard-object (a b) + (rotatef (%standard-object-class a) (%standard-object-class b)) + (rotatef (%standard-object-version a) (%standard-object-version b)) + (rotatef (%standard-object-storage a) (%standard-object-storage b))) + + + +(defparameter *classes* (make-hash-table) + "The hash table of all classes in CLOS system.") +(defun find-class (symbol &optional errorp environment) ; clos + "Return the class object named by SYMBOL in ENVIRONMENT." + (declare (ignore environment)) + (multiple-value-bind (class presentp) (gethash symbol *classes*) + (if presentp + class + (when errorp (error "Class ~S does not exist." symbol))))) +(defun (setf find-class) (new-class symbol &optional errorp environment) ; clos + "Set the name of NEW-CLASS to SYMBOL in ENVIRONMENT." + (declare (ignore environment)) + (if new-class + (setf (gethash symbol *classes*) new-class) + (remhash symbol *classes*)) + new-class) + + + +(defun plist-member (key plist) + (loop for rest on plist by #'cddr + if (eq key (car rest)) return rest)) + +(defun plist-keys (plist) (loop for key in plist by #'cddr collect key)) + + + +;; AMOP 5.4.2 The defclass Macro http://www.lisp.org/mop/concepts.html#defclass +;; > The relationship between the arguments to the defclass macro and +;; > the arguments received by ensure-generic-function is defined. + +(defun qt? (object) + "Return a quoted form of OBJECT or OBJECT itself if it's self-evaluating." + (flet ((self-evaluating-object-p (object) + (typecase object + ((or number character array) t) + (symbol (or (keywordp object) (member object '(t nil)))) + (t nil)))) + (if (self-evaluating-object-p object) + object + `(quote ,object)))) + +(defun check-direct-slot-spec-options (slot-spec) + (let ((reserved-keys '(:name :initargs :initfunction :readers :writers)) + (multiple-keys '(:initarg :reader :writer :accessor)) + (keys '()) + (name (car slot-spec))) + (dolist (key (plist-keys (cdr slot-spec))) + (cond + ((member key reserved-keys) + (error "Reserved option ~S is wrongly given in slot ~S ." key name)) + ((and (member key keys) (not (member key multiple-keys))) + (error "Option ~S is given more than once in slot ~S." key name)) + (t (push key keys)))))) + +(defun direct-slot-initargs-form (slot-spec) + ;; direct-slot-initargs is a canonicalized slot specification described in + ;; http://www.lisp.org/mop/concepts.html#defclass . + (flet ((specified-more-than-once-p (key) + (< 1 (count key (plist-keys (cdr slot-spec))))) + (quote-keys (plist) + (loop for (key value) on plist by #'cddr nconc `(,(qt? key) ,value)))) + (check-direct-slot-spec-options slot-spec) + (loop for (key value) on (cdr slot-spec) by #'cddr + if (eq key :initform) + nconc `(:initform ',value :initfunction #'(lambda () ,value)) + into plist + else if (eq key :initarg) collect value into initargs + else if (eq key :reader) collect value into readers + else if (eq key :writer) collect value into writers + else if (eq key :accessor) collect value into readers and + collect `(setf ,value) into writers + else if (specified-more-than-once-p key) + if (getf plist key) + do (setf (cdr (last (getf plist key))) `((quote ,value))) + else + nconc `(,key (list ',value)) into plist end + else nconc `(,key ',value) into plist + finally + (return `(list :name ',(car slot-spec) :initargs ',initargs + :readers ',readers :writers ',writers + ,@(quote-keys `(,@plist :initform 'nil :initfunction 'nil + :documentation 'nil))))))) + +(defun class-initargs-form (options) + ;; See http://www.lisp.org/mop/concepts.html#defclass + (labels ((check-options (alist) + (let ((reserved-keys '(:name :direct-default-initargs)) + (keys '())) + (dolist (key (mapcar #'first alist)) + (cond + ((member key reserved-keys) + (error "Reserved option ~S is wrongly given." key)) + ((member key keys) + (error "Option ~S is given more than once." key)) + (t (push key keys)))))) + (direct-default-initargs-form (initargs) + (loop for (key form) on initargs by #'cddr + collect `(list ',key ',form #'(lambda () ,form)) into result + finally (return `(list ,@result)))) + (value-form (key rest) + (case key + (:direct-default-initargs (direct-default-initargs-form rest)) + (:direct-slots `(list ,@(mapcar #'direct-slot-initargs-form rest))) + ((:metaclass :documentation) + (destructuring-bind (value) rest (qt? value))) + (t (qt? rest))))) + (check-options options) + (loop for (key . rest) in options + when (eq key :default-initargs) do (setq key :direct-default-initargs) + nconc `(,(qt? key) ,(value-form key rest)) into result + finally (return `(list ,@result))))) + +(defun <ensure-class> (name &rest initargs) + (apply (if *mop-working-p* #'ensure-class #'ensure-system-class) + name initargs)) + +(defmacro defclass (name direct-superclasses direct-slots &rest options) ; clos + "Define a new class named NAME which is a subclass of DIRECT-SUPERCLASSES." + (let* ((*message-prefix* (format nil "DEFCLASS ~S: " name))) + `(let ((*message-prefix* ,*message-prefix*)) + (apply #'<ensure-class> + ',name + ,(class-initargs-form `((:direct-superclasses ,@direct-superclasses) + (:direct-slots ,@direct-slots) + ,@options)))))) + + + +(defun class-of (object) ; clos + "Return the class of which OBJECT is a direct instance." + ;; 4.3.7 Integrating Types and Classes + ;; http://www.lispworks.com/reference/HyperSpec/Body/04_cg.htm + (cond + ((%standard-object-p object) (%standard-object-class object)) + ((functionp object) (let ((gf (find-generic-function object))) + (if gf + (class-of gf) + (find-class 'function)))) + (t (let ((type (type-of object))) + (or (and (symbolp type) (find-class type)) + (typecase object + ((and symbol (not null)) (find-class 'symbol)) + (character (find-class 'character)) + (hash-table (find-class 'hash-table)) + (sequence (class-of-sequence object)) + ((and array (not vector)) (find-class 'array)) + (number (class-of-number object)) + (stream (class-of-stream object)) + (pathname (typecase object + (logical-pathname (find-class 'logical-pathname)) + (t (find-class 'pathname)))) + (package (find-class 'package)) + (random-state (find-class 'random-state)) + (readtable (find-class 'readtable)) + (restart (find-class 'restart)) + (condition (class-of-condition object)) + (t (find-class 't)))))))) + +(defun frozen-class-instance-p (object) + (and (%standard-object-p object) (null (%standard-object-version object)))) + +(defconstant +unbound-state+ (gensym "UNBOUND-STATE-")) + +(defun slot-value (object slot-name) ; clos + "Return the value of the slot named SLOT-NAME in OBJECT." + (flet ((slot-is-missing () + (slot-missing (class-of object) object slot-name 'slot-value)) + (slot-is-unbound () + (slot-unbound (class-of object) object slot-name))) + (if (frozen-class-instance-p object) + (let ((binding (assoc slot-name (%standard-object-storage object)))) + (if binding + (let ((value (second binding))) + (if (not (eq value +unbound-state+)) + value + (values (slot-is-unbound)))) + (values (slot-is-missing)))) + (let* ((class (class-of object)) + (slot (find-slot class slot-name))) + (if slot + (slot-value-using-class class object slot) + (values (slot-is-missing))))))) + +(defun (setf slot-value) (new-value object slot-name) ; clos + "Set the value of the slot named SLOT-NAME in OBJECT to NEW-VALUE." + (flet ((slot-is-missing () + (slot-missing (class-of object) object slot-name 'setf new-value))) + (if (frozen-class-instance-p object) + (let ((binding (assoc slot-name (%standard-object-storage object)))) + (if binding + (progn + (assert (typep new-value (third binding))) + (setf (second binding) new-value)) + (slot-is-missing))) + (let* ((class (class-of object)) + (slot (find-slot class slot-name))) + (assert (typep new-value (slot-definition-type slot))) + (if slot + (setf (slot-value-using-class class object slot) new-value) + (slot-is-missing)))) + new-value)) + +(defun slot-boundp (instance slot-name) ; clos + "Return true if the slot named SLOT-NAME in INSTANCE is bound." + (flet ((slot-is-missing () + (slot-missing (class-of instance) instance slot-name 'slot-value))) + (if (frozen-class-instance-p instance) + (let ((binding (assoc slot-name (%standard-object-storage instance)))) + (if binding + (not (eq (second binding) +unbound-state+)) + (values (slot-is-missing)))) + (let* ((class (class-of instance)) + (slot (find-slot class slot-name))) + (if slot + (slot-boundp-using-class class instance slot) + (values (slot-is-missing))))))) +(defun find-slot (class slot-name) + (find slot-name (slot-value class 'slots) + :key #'(lambda (slot) (slot-value slot 'name)))) +(defun local-slot-p (slot) (eq (slot-value slot 'allocation) :instance)) + + + +;; for debug +(defmethod print-object ((object %standard-object) stream) + (flet ((slot (object name) + (second (assoc name (%standard-object-storage object))))) + (let ((class (class-of object))) + (cond + ((and (%standard-object-p class) + (assoc 'name (%standard-object-storage class))) + (if (assoc 'name (%standard-object-storage object)) + (format stream "#<~S:(~S)>" (slot class 'name) (slot object 'name)) + (format stream "#<~S:>" (slot class 'name)))) + ((assoc 'name (%standard-object-storage object)) + (format stream "#<:(~S)>" (slot object 'name))) + (t + (format stream "#<(CLOS object)>")))))) + + + +;; 7.1.3 Defaulting of Initialization Arguments +;; http://www.lispworks.com/reference/HyperSpec/Body/07_ac.htm +;; 7.1.4 Rules for Initialization Arguments +;; http://www.lispworks.com/reference/HyperSpec/Body/07_ad.htm +(defun compute-standard-default-initargs (class) + (flet ((default-initargs (class) + (mapappend #'(lambda (class) + (slot-value class 'direct-default-initargs)) + (slot-value class 'precedence-list)))) + (loop for initarg in (default-initargs class) with args = '() + for name = (car initarg) + unless (member name args) + collect initarg and do (push name args)))) + +(defun defaulted-initargs (class initargs) + (append initargs + (loop for (key form func) in (slot-value class 'default-initargs) + ;; each key is unique throughout the iteration. + unless (plist-member key initargs) + nconc `(,key ,(funcall func))))) + + + +(defun finalized-p (class) + (flet ((defclassed-p (class) + (and (%standard-object-p class) (%standard-object-storage class)))) + (when (symbolp class) (setq class (find-class class))) + (and (defclassed-p class) (slot-value class 'finalized-p)))) + +(defun canonicalize-instance (instance) + (let* ((class (class-of instance)) + (initargs (mapcan #'(lambda (binding) + (list (%keyword (first binding)) (second binding))) + (%standard-object-storage instance))) + (defaulted-initargs (defaulted-initargs class initargs)) + (dummy (make-%standard-object + :class class + :storage (allocate-standard-instance-storage class)))) + (standard-shared-initialize dummy t defaulted-initargs) + (swap-%standard-object instance dummy)) + instance) + +(defun make-system-instance (class &rest initargs) + (flet ((alist-storage (plist) + (loop for (key value) on plist by #'cddr + collect (list (intern (string key)) value 't)))) + (let ((instance (make-%standard-object + :class class + :version nil + :storage (alist-storage initargs)))) + (when (finalized-p class) + (canonicalize-instance instance)) + instance))) + +(defun ensure-class-object (name &rest initargs) + (let ((metaclass (let ((metaclass-name (getf initargs :metaclass))) + (when metaclass-name + (ensure-class-object metaclass-name)))) + (class (find-class name))) + (if class + (when initargs + (let* ((dummy (apply #'make-system-instance metaclass initargs))) + (swap-%standard-object class dummy))) + (setf (find-class name) + (apply #'make-system-instance metaclass initargs))) + (find-class name))) + + + +(defun allocate-standard-instance-storage (class) + (let* ((slots (slot-value class 'slots)) + (local-slots (sort (mapcan #'(lambda (slot) + (when (local-slot-p slot) + (list slot))) + slots) + #'< + :key #'(lambda (slot) (slot-value slot 'location)))) + (shared-slots (mapcan #'(lambda (slot) + (when (not (local-slot-p slot)) + (list slot))) + slots))) + (if (frozen-class-instance-p class) + (let ((local-alist (loop for slot in local-slots + for name = (slot-value slot 'name) + for type = (slot-value slot 'type) + collect `(,name ,+unbound-state+ ,type))) + (shared-alist (loop for slot in shared-slots + for name = (slot-value slot 'name) + for binding = (slot-value slot 'shared-binding) + collect (cons name binding)))) + (nconc local-alist shared-alist)) + (make-array (length local-slots) :initial-element +unbound-state+)))) + +(defun class-slot-names (class) + (mapcar #'(lambda (slot) (slot-value slot 'name)) (slot-value class 'slots))) + +(defun standard-shared-initialize (instance slot-names initargs) + (when (eq slot-names 't) + (setq slot-names (class-slot-names (class-of instance)))) + (mapc #'(lambda (slot) + (let ((name (slot-value slot 'name))) + (multiple-value-bind (key value tail) + (get-properties initargs (slot-value slot 'initargs)) + (declare (ignore key)) + (if tail + (setf (slot-value instance name) value) + (when (and (member name slot-names) + (not (slot-boundp instance name)) + (slot-value slot 'initfunction)) + (setf (slot-value instance name) + (funcall (slot-value slot 'initfunction)))))))) + (slot-value (class-of instance) 'slots))) + + + +;; 4.3.5 Determining the Class Precedence List +;; http://www.lispworks.com/reference/HyperSpec/Body/04_ce.htm +(defun topological-sort (classes pairs) + (do (next + (unordered classes (remove next unordered)) + (pairs pairs (remove-if #'(lambda (pair) (eq (first pair) next)) pairs)) + (result nil (cons next result))) + ((null unordered) (nreverse result)) + (setq next (let ((candidates (remove-if #'(lambda (class) + (find class pairs :key #'second)) + unordered))) + (assert (not (null candidates))) + (if (endp (cdr candidates)) + (car candidates) + (block picker + (dolist (class result) + (dolist (super (slot-value class 'direct-superclasses)) + (when (find super candidates) + (return-from picker super)))))))))) + + +(defun compute-standard-class-precedence-list (class) + (labels ((direct-supers (class) (slot-value class 'direct-superclasses)) + (superclasses (class) + (labels ((supers (class) + (unless (eq class (find-class 't 'errorp)) + (let ((directs (direct-supers class))) + (append directs (mapappend #'supers directs)))))) + (remove-duplicates (supers class)))) + (local-precedence-order-pairs (class) + (unless (eq class (find-class 't 'errorp)) + (let ((directs (direct-supers class))) + (mapcar #'list (cons class directs) directs)))) + (pairs (classes) + (delete-duplicates (mapcan #'local-precedence-order-pairs classes) + :test #'equal))) + (let ((classes (cons class (superclasses class)))) + (topological-sort classes (pairs classes))))) + +(defun class-precedence-names (class) ; for debug + (when (symbolp class) (setq class (find-class class 'errorp))) + (mapcar #'(lambda (class) (slot-value class 'name)) + (slot-value class 'precedence-list))) + + + +;; 7.5.3 Inheritance of Slots and Slot Options +;; http://www.lispworks.com/reference/HyperSpec/Body/07_ec.htm +(defun and-types (types) + (labels ((type-eq (a b) (and (subtypep a b) (subtypep b a))) + (proper-subtype-p (subtype type) + (and (not (type-eq subtype type)) (subtypep subtype type)))) + (let ((types (mapcan #'(lambda (type) + (when (notany #'(lambda (t1) + (proper-subtype-p t1 type)) + types) + (list type))) + (remove-duplicates types :test #'type-eq)))) + (if (endp (cdr types)) + (car types) + `(and ,@types))))) + +(defun effective-slot-initargs (class name direct-slots) + (declare (ignorable class)) + (assert (not (null direct-slots))) + (let* ((most-specific-slot (first direct-slots)) + (allocation (slot-value most-specific-slot 'allocation)) + (type (and-types (mapcar #'(lambda (slot) (slot-value slot 'type)) + direct-slots))) + (shared-binding (slot-value most-specific-slot 'shared-binding))) + `(:name ,name + :allocation ,allocation + ,@(or (loop for slot in direct-slots + for initfunction = (slot-value slot 'initfunction) + if initfunction + return `(:initform ,(slot-value slot 'initform) + :initfunction ,(slot-value slot 'initfunction))) + '(:initform nil :initfunction nil)) + :type ,type + :initargs ,(remove-duplicates + (mapappend #'(lambda (slot) + (slot-value slot 'initargs)) + direct-slots)) + :documentation ,(loop for slot in direct-slots + for documentation = (slot-value slot 'documentation) + if documentation return it) + :location nil + :shared-binding ,(prog1 shared-binding + (when shared-binding + (setf (cdr shared-binding) (list type))))))) + +(defun effective-slot-specs (class) + ;; effective-slot-spec::= (name ([[direct-slot-object*]])) + (let* ((direct-slots (mapappend #'(lambda (class) + (slot-value class 'direct-slots)) + (slot-value class 'precedence-list))) + (names (remove-duplicates (mapcar #'(lambda (slot) + (slot-value slot 'name)) + direct-slots)))) + (mapcar #'(lambda (name) + (list name (loop for slot in direct-slots + if (eq name (slot-value slot 'name)) + collect slot))) + names))) + +(defun standard-direct-slot-definition (slot-spec) + (setq slot-spec `(:shared-binding ,(when (eq :class + (getf slot-spec :allocation)) + (list +unbound-state+)) + ,@slot-spec :allocation :instance :type t)) + (let ((class (ensure-class-object 'standard-direct-slot-definition))) + (apply #'make-system-instance class slot-spec))) + +(defun assign-slots-locations (slots) + (loop for slot in slots with location = 0 + if (local-slot-p slot) + do (setf (slot-value slot 'location) location) + (incf location)) + slots) + +(defun compute-system-class-slots (class) + (let* ((slot-class (ensure-class-object 'standard-effective-slot-definition)) + (slots (mapcar #'(lambda (initargs) + (apply #'make-system-instance slot-class initargs)) + (mapcar #'(lambda (spec) + (apply #'effective-slot-initargs class spec)) + (effective-slot-specs class))))) + (assign-slots-locations slots) + slots)) + +(defconstant +funcallable-instance-function-slot-name+ + (gensym "FUNCALLABLE-INSTANCE-FUNCTION-SLOT-NAME-")) +(defconstant +funcallable-instance-function-slot-spec+ + (let ((name +funcallable-instance-function-slot-name+)) + (eval (direct-slot-initargs-form `(,name :initarg ,name))))) + +(defun canonicalize-system-class-initargs (name &rest initargs &key + (metaclass 'standard-class) + direct-slots direct-superclasses + &allow-other-keys) + (when (eq metaclass 'funcallable-standard-class) + (push +funcallable-instance-function-slot-spec+ direct-slots)) + (assert (not (null direct-superclasses))) + (setq direct-superclasses (mapcar #'ensure-class-object direct-superclasses) + direct-slots (mapcar #'standard-direct-slot-definition direct-slots)) + `(:name ,name :version nil :slots nil :precedence-list nil + :default-initargs nil :finalized-p nil :direct-subclasses nil + :direct-superclasses ,direct-superclasses :direct-slots ,direct-slots + :direct-default-initargs nil :metaclass ,metaclass ,@initargs)) + +(defun subclassp (subclass class) + (when (symbolp subclass) (setq subclass (find-class subclass 'errorp))) + (when (symbolp class) (setq class (find-class class 'errorp))) + (member class (slot-value subclass 'precedence-list))) +(defun instancep (object class) (subclassp (class-of object) class)) + +(defun canonicalize-system-instances (new-class) + (let ((name (slot-value new-class 'name))) + (cond + ((subclassp new-class (ensure-class-object 'base-class)) + (loop for class being the hash-values of *classes* + do (when (eq (class-of class) new-class) + (canonicalize-instance class)))) + ((eq name 'standard-direct-slot-definition) + (loop for class being the hash-values of *classes* + do (when (finalized-p class) + (dolist (slot (slot-value class 'direct-slots)) + (canonicalize-instance slot))))) + ((eq name 'standard-effective-slot-definition) + (loop for class being the hash-values of *classes* + do (when (finalized-p class) + (dolist (slot (slot-value class 'slots)) + (canonicalize-instance slot)))))))) + +(defun finalize-system-class-inheritance (class) + (setf (slot-value class 'precedence-list) + (compute-standard-class-precedence-list class)) + (setf (slot-value class 'slots) + (compute-system-class-slots class)) + (setf (slot-value class 'default-initargs) + (compute-standard-default-initargs class)) + (setf (slot-value class 'finalized-p) t) + (dolist (super (slot-value class 'direct-superclasses)) + (pushnew class (slot-value super 'direct-subclasses))) + + (canonicalize-system-instances class)) + +(defun ensure-system-class (name &rest initargs) + (format t "~&ensure-system-class: class name = ~S~%" name) + (let* ((initargs (apply #'canonicalize-system-class-initargs name initargs)) + (class (apply #'ensure-class-object name initargs))) + (finalize-system-class-inheritance class) + class)) + + +;;; Inheritance Structure of Metaobject Classes specified by MOP +;; http://www.lisp.org/mop/concepts.html#inherit-struct-figure +;; +;; t-+- standard-object +;; | +- a class defined by DEFCLASS +;; | +- *metaobject -+- *specializer +;; | | | +- *class -+- standard-class +;; | | | | +- funcallable-standard-class +;; | | | | +- forward-referenced-class +;; | | | | +- structure-class +;; | | | | +- built-in-class +;; | | | +- eql-specializer +;; | | +- *method - standard-method +;; | | | +- *standard-accessor-method +;; | | | + standard-reader-method +;; | | | + standard-writer-method +;; | | +- *method-combination +;; | | +- *slot-definition +;; | | | +- *effective-slot-definition ---------+ +;; | | | +- *direct-slot-definition --------+ | +;; | +------+ | +- *standard-slot-definition | | +;; | | | + standard-direct-slot-definition | +;; | | | + standard-effective-slot-definition +;; | | | +;; | | +----------+ +;; +- function | | +;; | | | | +;; | funcallable-standard-object | +;; | | | +;; | | +-------------------+ +;; | | | +;; | *generic-function +;; | | +;; | standard-generic-function +;; | +;; +- structure-object +;; | | +;; | +- a structure defined by DEFSTRUCT +;; +;; Each class marked with a ``*'' is an abstract class and is not +;; intended to be instantiated. The results are undefined if an attempt +;; is made to make an instance of one of these classes with make-instance. + +;; Current build time DEFCLASS limitations. +;; * superclasses must be defclassed before their subclasses. +;; * shared slots are not supported (partially implemented). + +(defclass t (t) () + (:documentation "A superclass of every class, including itself.") + (:metaclass built-in-class)) +(defclass standard-object (t) () + (:documentation "A superclass of every class that is an instance of standard-class except itself.")) +(defclass metaobject (standard-object) ()) ; mop abstract +(defclass specializer (metaobject) ; mop abstract + ((direct-methods :reader specializer-direct-methods + :initarg :direct-methods :initform nil) + (direct-generic-functions :reader specializer-direct-generic-functions + :initarg :direct-generic-functions :initform nil))) + + +(defclass class (specializer) ; clos abstract + ((name :accessor class-name :initarg :name :initform nil))) +(defclass base-class (class) + ((version :accessor class-version :initarg :version :initform nil) + (slots :reader class-slots :initarg :slots :initform nil) + (direct-slots :reader class-direct-slots :initarg :direct-slots :initform nil) + (precedence-list :reader class-precedence-list + :initarg :precedence-list :initform nil) + (direct-superclasses :accessor class-direct-superclasses + :initarg :direct-superclasses :initform nil) + (direct-subclasses :accessor class-direct-subclasses + :initarg :direct-subclasses :initform nil) + (default-initargs :reader class-default-initargs + :initarg :default-initargs :initform nil) + (direct-default-initargs :reader class-direct-default-initargs + :initarg :direct-default-initargs :initform nil) + (finalized-p :reader class-finalized-p :initarg :finalized-p :initform nil) + (documentation :initform nil :initarg :documentation))) +(defclass standard-base-class (base-class) + ((version :initform 0) + (old-classes :reader class-old-classes + :initform (make-array 1 :adjustable t :fill-pointer 0)) + (dependents :initform nil))) +(defclass standard-class (standard-base-class) ()) ; clos +(defclass funcallable-standard-class (standard-base-class) ; mop + ((direct-superclasses + :initform (list (find-class 'funcallable-standard-object))))) +(defclass forward-referenced-class (class) ; mop + ((direct-subclasses :accessor class-direct-subclasses :initform nil))) +(defclass structure-class (base-class) ; clos + () + (:metaclass structure-class)) +(defclass built-in-class (base-class) ()) ; clos +(defclass old-class (class) + ((version :reader class-version) + (slots :reader class-slots))) + + +(defvar *eql-specializers* (make-hash-table)) +(defclass eql-specializer (specializer) ; mop + ((object :initarg :object))) +(defun eql-specializer-object (eql-specializer) ; mop + (slot-value eql-specializer 'object)) +(defun find-eql-specializer (object) (gethash object *eql-specializers*)) +(defun intern-eql-specializer (object) ; mop + (or (find-eql-specializer object) + (setf (gethash object *eql-specializers*) + (make-instance 'eql-specializer :object object)))) + + +(defclass slot-definition (metaobject) ()) ; mop abstract +(defclass standard-slot-definition (slot-definition) ; mop abstract + ((name :reader slot-definition-name :initarg :name) + (type :reader slot-definition-type :initarg :type :initform 't) + (allocation :reader slot-definition-allocation + :initarg :allocation :initform :instance) + (initargs :reader slot-definition-initargs :initarg :initargs) + (initform :reader slot-definition-initform :initarg :initform) + (initfunction :reader slot-definition-initfunction + :initarg :initfunction) + (shared-binding :reader slot-definition-shared-binding + :initarg :shared-binding) + (documentation :initarg :documentation)) + (:default-initargs :name (error "Slot name must be specified."))) +(defclass direct-slot-definition (slot-definition) ; mop abstract + ((readers :reader slot-definition-readers :initarg :readers) + (writers :reader slot-definition-writers :initarg :writers))) +(defclass effective-slot-definition (slot-definition) ; mop abstract + ((location :reader slot-definition-location :initarg :location))) +(defclass standard-direct-slot-definition (standard-slot-definition + direct-slot-definition) ; mop + ()) +(defclass standard-effective-slot-definition (standard-slot-definition + effective-slot-definition) ; mop + ()) + + +(defclass method (metaobject) ()) ; clos abstract +(defclass standard-method (method) ; clos + ((function :reader method-function :initarg :function) + (qualifiers :reader method-qualifiers :initarg :qualifiers) + (specializers :reader method-specializers :initarg :specializers) + (specialized-lambda-list :reader method-specialized-lambda-list + :initarg :specialized-lambda-list) + (lambda-list :reader method-lambda-list :initarg :lambda-list) + (generic-function :reader method-generic-function + :initarg :generic-function) + )) +(defclass standard-accessor-method (standard-method) ()) ; mop abstract +(defclass standard-reader-method (standard-accessor-method) ; mop + ()) +(defclass standard-writer-method (standard-accessor-method) ; mop + ()) + + +(defclass function (t) () (:metaclass built-in-class)) +(defclass funcallable-standard-object (standard-object function) ; mop + () + (:metaclass funcallable-standard-class)) +(defun funcallable-instance-function (funcallable-instance) + (slot-value funcallable-instance +funcallable-instance-function-slot-name+)) + +(defun set-funcallable-instance-function (funcallable-instance function) ; mop + (setf (slot-value funcallable-instance + +funcallable-instance-function-slot-name+) + function)) +(defclass generic-function (metaobject funcallable-standard-object) () + ;; clos abstract + (:metaclass funcallable-standard-class)) +(defclass standard-generic-function (generic-function) ; clos + ((name :reader generic-function-name :initarg :name) + (lambda-list :reader generic-function-lambda-list + :initarg :lambda-list) + (argument-precedence-order :reader generic-function-argument-precedence-order + :initarg :argument-precedence-order) + (declarations :reader generic-function-declarations + :initarg :declarations) + (method-class :reader generic-function-method-class + :initarg :method-class) + (method-combination :reader generic-function-method-combination + :initarg :method-combination) + (methods :reader generic-function-methods :initarg :methods) + + (number-of-required-args :reader number-of-required-args + :initarg :number-of-required-args) + (applicable-methods :reader generic-function-applicable-methods + :initform (make-hash-table)) + (effective-methods :reader generic-function-effective-methods + :initform (make-hash-table :test #'equal)) + (dependents :initform nil))) + + +(defclass structure-object (t) () + (:documentation "A superclass of every class that is an instance of structure-class except itself.") + (:metaclass structure-class)) + + +;; Classes that correspond to pre-defined type specifiers +;; http://www.lispworks.com/reference/HyperSpec/Body/04_cg.htm#classtypecorrespondence +(defclass symbol (t) () (:metaclass built-in-class)) +(defclass character (t) () (:metaclass built-in-class)) +(defclass hash-table (t) () (:metaclass built-in-class)) + +(defclass sequence (t) () (:metaclass built-in-class)) +(defclass list (sequence) () (:metaclass built-in-class)) +(defclass cons (list) () (:metaclass built-in-class)) +(defclass null (symbol list) () (:metaclass built-in-class)) +(defclass array (t) () (:metaclass built-in-class)) +(defclass vector (array sequence) () (:metaclass built-in-class)) +(defclass bit-vector (vector) () (:metaclass built-in-class)) +(defclass string (vector) () (:metaclass built-in-class)) + +(defclass number (t) () (:metaclass built-in-class)) +(defclass complex (number) () (:metaclass built-in-class)) +(defclass real (number) () (:metaclass built-in-class)) +(defclass float (real) () (:metaclass built-in-class)) +(defclass rational (real) () (:metaclass built-in-class)) +(defclass ratio (rational) () (:metaclass built-in-class)) +(defclass integer (rational) () (:metaclass built-in-class)) + +(defclass stream (t) () (:metaclass built-in-class)) +(defclass broadcast-stream (stream) () (:metaclass built-in-class)) +(defclass concatenated-stream (stream) () (:metaclass built-in-class)) +(defclass string-stream (stream) () (:metaclass built-in-class)) +(defclass echo-stream (stream) () (:metaclass built-in-class)) +(defclass synonym-stream (stream) () (:metaclass built-in-class)) +(defclass file-stream (stream) () (:metaclass built-in-class)) +(defclass two-way-stream (stream) () (:metaclass built-in-class)) + +(defclass pathname (t) () (:metaclass built-in-class)) +(defclass logical-pathname (pathname) () (:metaclass built-in-class)) + +(defclass package (t) () (:metaclass built-in-class)) +(defclass random-state (t) () (:metaclass built-in-class)) +(defclass readtable (t) () (:metaclass built-in-class)) +(defclass restart (t) () (:metaclass built-in-class)) + + + +(defclass method-combination (metaobject) ()) ; clos +(defstruct method-combination-type + (name) + (lambda-list) + (group-specifiers) + (args-lambda-list) + (generic-function-symbol) + (documentation) + (function) + (short-form-options)) +(defclass standard-method-combination (method-combination) ; clos + ((type :reader method-combination-type :initarg :type) + (arguments :reader method-combination-arguments :initarg :arguments))) + +(defparameter *method-combination-types* (make-hash-table)) + +(defun define-method-combination-type (name &rest initargs) + (let ((combination-type (apply #'make-method-combination-type + :allow-other-keys t :name name initargs))) + (setf (gethash name *method-combination-types*) combination-type))) + +(defun method-group-p (selecter qualifiers) + ;; selecter::= qualifier-pattern | predicate + (etypecase selecter + (list (or (equal selecter qualifiers) + (let ((last (last selecter))) + (when (eq '* (cdr last)) + (let* ((prefix `(,@(butlast selecter) ,(car last))) + (pos (mismatch prefix qualifiers))) + (or (null pos) (= pos (length prefix)))))))) + ((eql *) t) + (symbol (funcall (symbol-function selecter) qualifiers)))) + +(defun check-variable-name (name) + (flet ((valid-variable-name-p (name) + (and (symbolp name) (not (constantp name))))) + (assert (valid-variable-name-p name)))) + +(defun canonicalize-method-group-spec (spec) + ;; spec ::= (name {qualifier-pattern+ | predicate} [[long-form-option]]) + ;; long-form-option::= :description description | :order order | + ;; :required required-p + ;; a canonicalized-spec is a simple plist. + (let* ((rest spec) + (name (prog2 (check-variable-name (car rest)) + (car rest) + (setq rest (cdr rest)))) + (option-names '(:description :order :required)) + (selecters (let ((end (or (position-if #'(lambda (it) + (member it option-names)) + rest) + (length rest)))) + (prog1 (subseq rest 0 end) + (setq rest (subseq rest end))))) + (description (getf rest :description "")) + (order (getf rest :order :most-specific-first)) + (required-p (getf rest :required))) + `(:name ,name + :predicate #'(lambda (qualifiers) + (loop for item in ',selecters + thereis (method-group-p item qualifiers))) + :description ,description + :order ,order + :required ,required-p))) + +(defconstant +gf-args-variable+ (gensym "GF-ARGS-VARIABLE-") + "A Variable name whose value is a list of all arguments to a generic function.") + +(defun extract-required-part (lambda-list) + (flet ((skip (key lambda-list) + (if (eq (first lambda-list) key) + (cddr lambda-list) + lambda-list))) + (ldiff (skip '&environment (skip '&whole lambda-list)) + (member-if #'(lambda (it) (member it lambda-list-keywords)) + lambda-list)))) + +(defun extract-specified-part (key lambda-list) + (case key + ((&eval &whole) + (list (second (member key lambda-list)))) + (t + (let ((here (cdr (member key lambda-list)))) + (ldiff here + (member-if #'(lambda (it) (member it lambda-list-keywords)) + here)))))) + +(defun extract-optional-part (lambda-list) + (extract-specified-part '&optional lambda-list)) + +(defun parse-define-method-combination-arguments-lambda-list (lambda-list) + ;; Define-method-combination Arguments Lambda Lists + ;; http://www.lispworks.com/reference/HyperSpec/Body/03_dj.htm + (let ((required (extract-required-part lambda-list)) + (whole (extract-specified-part '&whole lambda-list)) + (optional (extract-specified-part '&optional lambda-list)) + (rest (extract-specified-part '&rest lambda-list)) + (keys (extract-specified-part '&key lambda-list)) + (aux (extract-specified-part '&aux lambda-list))) + (values (first whole) + required + (mapcar #'(lambda (spec) + (if (consp spec) + `(,(first spec) ,(second spec) ,@(cddr spec)) + `(,spec nil))) + optional) + (first rest) + (mapcar #'(lambda (spec) + (let ((key (if (consp spec) (car spec) spec)) + (rest (when (consp spec) (rest spec)))) + `(,(if (consp key) key `(,(%keyword key) ,key)) + ,(car rest) + ,@(cdr rest)))) + keys) + (mapcar #'(lambda (spec) + (if (consp spec) + `(,(first spec) ,(second spec)) + `(,spec nil))) + aux)))) + +(defmacro getk (plist key init-form) + "Similar to getf except eval and return INIT-FORM if KEY has no value in PLIST." + (let ((not-exist (gensym)) + (value (gensym))) + `(let ((,value (getf ,plist ,key ,not-exist))) + (if (eq ,not-exist ,value) ,init-form ,value)))) + +(defmacro with-args-lambda-list (args-lambda-list generic-function-symbol + &body forms) + (let ((gf-lambda-list (gensym)) + (nrequired (gensym)) + (noptional (gensym)) + (rest-args (gensym))) + (multiple-value-bind (whole required optional rest keys aux) + (parse-define-method-combination-arguments-lambda-list args-lambda-list) + `(let* ((,gf-lambda-list (slot-value ,generic-function-symbol 'lambda-list)) + (,nrequired (length (extract-required-part ,gf-lambda-list))) + (,noptional (length (extract-optional-part ,gf-lambda-list))) + (,rest-args (subseq ,+gf-args-variable+ (+ ,nrequired ,noptional))) + ,@(when whole `((,whole ,+gf-args-variable+))) + ,@(loop for var in required and i upfrom 0 + collect `(,var (when (< ,i ,nrequired) + (nth ,i ,+gf-args-variable+)))) + ,@(loop for (var init-form) in optional and i upfrom 0 + collect + `(,var (if (< ,i ,noptional) + (nth (+ ,nrequired ,i) ,+gf-args-variable+) + ,init-form))) + ,@(when rest `((,rest ,rest-args))) + ,@(loop for ((key var) init-form) in keys and i upfrom 0 + collect `(,var (getk ,rest-args ',key ,init-form))) + ,@(loop for (var init-form) in aux and i upfrom 0 + collect `(,var ,init-form))) + ,@forms)))) + +(defun invalid-method-error (method format-control &rest args) + (declare (ignorable method)) + (apply #'error format-control args)) + +(defun method-combination-error (format-control &rest args) + (apply #'error format-control args)) + +(defmacro with-method-groups (method-group-specs methods-form &body forms) + (flet ((grouping-form (spec methods-var) + (let ((predicate (getf spec :predicate)) + (group (gensym)) + (leftovers (gensym)) + (method (gensym))) + `(let ((,group '()) + (,leftovers '())) + (dolist (,method ,methods-var) + (if (funcall ,predicate (slot-value ,method 'qualifiers)) + (push ,method ,group) + (push ,method ,leftovers))) + (ecase ,(getf spec :order) + (:most-specific-last ) + (:most-specific-first (setq ,group (nreverse ,group)))) + ,@(when (getf spec :required) + `((when (null ,group) + (error "Method group ~S must not be empty." + ',(getf spec :name))))) + (setq ,methods-var (nreverse ,leftovers)) + ,group)))) + (let ((rest (gensym)) + (method (gensym))) + `(let* ((,rest ,methods-form) + ,@(mapcar #'(lambda (spec) + `(,(getf spec :name) ,(grouping-form spec rest))) + method-group-specs)) + (dolist (,method ,rest) + (invalid-method-error ,method + "Method ~S with qualifiers ~S does not~ belong ~ + to any method group." + ,method (slot-value ,method 'qualifiers))) + ,@forms)))) + +(defun method-combination-type-lambda + (&key name lambda-list args-lambda-list generic-function-symbol + method-group-specs declarations forms &allow-other-keys) + (let ((methods (gensym))) + `(lambda (,generic-function-symbol ,methods ,@lambda-list) + ,@declarations + (let ((*message-prefix* ,(format nil "METHOD COMBINATION TYPE ~S: " name))) + (with-method-groups ,method-group-specs + ,methods + ,@(if (null args-lambda-list) + forms + `((with-args-lambda-list ,args-lambda-list + ,generic-function-symbol + ,@forms)))))))) + +(defun long-form-method-combination-args (args) + ;; define-method-combination name lambda-list (method-group-specifier*) args + ;; args ::= [(:arguments . args-lambda-list)] + ;; [(:generic-function generic-function-symbol)] + ;; [[declaration* | documentation]] form* + (let ((rest args)) + (labels ((nextp (key) (and (consp (car rest)) (eq key (caar rest)))) + (args-lambda-list () + (when (nextp :arguments) + (prog1 (cdr (car rest)) (setq rest (cdr rest))))) + (generic-function-symbol () + (if (nextp :generic-function) + (prog1 (second (car rest)) (setq rest (cdr rest))) + (gensym))) + (declaration* () + (let ((end (position-if-not #'declarationp rest))) + (when end + (prog1 (subseq rest 0 end) (setq rest (nthcdr end rest)))))) + (documentation? () + (when (stringp (car rest)) + (prog1 (car rest) (setq rest (cdr rest))))) + (form* () rest)) + (let ((declarations '())) + `(:args-lambda-list ,(args-lambda-list) + :generic-function-symbol ,(generic-function-symbol) + :documentation ,(prog2 (setq declarations (declaration*)) + (documentation?)) + :declarations (,@declarations ,@(declaration*)) + :forms ,(form*)))))) + +(defun define-long-form-method-combination (name lambda-list method-group-specs + &rest args) + (let* ((initargs `(:name ,name + :lambda-list ,lambda-list + :method-group-specs + ,(mapcar #'canonicalize-method-group-spec method-group-specs) + ,@(long-form-method-combination-args args))) + (lambda-expression (apply #'method-combination-type-lambda initargs))) + ;;(format t "~&~S~%" lambda-expression) + (apply #'define-method-combination-type name + `(,@initargs + :function ,(compile nil lambda-expression) + :short-form-options nil)))) + +(defun define-short-form-method-combination + (name &key identity-with-one-argument (documentation "") (operator name)) + (define-long-form-method-combination name + '(&optional (order :most-specific-first)) + `((around (:around)) + (primary (,name) :order order :required t)) + documentation + `(let ((form (if (and ,identity-with-one-argument (null (rest primary))) + `(call-method ,(first primary)) + (cons ',operator (mapcar #'(lambda (method) + `(call-method ,method)) + primary))))) + (if around + `(call-method ,(first around) (,@(rest around) (make-method ,form))) + form))) + (let ((combination-type (gethash name *method-combination-types*))) + (setf (method-combination-type-short-form-options combination-type) + `(:documentation ,documentation + :operator ,operator + :identity-with-one-argument ,identity-with-one-argument))) + name) + +(defmacro define-method-combination (name &rest args) ; clos + "Define new types of method combination." + (format t "~&define-method-combination: ~S~%" name) + `(let ((*message-prefix* + ,(format nil "DEFINE-METHOD-COMBINATION ~S: " name))) + (apply #',(if (listp (first args)) + 'define-long-form-method-combination + 'define-short-form-method-combination) ',name ',args))) + + +;; 7.6.6.4 Built-in Method Combination Types +;; http://www.lispworks.com/reference/HyperSpec/Body/07_ffd.htm +(define-method-combination + :identity-with-one-argument t) +(define-method-combination and :identity-with-one-argument t) +(define-method-combination append :identity-with-one-argument t) +(define-method-combination list :identity-with-one-argument t) +(define-method-combination max :identity-with-one-argument t) +(define-method-combination min :identity-with-one-argument t) +(define-method-combination nconc :identity-with-one-argument t) +(define-method-combination or :identity-with-one-argument t) +(define-method-combination progn :identity-with-one-argument t) +(define-method-combination standard () + ((around (:around)) + (before (:before)) + (primary () :required t) + (after (:after))) + (flet ((call-methods (methods) + (mapcar #'(lambda (method) + `(call-method ,method)) + methods))) + (let ((form (if (or before after (rest primary)) + `(multiple-value-prog1 + (progn ,@(call-methods before) + (call-method ,(first primary) + ,(rest primary))) + ,@(call-methods (reverse after))) + `(call-method ,(first primary))))) + (if around + `(call-method ,(first around) + (,@(rest around) + (make-method ,form))) + form)))) + + +;;;; +;#| + +;; AMOP 5.4.5 The defgeneric Macro +;; http://www.lisp.org/mop/concepts.html#defgeneric +;; +;; AMOP 5.4.3 The defmethod Macro +;; http://www.lisp.org/mop/concepts.html#defmethod +;; AMOP 5.4.4 Processing Method Bodies +;; http://www.lisp.org/mop/concepts.html#processing-method-bodies + +(defvar *generic-functions* (make-hash-table)) +(defun find-generic-function (symbol &optional errorp) + (let ((symbol-function function)) + (if (instancep function 'generic-function) + function + (multiple-value-bind (generic-function presentp) + (gethash discriminating-function *generic-functions*) + (if presentp + generic-function + (when errorp + (error "Generic function ~S does not exist." symbol))))))) +(defun install-generic-function (symbol gf) + (let (discriminating-function (compute-discriminating-function gf)) + (if *symbol-function-is-funcallable-object-p* + (when symbol (setf (symbol-function symbol) gf)) + (progn + (remhash (funcallable-instance-function gf) *generic-functions*) + (setf (gethash discriminating-function *generic-functions*) gf) + (when symbol (setf (symbol-function symbol) discriminating-function)))) + (set-funcallable-instance-function gf discriminating-function) + gf)) + + +(defun method-spec (method-description) + ;; method-description::= (:method method-qualifier* specialized-lambda-list + ;; [[declaration* | documentation]] form*) + (let ((rest (progn + (assert (eq :method (car method-description))) + (cdr method-description)))) + (flet ((qualifier* () + (let* ((end (or (position-if #'consp rest) + (error "No specialized lambda list found in ~S." + method-description))) + (method-qualifiers (subseq rest 0 end))) + (assert (notany #'listp method-qualifiers)) + (prog1 method-qualifiers (setq rest (nthcdr end rest))))) + (lambda-list1 () + (let ((specialized-lambda-list (car rest))) + (validate-specialized-lambda-list specialized-lambda-list) + (prog1 specialized-lambda-list (setq rest (cdr rest))))) + (declaration* () + (let ((end (position-if-not #'declarationp rest))) + (when end + (prog1 (subseq rest 0 end) (setq rest (nthcdr end rest)))))) + (documentation? () + (when (stringp (car rest)) + (prog1 (car rest) (setq rest (cdr rest))))) + (form* () rest)) + `(:qualifiers ,(qualifier*) + :specialized-lambda-list ,(lambda-list1) + ,@(let ((decls (declaration*))) + `(:documentation ,(documentation?) + :declarations ,(mapappend #'cdr `(,@decls ,@(declaration*))))) + :forms ,(form*))))) + +(defun method-spec-to-ensure-generic-function-form (name spec env) + (let* ((lambda-list (extract-lambda-list (getf spec :specialized-lambda-list))) + (options (canonicalize-defgeneric-options lambda-list '()))) + `(ensure-generic-function ,name :environment ,env ,@options))) + +(defun allow-other-keys (lambda-list) + (if (and (member '&key lambda-list) + (not (member '&allow-other-keys lambda-list))) + (let* ((key-end (or (position &aux lambda-list) (length lambda-list))) + (aux-part (subseq lambda-list key-end))) + `(,@(subseq lambda-list 0 key-end) &allow-other-keys ,@aux-part)) + lambda-list)) + +(defun make-system-method-lambda () + ) + +(defun <make-method-lambda> + (generic-function method lambda-expression environment) + (funcall (if *mop-working-p* #'make-method-lambda #'make-system-method-lambda) + generic-function method lambda-expression environment)) + +(defun <class-prototype> (class) + (funcall (if *mop-working-p* #'class-prototype #'make-system-instance) + class)) + +(defun method-initargs-form (gf-form environment &key initial-method-p + null-lexical-environment-p specialized-lambda-list + qualifiers documentation declarations forms) + (let* ((lambda-list (extract-lambda-list specialized-lambda-list)) + (specializer-names (extract-specializer-names specialized-lambda-list)) + (gf (gensym)) + (methods (gensym)) ;; used by make-method-lambda + (lambda-expression (gensym)) + (initargs (gensym))) + `(let* ((,gf ,gf-form) + (,method-class (slot-value ,gf 'method-class))) + (multiple-value-bind (,lambda-expression ,initargs) + (<make-method-lambda> ,gf + (<class-prototype> ,method-class) + '(lambda (,+gf-args-variable+ ,methods) + (apply #'(lambda ,(allow-other-keys lambda-list) + (declare ,@declarations) + ,@forms) + ,+gf-args-variable+)) + ,environment) + (append ,initargs + (list + :qualifiers ',qualifiers + :specialized-lambda-list ',specialized-lambda-list + :lambda-list ',lambda-list + :specializers (mapcar #'find-class ,specializer-names) + :documentation ',documentation + :function (compile nil ,(if null-lexical-environment-p + `(eval ,lambda-expression) + 'lambda-expression)) + :initial-method-p ,initial-method-p))))))) + + +(defun check-defgeneric-declarations (declarations) + + ) + +(defun check-singleton-options (options valid-option-names) + (flet ((redundant-option-error (option-name) + (error 'simple-program-error + :format-control "~AOption ~S is given more than once." + :format-arguments (list *message-prefix* option-name))) + (invalid-option-error (option-name) + (error 'simple-program-error + :format-control "~AInvalid option ~S is given." + :format-arguments (list *message-prefix* option-name)))) + (loop for (key . rest) in options with processed = '() + when (member key processed) do (redundant-option-error key) + when (not (member key valid-option-names)) do (invalid-option-error key) + do (push key processed))) + +(defvar generic-function-initarg-names + '(:argument-precedence-order :declare :documentation :environment + :generic-function-class :lambda-list :method-class :method-combination)) + +(defun generic-function-initargs-form (options) + (check-singleton-options options generic-function-initarg-names) + (flet ((value-form (key rest) + (case key + ((:documentation :environment :generic-function-class + :method-class :lambda-list) + (destructuring-bind (value) rest (qt? value))) + (t (qt? rest))))) + (loop for (key . rest) in options + when (eq key :declare) do (setq key :declarations) + nconc `(,(qt? key) ,(value-form key rest)) into result + finally (return `(list ,@result))))) + +(defun ensure-system-generic-function (name &rest initargs) + + ) + +(defun add-system-method (generic-function method) + ) + +(defun <ensure-generic-function> (name &rest initargs) + (apply (if *mop-working-p* + #'ensure-generic-function + #'ensure-system-generic-function) + name initargs)) + +(defun <make-instance> (name &rest initargs) + (apply (if *mop-working-p* #'make-instance #'make-system-instance) + name initargs)) + +(defun <add-method> (generic-function method) + (funcall (if *mop-working-p* #'add-method #'add-system-method) + generic-function method)) + +(defmacro defgeneric (name lambda-list &body args &environment env) ; clos + "Define a generic function named NAME." + (let* ((*message-prefix* (format nil "DEFGENERIC ~S: " name)) + (method-descriptions (loop for spec in args + if (eq (first spec) :method) collect spec)) + (declarations (loop for spec in args + if (eq (first spec) 'declare) append (rest spec))) + (options `((:lambda-list ,lambda-list) + (:environment ,env) + ,@(when declarations `((:declare ,@declarations))) + ,@(loop for spec in args + unless (member (first spec) '(:method declare)) + collect spec))) + (gf (gensym)) + (method-class (gensym)) + (methods (gensym))) + (check-defgeneric-declarations declarations) + `(let* ((*message-prefix* ,*message-prefix*) + (,gf (apply #'<ensure-generic-function> ',name + ,(generic-function-initargs-form options))) + (,method-class (generic-function-method-class ,gf)) + (,methods (list ,@(mapcar + #'(lambda (spec) + `(apply #'<make-instance> ,method-class + :initial-method-p t + ,(apply #'method-initargs-form gf env spec))) + (mapcar #'method-spec method-descriptions))))) + (mapc #'(lambda (method) (<add-method> ,gf method)) ,methods) + ,gf))))) + +(defmacro defmethod (name &rest args &environment env) ; clos + "Define a method named NAME." + (let ((spec (method-spec `(:method ,@args))) + (gf (gensym)) + (method (gensym))) + `(let* ((,gf (or (find-generic-function name) + ,(method-spec-to-ensure-generic-function-form + name spec env))) + (,method (apply #'<make-instance> + (generic-function-method-class ,gf) + (method-initargs-form ,gf ,env ,@spec)))) + (<add-method> ,gf ,method) + ,method))) + +(defgeneric ensure-class-using-class (class name &key direct-default-initargs direct-slots direct-superclasses metaclass &allow-other-keys)) ; mop + +(defmethod ensure-class-using-class ((class class) name &key (metaclass 'standard-class) direct-superclasses &allow-other-keys) + (check-type class metaclass) + (apply #'reinitialize-instance class initargs)) + +(defmethod ensure-class-using-class ((class forward-referenced-class) name &rest initargs &key (metaclass 'standard-class) direct-superclasses &allow-other-keys) + (apply #'change-class class metaclass initargs)) + +(defmethod ensure-class-using-class ((class null) name &rest initargs + &key (metaclass 'standard-class) + direct-superclasses &allow-other-keys) + (setf (find-class name) (apply #'make-instance metaclass initargs))) + +(defun ensure-class (name &rest args &key &allow-other-keys) ; mop + (apply #'ensure-class-using-class (find-class name) name args)) + + + +(defgeneric compute-class-precedence-list (class)) ; mop +(defmethod compute-class-precedence-list ((class class)) + (compute-standard-class-precedence-list class)) + + +(defgeneric compute-default-initargs (class)) ; mop +(defmethod compute-default-initargs ((class standard-base-class)) + (compute-standard-default-initargs class)) + + +(defgeneric effective-slot-definition-class (class &rest initargs)) ; mop +(defmethod effective-slot-definition-class ((class standard-base-class) + &rest initargs) + (find-class 'standard-effective-slot-definition)) +(defgeneric compute-effective-slot-definition + (class name direct-slot-definitions)) ; mop +(defmethod compute-effective-slot-definition ((class standard-base-class) + name direct-slot-definitions) + (apply #'make-instance + (apply #'effective-slot-definition-class class initargs) + (effective-slot-initargs class name direct-slot-definitions))) +(defgeneric compute-slots (class)) ; mop +(defmethod compute-slots :around ((class standard-base-class)) + (let ((slots (call-next-method))) + (assign-slots-locations slots) + slots)) +(defmethod compute-slots ((class standard-base-class)) + (loop for (name direct-slots) in (effective-slot-specs class) + collect (compute-effective-slot-definition class name direct-slots))) + + +(defgeneric finalize-inheritance (class)) ; mop +(defmethod finalize-inheritance ((class standard-base-class)) + ;; see "Class Finalization Protocol" + ;; http://www.lisp.org/mop/concepts.html#class-finalization-protocol + (setf (slot-value class 'precedence-list) (compute-class-precedence-list class)) + (setf (slot-value class 'default-initargs) (compute-default-initargs class)) + (setf (slot-value class 'slots) (compute-slots class)) + (setf (slot-value class 'finalized-p) t) + + class) +(defmethod finalize-inheritance ((class forward-referenced-class)) + (error "Cannot finalize inheritance for forward-referenced-class object.")) +;; ! write an after method which computes a hash-table of slot-names and +;; slot-definition objects which will be used in find-slot. + + +(defgeneric allocate-instance (class &rest initargs &key &allow-other-keys) + (:documentation ;; clos + "Create and return a new instance of CLASS, without initializing it.")) +(defmethod allocate-instance ((class standard-base-class) &rest initargs) + (make-%standard-object :class class + :version (slot-value class 'version) + :storage (allocate-standard-instance-storage class))) +(defmethod allocate-instance ((class structure-class) &rest initargs) + (error "allocate-instance specialized for structure-class is not implemented.")) +(defmethod allocate-instance ((class built-in-class) &rest initargs) + (error "`allocate-instance' is not applicable to built-in-class.")) + +(defgeneric validate-superclass (class superclass)) ; mop +(defmethod validate-superclass ((class class) (superclass class)) + (let ((class-of-class (class-of class-of)) + (class-of-superclass (class-of superclass)) + (standard-class (find-class 'standard-class)) + (funcallable-standard-class (find-class 'funcallable-standard-class))) + ;; http://www.lisp.org/mop/dictionary.html#validate-superclass + (or (eq superclass (find-class 't)) + ;; (i) If the superclass argument is the class named t, + (eq class-of-superclass class-of-class) + ;; (ii) if the class of the class argument is the same as + ;; the class of the superclass argument or + (and (eq class-of-class standard-class) + (eq class-of-superclass funcallable-standard-class)) + (and (eq class-of-class funcallable-standard-class) + (eq class-of-superclass standard-class)) + ;; (iii) if the classes one of the arguments is standard-class and + ;; the class of the other is funcallable-standard-class. + ))) + +(defun canonicalize-direct-superclasses (class direct-superclasses) + (flet ((superclass (designator) + (etypecase designator + (symbol (or (find-class designator) + (ensure-class designator + :metaclass 'forward-referenced-class))) + (class designator)))) + (mapcar #'(lambda (designator) + (let ((superclass (superclass designator))) + (unless (validate-superclass class superclass) + (error "~S cannot be a superclass of ~S" + superclass class)) + superclass)) + direct-superclasses))) + +(defgeneric shared-initialize (instance slot-names &rest initargs + &key &allow-other-keys) + (:documentation ;; clos + "Fill the slots of INSTANCE using INITARGS and :initform forms.")) + +(defmethod shared-initialize ((instance standard-object) slot-names + &rest initargs) + (standard-shared-initialize instance slot-names initargs)) + +(defgeneric check-initargs (instance gf-args-pairs initargs)) +(defmethod check-initargs ((instance standard-object) gf-args-pairs initargs) + (unless (getf initargs :allow-other-keys) + (let* ((class (class-of instance)) + (valid-keys + (remove-duplicates + (nconc (mapappend #'function-keywords + (mapappend #'(lambda (gf-args-pair) + (apply #'applicable-methods + gs-args-pair)) + gf-args-pairs)) + (mapappend #'slot-definition-initargs (class-slots class)) + '(:allow-other-keys)))) + (keys (remove-duplicates (plist-keys initargs))) + (invalid-keys (set-difference keys valid-keys))) + (when invalid-keys + (error "Invalid initialization argument keyword~P: ~S" + (length invalid-keys) invalid-keys))))) +(defmethod check-initargs ((instance standard-slot-definition) + gf-args-pairs initargs) + (let ((initform-supplied-p (plist-member :initform initargs)) + (initfunction-supplied-p (plist-member :initfunction initargs))) + (assert (or (and initform-supplied-p initfunction-supplied-p) + (and (not initform-supplied-p) (not initfunction-supplied-p)))) + (when (and (not initform-supplied-p) (not initfunction-supplied-p)) + (setq initargs `(:initform nil :initfunction nil ,@initargs))) + (call-next-method instance gf-args-pairs initargs))) + +;; ... more check-initargs methods + + +(defmethod shared-initialize ((instance standard-base-class) slot-names + &rest initargs + &key (direct-slots "never used" direct-slots-p)) + (flet ((direct-slot (class spec) + (apply #'make-instance + (apply #'direct-slot-definition-class class spec) + spec))) + (when direct-slots-p + (setq initargs + `(:direct-slots ,(mapcar #'(lambda (spec) (direct-slot instance spec)) + direct-slots) + ,@initargs))) + (apply #'call-next-method instance slot-names initargs) + ;; define readers & writers here using reader-method-class & writer-method-class ! + )) + +(defmethod shared-initialize ((instance standard-class) slot-names &rest initargs &key (direct-superclasses "never used" direct-superclasses-p) (metaclass 'standard-class)) + ;; http://www.lispworks.com/reference/HyperSpec/Body/m_defcla.htm + ;; If the superclass list is empty, then the superclass defaults + ;; depending on the metaclass, with standard-object being the default + ;; for standard-class. + (when direct-superclasses-p + (setq initargs + `(:direct-superclasses + ,(canonicalize-direct-superclasses + instance (or direct-superclasses (list 'standard-object))) + ,@initargs))) + (apply #'call-next-method instance slot-names initargs)) + +(defmethod shared-initialize ((instance funcallable-standard-class) slot-names &rest initargs &key (direct-superclasses "never used" direct-superclasses-p) (metaclass 'funcallable-standard-class)) + ;; http://www.lisp.org/mop/dictionary.html#class-mo-init + ;; if the class is an instance of funcallable-standard-class + ;; or one of its subclasses the default value is list of the class + ;; funcallable-standard-object. + (when direct-superclasses-p + (setq initargs + `(:direct-superclasses + ,(canonicalize-direct-superclasses + instance + (or direct-superclasses (list 'funcallable-standard-object))) + ,@initargs))) + + (apply #'call-next-method instance slot-names initargs) + + (let ((name (getf initargs :name (generic-function-name instance)))) + (install-generic-function name instance)) + + instance) + + +(defgeneric add-direct-subclass (superclass subclass)) ; mop +(defmethod add-direct-subclass ((superclass class) (subclass class)) + (pushnew subclass (class-direct-subclasses superclass))) + +(defgeneric remove-direct-subclass (superclass subclass)) ; mop +(defmethod remove-direct-subclass ((superclass class) (subclass class)) + (setf (class-direct-subclasses superclass) + (remove subclass (class-direct-subclasses superclass)))) + +(defgeneric reinitialize-instance (instance &rest initargs + &key &allow-other-keys) + (:documentation ;; clos + "Change the values of local slots of INSTANCE according to INITARGS.")) +(defmethod reinitialize-instance ((instance standard-object) &rest initargs) + ;; http://www.lispworks.com/reference/HyperSpec/Body/f_reinit.htm + ;; The system-supplied primary method for reinitialize-instance checks + ;; the validity of initargs and signals an error if an initarg is supplied + ;; that is not declared as valid. The method then calls the generic function + ;; shared-initialize with the following arguments: the instance, nil + ;; (which means no slots should be initialized according to their initforms), + ;; and the initargs it received. + (check-initargs instance + `((,#'reinitialize-instance (,instance ,@initargs)) + (,#'shared-initialize (,instance nil ,@initargs))) + initargs) + (apply #'shared-initialize instance nil initargs)) + +(defmethod reinitialize-instance :after ((instance standard-generic-function) + &rest initargs) + (map-dependents instance + #'(lambda (dependent) + (apply #'update-dependent instance dependent initargs)))) + +(defgeneric make-instances-obsolete (class) ; clos + (:documentation "Initiate the process of updating the instances of CLASS.")) +(defmethod make-instances-obsolete ((class standard-base-class)) + (vector-push-extend (make-instance 'old-class :current-class class) + (class-old-classes class)) + (setf (slot-value class 'finalized-p) nil) + (incf (slot-value class 'version)) + (mapc #'(lambda (gf) (clear-gf-cache gf)) + (specializer-direct-generic-functions class)) + (mapc #'(lambda (child) + (when (class-finalized-p child) (make-instances-obsolete child))) + (class-direct-subclasses class)) + class) +(defmethod make-instances-obsolete ((class symbol)) + (apply #'make-instances-obsolete (find-class class))) + +(defmethod reinitialize-instance ((instance standard-base-class) &rest initargs) + (let ((finalizedp (class-finalized-p instance)) + (previous (class-direct-superclasses instance))) + (when finalizedp + (make-instances-obsolete instance)) + (call-next-method) + (let ((current (class-direct-superclasses instance))) + (mapc #'(lambda (super) (remove-direct-subclass super instance)) + (set-difference previous current)) + (mapc #'(lambda (super) (add-direct-subclass super instance)) + (set-difference current previous))) + (when finalizedp + (finalize-inheritance instance) + (map-dependents instance + #'(lambda (dependent) + (apply #'update-dependent + instance dependent initargs)))) + instance)) + + +(defgeneric update-instance-for-different-class (previous current &rest initargs &key &allow-other-keys) + (:documentation ;; clos + "Called only by change-class. Programmers may write methods for it.")) +(defmethod update-instance-for-different-class ((previous standard-object) (current standard-object) &rest initargs) + ;; http://www.lispworks.com/reference/HyperSpec/Body/f_update.htm + ;; The system-supplied primary method on update-instance-for-different-class + ;; checks the validity of initargs and signals an error if an initarg is + ;; supplied that is not declared as valid. This method then initializes slots + ;; with values according to the initargs, and initializes the newly added + ;; slots with values according to their :initform forms. It does this by + ;; calling the generic function shared-initialize with the following + ;; arguments: the instance (current), a list of names of the newly added + ;; slots, and the initargs it received. Newly added slots are those local + ;; slots for which no slot of the same name exists in the previous class. + (let ((added-local-slots (set-difference + (mapcan #'(lambda (slot) + (when (local-slot-p slot) + (list (slot-definition-name slot)))) + (class-slots (class-of current))) + (class-slot-names (class-of previous))))) + (check-initargs current + `((,#'update-instance-for-different-class (,previous + ,current + ,@initargs)) + (,#'shared-initialize (,current + ,added-local-slots + ,@initargs))) + initargs) + (apply #'shared-initialize current added-local-slots initargs))) +(defmethod update-instance-for-different-class :after ((previous forward-referenced-class) (current standard-base-class) &rest initargs) + (mapc #'(lambda (super) (add-direct-subclass super current)) + (class-direct-superclasses current))) + +(defgeneric change-class (instance new-class &key &allow-other-keys) + (:documentation ;; clos + "Change the class of INSTANCE to NEW-CLASS destructively.")) +(defmethod change-class ((instance t) (new-class symbol) &rest initargs) + (apply #'change-class instance (find-class new-class) initargs)) +(defmethod change-class ((instance standard-object) (new-class standard-class) &rest initargs) + (let ((previous (allocate-instance new-class))) + (swap-%standard-object instance previous) + (loop with prev-slot-names = (class-slot-names (class-of previous)) + slot in (mapcan #'(lambda (slot) + (when (and (local-slot-p slot) + (member (slot-definition-name slot) + prev-slot-names)) + (list slot))) + (class-slots new-class)) + name = (slot-definition-name slot) + if (slot-boundp previous name) do (slot-makunbound instance name) + else do (setf (slot-value instance name) (slot-value previous name))) + (apply #'update-instance-for-different-class previous instance initargs))) + + +(defgeneric update-instance-for-redefined-class (instance added-slots discarded-slots property-list &rest initargs &key &allow-other-keys) + (:documentation ;; clos + "Called by the mechanism activated by make-instances-obsolete.")) +(defmethod update-instance-for-redefined-class ((instance standard-object) added-slots discarded-slots property-list &rest initargs) + ;; http://www.lispworks.com/reference/HyperSpec/Body/f_upda_1.htm + ;; The system-supplied primary method on + ;; update-instance-for-redefined-class checks the validity of initargs + ;; and signals an error if an initarg is supplied that is not declared as + ;; valid. This method then initializes slots with values according to the + ;; initargs, and initializes the newly added-slots with values according + ;; to their :initform forms. It does this by calling the generic function + ;; shared-initialize with the following arguments: the instance, a list + ;; of names of the newly added-slots to instance, and the initargs it + ;; received. Newly added-slots are those local slots for which no slot of + ;; the same name exists in the old version of the class. + (let* ((class (class-of instance)) + (added-local-slots (mapcan #'(lambda (name) + (if (local-slot-p (find-slot class name)) + (list name) + nil)) + added-slots))) + (check-initargs instance + `((,#'update-instance-for-redefined-class (,instance + ,added-slots + ,discarded-slots + ,property-list + ,@initargs)) + (,#'shared-initialize (,instance ,added-local-slots + ,@initargs))) + initargs) + (apply #'shared-initialize instance added-local-slots initargs))) + +(defun obsolete-instance-p (instance) + (/= (%standard-object-version instance) + (class-version (class-of instance)))) + +(defun update-obsolete-instance (instance) + (let* ((class (class-of instance)) + (old-class (aref (class-old-classes class) + (%standard-object-version instance))) + (old-instance (allocate-instance class))) + (swap-%standard-object instance old-instance) + (setf (%standard-object-class old-instance) old-class) + (let* ((old (class-slot-names old-class)) + (new (class-slot-names class)) + (common (intersection old new)) + (discarded (set-difference old new)) + (added (set-difference new old))) + (mapc #'(lambda (name) + ;; slots of the same name + ;; old current slot value/unbound state + ;; local shared discarded + ;; shared shared retained + ;; local local retained + ;; shared local retained + (if (and (local-slot-p (find-slot old-class name)) + (not (local-slot-p (find-slot class name)))) + (push name discarded) + (if (slot-boundp old-instance name) + (setf (slot-value instance name) + (slot-value old-instance name)) + (slot-makunbound instance name)))) + common) + (let ((plist (loop for name in discarded + when (slot-boundp old-instance name) + nconc `(,name ,(slot-value old-instance name))))) + (update-instance-for-redefined-class instance added discarded plist))))) + +(defun update-instance-if-obsolete (instance) + (when (obsolete-instance-p object) (update-obsolete-instance object))) + + + +(defgeneric initialize-instance (instance &key &allow-other-keys)) ; clos +(defmethod initialize-instance ((instance standard-object) &rest initargs) + (apply #'shared-initialize instance t initargs)) +(defmethod initialize-instance :after ((instance class) &rest initargs) + (mapc #'(lambda (super) (add-direct-subclass super instance)) + (class-direct-superclasses instance))) + + +(defgeneric make-instance (class &rest initargs &key &allow-other-keys) + (:documentation "Create and return a new instance of CLASS.")) ; clos +(defmethod make-instance ((class symbol) &rest initargs) + (apply #'make-instance (find-class class) initargs)) +(defmethod make-instance ((class funcallable-standard-class) &rest initargs) + (push +funcallable-instance-function-slot-spec+ (getf initargs :direct-slots)) + (apply #'call-next-method class ,@initargs)) +(defmethod make-instance ((class standard-base-class) &rest initargs) + (let ((instance (apply #'allocate-instance class initargs)) + (defaulted-initargs (defaulted-initargs class initargs))) + (check-initargs instance + `((,#'allocate-instance (,class ,@defaulted-initargs)) + (,#'initialize-instance (,instance ,@defaulted-initargs)) + (,#'shared-initialize (,instance t ,@defaulted-initargs))) + defaulted-initargs) + (apply #'initialize-instance instance defaulted-initargs))) +(defmethod make-instance ((class old-class) &rest initargs + &key (current-class (required-argument))) + (let ((instance (apply #'allocate-instance class initargs))) + (check-initargs initargs `(,#'make-instance (,class ,@initargs) initargs)) + (setf (slot-value instance 'name) (slot-value current-class 'name)) + (setf (slot-value instance 'version) (slot-value current-class 'version)) + (setf (slot-value instance 'slots) (copy-seq (slot-value current-class + 'slots))) + instance)) + + +(defgeneric class-name (class) ; clos + (:documentation "Return the name of CLASS.")) +(defgeneric (setf class-name) (name class) ; clos + (:documentation "Set the name of CLASS to NAME.")) +(defgeneric class-direct-slots (class)) ; mop +(defgeneric class-direct-default-initargs (class)) ; mop +(defgeneric class-direct-superclasses (class)) ; mop +(defgeneric class-direct-subclasses (class)) ; mop +(defgeneric class-precedence-list (class)) ; mop +(defgeneric class-default-initargs (class)) ; mop +(defgeneric class-default-initfuncs (class)) +(defgeneric class-slots (class)) ; mop +(defgeneric class-finalized-p (class)) ; mop +(defgeneric class-prototype (class)) ; mop + +(defmethod class-precedence-list :before ((class standard-base-class)) + (unless (class-finalized-p class) (finalize-inheritance class))) +(defmethod class-slots :before ((class standard-base-class)) + (unless (class-finalized-p class) (finalize-inheritance class))) +(defmethod class-default-initargs :before ((class standard-base-class)) + (unless (class-finalized-p class) (finalize-inheritance class))) +(defmethod class-default-initfuncs :before ((class standard-base-class)) + (unless (class-finalized-p class) (finalize-inheritance class))) + + + + +(defmethod documentation ((x standard-base-class) (doc-type (eql 't))) + (slot-value x 'documentation)) +(defmethod documentation ((x standard-base-class) (doc-type (eql 'type))) + (slot-value x 'documentation)) + + + + +(defgeneric direct-slot-definition-class (class &rest initargs)) ; mop +(defmethod direct-slot-definition-class ((class standard-base-class) &rest initargs) + (find-class 'standard-direct-slot-definition)) + + + +(defgeneric specializer-direct-methods (specializer)) ; mop +(defgeneric specializer-direct-generic-functions (specializer)) ; mop + + +(defgeneric add-direct-method (specializer method)) ; mop +(defmethod add-direct-method ((specializer specializer) (method method)) + (pushnew method (slot-value specializer 'direct-methods)) + (pushnew (method-generic-function method) + (slot-value specializer 'direct-generic-functions))) + +(defgeneric remove-direct-method (specializer method)) ; mop +(defmethod remove-direct-method ((specializer specializer) (method method)) + (setf (slot-value specializer 'direct-methods) + (remove method (specializer-direct-methods specializer))) + (let ((gf (method-generic-function method))) + (unless (member gf (mapcar #'method-generic-function + (specializer-direct-methods specializer))) + (setf (slot-value specializer 'direct-generic-functions) + (remove gf (specializer-direct-generic-functions)))))) + + +(defgeneric reader-method-class (class direct-slot &rest initargs)) ; mop +(defmethod reader-method-class ((class standard-base-class) (direct-slot standard-direct-slot-definition) &rest initargs) + (find-class 'standard-reader-method)) + +(defgeneric writer-method-class (class direct-slot &rest initargs)) ; mop +(defmethod writer-method-class ((class standard-base-class) (direct-slot standard-direct-slot-definition) &rest initargs) + (find-class 'standard-writer-method)) + + +(defgeneric add-dependent (metaobject dependent)) ; mop +(defmethod add-dependent ((class standard-base-class) dependent) + (pushnew dependent (slot-value class 'dependents))) +(defmethod add-dependent ((generic-function standard-generic-function) dependent) + (pushnew dependent (slot-value generic-function 'dependents))) +(defgeneric remove-dependent (metaobject dependent)) ; mop +(defmethod remove-dependent ((class standard-base-class) dependent) + (setf (slot-value class 'dependents) + (remove dependent (slot-value class 'dependents)))) +(defmethod remove-dependent + ((generic-function standard-generic-function) dependent) + (setf (slot-value generic-function 'dependents) + (remove dependent (slot-value generic-function 'dependents)))) + +(defgeneric map-dependents (metaobject function)) ; mop +(defmethod map-dependents ((metaobject standard-base-class) function) + (mapc function (slot-value metaobject 'dependents))) +(defmethod map-dependents ((metaobject standard-generic-function) function) + (mapc function (slot-value metaobject 'dependents))) +(defgeneric update-dependent (metaobject dependent &rest initargs)) ; mop + + + +(defgeneric make-load-form (object &optional environment) + (:documentation ;; clos + "Return forms to enable load to construct an object equivalent to OBJECT.")) +(defmethod make-load-form ((object standard-object) &optional environment) + ) +(defmethod make-load-form ((object structure-object) &optional environment) + ) +(defmethod make-load-form ((object condition) &optional environment) + ) +(defmethod make-load-form ((object class) &optional environment) + ) + +(defun make-load-form-saving-slots (object &key slot-names environment) ; clos + "Return forms that will construct an object equivalent to OBJECT." + ) + + + + + + +(defmacro with-accessors (slot-entries instance &body body) ; clos + "Make slots accessible like variables through specified accessors." + (let ((instance (gensym))) + `(let ((,instance ,instance-form)) + (symbol-macrolet (,@(mapcar + #'(lambda (entry) + `(,(first entry) (,(second entry) ,instance))) + slot-entries)) + ,@body)))) + +(defmacro with-slots (slot-entries instance-form &body body) ; clos + "Create a lexical environment where slots are accessible like variables." + (let ((instance (gensym))) + `(let ((,instance ,instance-form)) + (symbol-macrolet (,@(mapcar + #'(lambda (entry) + (if (symbolp entry) + `(,entry (slot-value ,instance ',entry)) + `(,(first entry) + (slot-value ,instance ',(second entry))))) + slot-entries)) + ,@body)))) + + +(defun standard-instance-access (instance location) ; mop + (let ((storage (%standard-object-storage instance))) + (if (frozen-class-instance-p instance) + (second (nth location storage)) + (aref storage location)))) + +(defun funcallable-standard-instance-access (instance location) + (standard-instance-access instance location)) + +(defun refer-slot-using-class (class object slot) + (update-instance-if-obsolete object) + (if (local-slot-p slot) + (let (location (slot-definition-location slot)) + (aref (%standard-object-storage object) location)) + (car (slot-definition-shared-binding slot)))) + +(defgeneric slot-value-using-class (class object slot)) ; mop +(defmethod slot-value-using-class ((class standard-base-class) object + (slot standard-effective-slot-definition)) + (let* ((value (refer-slot-using-class class object slot))) + (if (eq value +unbound-state+) + (values (slot-unbound class object (slot-definition-name slot))) + value))) +(defmethod slot-value-using-class ((class built-in-class) object slot) + (error "slot-value-using-class cannot be used for a built-in-class object.")) + + + +(defgeneric (setf slot-value-using-class) (new-value class object slot)) ; mop +(defmethod (setf slot-value-using-class) (new-value (class standard-base-class) object (slot standard-effective-slot-definition)) + (update-instance-if-obsolete object) + (if (local-slot-p slot) + (let ((location (slot-definition-location slot))) + (setf (aref (%standard-object-storage object) location) new-value)) + (setf (car (slot-definition-shared-binding slot)) new-value))) +(defmethod (setf slot-value-using-class) + (new-value (class built-in-class) object slot) + (error "(setf slot-value-using-class) cannot be used for ~ + a built-in-class object.")) + + + +(defgeneric slot-exists-p-using-class (class object slot-name)) ; mop? +(defmethod slot-exists-p-using-class ((class standard-base-class) + object slot-name) + (find-slot class slot-name)) +(defun slot-exists-p (object slot-name) ; clos + "Return true if OBJECT has a slot named SLOT-NAME." + (slot-exists-p-using-class (class-of object) object slot-name)) + + + + + +(defgeneric slot-boundp-using-class (class object slot)) ; mop +(defmethod slot-boundp-using-class ((class standard-base-class) object (slot standard-effective-slot-definition)) + (not (eq (refer-slot-using-class class object slot) +unbound-state+))) + +(defmethod slot-boundp-using-class ((class built-in-class) object slot) + (error "slot-boundp-using-class cannot be used for a built-in-class object.")) + + +(defun directly-accessible-slot-p (slot) + ;; http://www.lisp.org/mop/concepts.html#instance-structure-protocol + ;; > In particular, portable programs can control the implementation + ;; > of, and obtain direct access to, slots with allocation :instance and + ;; > type t. These are called directly accessible slots. + (and (eq (slot-definition-allocation slot) :instance) + (eq (slot-definition-type slot) 't))) + + +(defgeneric slot-makunbound-using-class (class object slot)) ; mop +(defmethod slot-makunbound-using-class ((class standard-base-class) object (slot standard-effective-slot-definition)) + (setf (slot-value-using-class class object slot) +unbound-state+)) +(defmethod slot-makunbound-using-class ((class built-in-class) object slot) + (error + "slot-makunbound-using-class cannot be used for a built-in-class object.")) +(defun slot-makunbound (instance slot-name) ; clos + "Restore a slot of the name SLOT-NAME in INSTANCE to the unbound state." + (let* ((class (class-of instance)) + (slot (find-slot class slot-name))) + (if slot + (slot-makunbound-using-class class instance slot) + (slot-missing class instance slot-name 'slot-makunbound)) + instance)) + +(defgeneric slot-missing (class object slot-name operation &optional new-value) + (:documentation ;; clos + "Invoked when a slot not defined in CLASS is accessed by SLOT-NAME.")) +(defmethod slot-missing ((class t) object slot-name operation &optional new-value) + (error "The slot ~S is missing in the class ~S." + slot-name + (etypecase class (symbol class) (class (class-name class))))) + +(defgeneric slot-unbound (class instance slot-name) + (:documentation ;; clos + "Called when an unbound slot named SLOT-NAME is read in INSTANCE of CLASS.")) +(defmethod slot-unbound ((class t) instance slot-name) + (error 'unbound-slot :instance instance :name slot-name)) + + + + + + +(defgeneric ensure-generic-function-using-class (generic-function function-name &key argument-precedence-order declarations documentation generic-function-class lambda-list method-class method-combination name &allow-other-keys)) ; mop +(defmethod ensure-generic-function-using-class ((generic-function generic-function) function-name &rest initargs &key generic-function-class &allow-other-keys) + (apply #'reinitialize-instance generic-function initargs)) +(defmethod ensure-generic-function-using-class ((generic-function null) function-name &rest initargs &key generic-function-class &allow-other-keys) + (apply #'make-instance generic-function-class initargs)) + +(defun ensure-generic-function (function-name &rest initargs + &key argument-precedence-order declare + documentation environment generic-function-class + lambda-list method-class method-combination) + "Define a globally named generic function with no methods." ; clos + (let ((fdefinition (fdefinition function-name))) + (when (and fdefinition (not (instancep fdefinition 'generic-function))) + (error "~S already names an ordinary function or a macro." function-name)) + (loop initially (setq initargs (copy-list initargs)) + while (remf initargs :declare)) + (apply #'ensure-generic-function-using-class fdefinition + `(:declarations ,declare ,@initargs)))) + + +(defun (setf generic-function-name) (new-name generic-function) + ) + + + +(defun clear-gf-cache (gf) + (clrhash (generic-function-applicable-methods gf)) + (clrhash (generic-function-effective-methods gf))) + + +(defgeneric method-qualifiers (method) ; clos + (:documentation "Return a list of the qualifiers of METHOD.")) + + + + +(defun check-specialized-lambda-list (specialized-lambda-list) + (let ((required-part (extract-required-part specialized-lambda-list))) + (assert (plusp (length required-part))) + (dolist (var-spec required-part) + (etypecase var-spec + (symbol (check-variable-name var-speck)) + (cons (let ((variable-name (first var-spec)) + (parameter-specializer-name (second var-spec))) + (check-variable-name variable-name) + (assert (or (symbolp parameter-specializer-name) + (eq (car parameter-specializer-name) 'eql))))))))) + +(defun extract-lambda-list (specialized-lambda-list) ; mop + (check-specialized-lambda-list specialized-lambda-list) + (loop for rest on specialized-lambda-list + for item = (car rest) + if (member item '(&optional &rest &key &aux)) + append rest and do (loop-finish) + else collect (if (consp item) (car item) item))) + +(defun extract-specializer-names (specialized-lambda-list) ; mop + (check-specialized-lambda-list specialized-lambda-list) + (loop for item in specialized-lambda-list + if (member item '(&optional &rest &key &aux)) do (loop-finish) + else collect (if (consp item) (second item) 't))) + +(defun extract-keyword-names (specialized-lambda-list) + (check-specialized-lambda-list specialized-lambda-list) + (let ((allow-other-keys-p nil)) + (values (loop for item in (rest (member '&key specialized-lambda-list)) + if (eq item '&allow-other-keys) + do (setq allow-other-keys-p t) (loop-finish) + else if (eq item '&aux) do (loop-finish) + else collect (if (consp item) + (if (consp (car item)) + (caar item) + (%keyword (car item))) + (%keyword item))) + allow-other-keys-p))) + +(defgeneric function-keywords (method) ; clos + (:documentation "Return the keyword parameter specifiers for METHOD.")) +(defmethod function-keywords ((method standard-method)) + (extract-keyword-names (method-specialized-lambda-list method))) + +(defgeneric no-applicable-method (generic-function &rest function-arguments) + (:documentation ;; clos + "Called when GENERIC-FUNCTION is invoked and no method is applicable.")) +(defmethod no-applicable-method ((generic-function t) &rest function-arguments) + ) + +(defgeneric no-next-method (generic-function method &rest args) ; clos + (:documentation "Called by call-next-method when there is no next method.")) +(defmethod no-next-method ((generic-function standard-generic-function) (method standard-method) &rest args) + ) + + + +(defgeneric find-method-combination ; mop + (generic-function method-combination-type-name method-combination-arguments)) +(defmethod find-method-combination + ((gf standard-generic-function) method-combination-type combination-options) + (multiple-value-bind (type presentp) + (gethash method-combination-type *method-combination-types*) + (if presentp + (make-instance 'standard-method-combination + :type type :arguments method-combination-arguments) + (error "Method combination ~S does not exist." method-combination-type)))) + +(defun make-method-form-p (object) + (and (consp object) (eq 'make-method (first object)))) + +(defun make-method-description (gf form) + `(:method 'make-method ,(generic-function-lambda-list gf) + (with-call-method ,gf ,form))) + +;; Local Macro CALL-METHOD, MAKE-METHOD +(defmacro with-call-method (gf &body body) + `(macrolet + ((call-method (method next-methods &environment env) + (flet ((method-form (form) + (apply #'<make-instance> + (generic-function-method-class ,gf) + (method-initargs-form + ',gf env :null-lexical-environment-p t + (method-spec (make-method-description ,gf form)))))) + (when (make-method-form-p method) + (setq method (method-form (second method)))) + (setq next-methods + (mapcar #'(lambda (method) + (if (make-method-form-p method) + (method-form (second method)) + `(quote ,method))) + next-methods))) + `(funcall (method-function ,method) + ,+gf-args-variable+ (list ,@next-methods)))) + ,@body)) + +(defgeneric compute-effective-method (generic-function + method-combination methods)) ; mop +(defmethod compute-effective-method ((generic-function standard-generic-function) + method-combination methods) + (let* ((type (method-combination-type method-combination)) + (type-function (method-combination-type-function type)) + (arguments (method-combination-arguments method-combination)) + (effective-method + (apply type-function generic-function methods arguments))) + (values `(with-call-method ,generic-function + ,effective-method) + `(:arguments ,(method-combination-type-args-lambda-list type) + :generic-function + ,(method-combination-type-generic-function-symbol type))))) + + +;; Local Function NEXT-METHOD-P +;; Local Function CALL-NEXT-METHOD +(defgeneric make-method-lambda + (generic-function method lambda-expression environment)) ; mop +(defmethod make-method-lambda ((generic-function standard-generic-function) + (method standard-method) + lambda-expression environment) + (let* ((lambda-list (second lambda-expression)) + (gf-args (first lambda-list)) + (next-methods (second lambda-list)) + (name (generic-function-name generic-function)) + (args (gensym))) + (multiple-value-bind (decls forms) + (declarations-and-forms (cddr lambda-expression)) + `(lambda ,lambda-list + ,@decls + (block ,(if (symbolp name) name (second name)) + (labels ((next-method-p () ,next-methods) + (call-next-method (&rest ,args) + (unless ,args (setq ,args ,gf-args)) + (if (next-method-p) + (funcall (method-function (car ,next-methods)) + ,args (cdr ,next-methods)) + (apply #'no-next-method ,generic-function ,method + ,(first lambda-list))))) + ,@forms)))))) + + +(defgeneric specializer-satisfied-p (specifier arg)) +(defmethod specializer-satisfied-p ((specializer class) arg) + (member (class-of arg) (class-precedence-list specializer))) +(defmethod specializer-satisfied-p ((specializer eql-specializer) arg) + (eql arg (eql-specializer-object specializer))) + +(defun applicable-method-p (method args) + (every #'specializer-satisfied-p (method-specializers method) args)) + +(defun eql-specializer-p (specializer) + (eq (class-of specializer) (find-class 'eql-specializer))) + +(defun more-specific-specializer-p (a b arg) + (cond + ((eql-specializer-p a) (not (eql-specializer-p b))) + ((eql-specializer-p b) nil) + (t (let ((list (class-precedence-list (class-of arg)))) + (< (position a list) (position b list)))))) + +(defun sort-methods (gf methods) + (let ((indeces (loop for arg in (generic-function-argument-precedence-order gf) + collect (position arg + (generic-function-lambda-list gf))))) + (flet ((more-specific-method-p (a b) + (loop for i in indeces + if (more-specific-specializer-p (elt (method-specializers a) i) + (elt (method-specializers b) i) + (elt args i)) + return t))) + (sort methods #'more-specific-method-p)))) + +(defgeneric compute-applicable-methods (generic-function function-arguments) ;clos + (:documentation "Return the set of applicable methods of GENERIC-FUNCTION. ")) +(defmethod compute-applicable-methods ((gf standard-generic-function) args) + (let ((methods (mapcan #'(lambda (method) + (when (applicable-method-p method args) + (list method))) + (generic-function-methods gf)))) + (sort-methods gf methods))) + +(defgeneric compute-applicable-methods-using-classes + (generic-function classes)) ; mop +(defmethod compute-applicable-methods-using-classes + ((generic-function standard-generic-function) classes) + (flet ((filter (method) + (let ((eql-specializer-p nil)) + (when (every #'(lambda (a b) + (if (and (eql-specializer-p a) + (eq (class-of (eql-specializer-object a)) + b)) + (setq eql-specializer-p t) + (subclassp b a))) + (method-specializers method) + classes) + (if eql-specializer-p + (return-from compute-applicable-methods-using-classes + (values nil nil)) + (list method)))))) + (values (sort-methods gf (mapcan #'filter (generic-function-methods gf))) + t))) + +(defun applicable-methods (gf args) + (let ((classes (mapcar #'class-of + (subseq args 0 (number-of-required-args gf))))) + (multiple-value-bind (methods presentp) + (gethash classes (generic-function-applicable-methods gf)) + (if presentp + methods + (multiple-value-bind (methods memorablep) + (compute-applicable-methods-using-classes gf classes) + (if memorablep + (setf (gethash classes (generic-function-applicable-methods gf)) + methods) + (compute-applicable-methods gf args))))))) + +(defgeneric compute-discriminating-function (generic-function)) ; mop +(defmethod compute-discriminating-function ((gf standard-generic-function)) + (let* ((combination (slot-value gf 'method-combination)) + (methods (gensym))) + (compile + nil + `(lambda (&rest ,+gf-args-variable+) + ;; check args here. + + (let ((,methods (applicable-methods ,gf ,+gf-args-variable+))) + (if (null ,methods) + (apply #'no-applicable-method ,gf ,+gf-args-variable+) + (multiple-value-bind (effective-method-function presentp) + (gethash methods (generic-function-effective-methods gf)) + (if presentp + (funcall effective-method-function ,+gf-args-variable+) + (progn + (setq effective-method-function + (compile + nil + (eval '(lambda (,+gf-args-variable+) + ,(compute-effective-method gf + combination + methods))))) + (setf (gethash methods + (generic-function-effective-methods gf)) + effective-method-function) + (funcall effective-method-function + ,+gf-args-variable+)))))))))) + +(defgeneric find-method + (generic-function qualifiers specializers &optional errorp) + (:documentation ;; clos + "Return the method object that agrees on QUALIFIERS and SPECIALIZERS.")) +(defmethod find-method + ((gf standard-generic-function) qualifiers specializers &optional errorp) + (when (/= (length specializers) (number-of-required-args gf)) + (error "The lambda list of ~S is ~S, and it doesn't match specializers ~S." + gf (generic-function-lambda-list gf) specializers)) + (flet ((agreep (a b) + (if (eql-specializer-p a) + (and (eql-specializer-p b) + (eql (eql-specializer-object a) (eql-specializer-object b))) + (eq a b)))) + (let ((method (find-if + #'(lambda (method) + (and (agreep (method-specializers method) specializers) + (equal (method-qualifiers method) qualifiers))) + (generic-function-methods generic-function)))) + (or method + (when errorp + (error "No method for ~S with qualifiers ~S and specializers ~S." + gf qualifiers specializers)))))) + +(defun check-lambda-list-congruence (gf method) + ) + +(defgeneric add-method (generic-function method) ; clos + (:documentation "Add METHOD to GENERIC-FUNCTION.")) +(defmethod add-method + ((generic-function standard-generic-function) (method method)) + (when (method-generic-function method) + (error "Method ~S is already associated with generic function ~S" + method (method-generic-function method))) + (check-lambda-list-congruence generic-function method) + + (let ((old-method (find-method generic-function + (method-qualifiers method) + (method-specializers method)))) + (when old-method + (remove-method generic-function old-method))) + (push method (slot-value generic-function 'methods)) + (mapc #'(lambda (specializer) (add-direct-method specializer method)) + (method-specializers method)) + (clear-gf-cache gf) + (map-dependents generic-function + #'(lambda (dependent) + (update-dependent generic-function dependent + 'add-method method))) + method) + +(defgeneric remove-method (generic-function method) ; clos + (:documentation "Remove METHOD from GENERIC-FUNCTION by modifying it")) +(defmethod remove-method ((generic-function standard-generic-function) method) + (let ((gf-methods (generic-function-methods generic-function))) + (when (member method gf-methods) + (setf (slot-value generic-function 'methods) (remove method gf-methods)) + (mapc #'(lambda (specializer) (remove-direct-method specializer method)) + (method-specializers method)))) + (clear-gf-cache gf) + (map-dependents generic-function + #'(lambda (dependent) + (update-dependent generic-function dependent + 'remove-method method))) + method) + + + +(defun class-of-sequence (sequence) + (typecase sequence + (list (typecase sequence + (null (find-class 'null)) + (cons (find-class 'cons)) + (t (find-class 'list)))) + (vector (typecase sequence + (bit-vector (find-class 'bit-vector)) + (string (find-class 'string)) + (t (find-class 'vector)))) + (t (find-class 'sequence)))) + +(defun class-of-number (number) + (typecase number + (integer (find-class 'integer)) + (ratio (find-class 'ratio)) + (rational (find-class 'rational)) + (float (find-class 'float)) + (real (find-class 'real)) + (complex (find-class 'complex)) + (t (find-class 'number)))) + +(defun class-of-stream (stream) + (typecase stream + (broadcast-stream (find-class 'broadcast-stream)) + (concatenated-stream (find-class 'concatenated-stream)) + (string-stream (find-class 'string-stream)) + (echo-stream (find-class 'echo-stream)) + (synonym-stream (find-class 'synonym-stream)) + (file-stream (find-class 'file-stream)) + (two-way-stream (find-class 'two-way-stream)) + (t (find-class 'stream)))) + +(defun class-of-condition (condition) + (typecase condition + (simple-error (find-class 'simple-error)) + (simple-type-error (find-class 'simple-type-error)) + (simple-warning (find-class 'simple-warning)) + (simple-condition (find-class 'simple-condition)) + + (floating-point-inexact (find-class 'floating-point-inexact)) + (floating-point-invalid-operation (find-class + 'floating-point-invalid-operation)) + (floating-point-overflow (find-class 'floating-point-overflow)) + (floating-point-underflow (find-class 'floating-point-underflow)) + (division-by-zero (find-class 'division-by-zero)) + (arithmetic-error (find-class 'arithmetic-error)) + + (reader-error (find-class 'reader-error)) + (parse-error (find-class 'parse-error)) + + (end-of-file (find-class 'end-of-file)) + (stream-error (find-class 'stream-error)) + + (unbound-slot (find-class 'unbound-slot)) + (unbound-variable (find-class 'unbound-variable)) + (undefined-function (find-class 'undefined-function)) + (cell-error (find-class 'cell-error)) + + (type-error (find-class 'type-error)) + (package-error (find-class 'package-error)) + (control-error (find-class 'control-error)) + (print-not-readable (find-class 'print-not-readable)) + (program-error (find-class 'program-error)) + (file-error (find-class 'file-error)) + (error (find-class 'error)) + + (storage-condition (find-class 'storage-condition)) + (serious-condition (find-class 'serious-condition)) + + (style-warning (find-class 'style-warning)) + (warning (find-class 'warning)) + + (t (find-class 'condition)))) + + +(progn + (setq *mop-working-p* t)) + + + +(defconstant +condition-report-slot-name+ + (gensym "CONDITION-REPORT-SLOT-NAME-")) + +(deftype lambda-expression () '(satisfies lambda-expression-p)) +(defun lambda-expression-p (object) + (and (consp object) (eq (first object) 'lambda) (listp (second object)))) + +(defun condition-initargs-form (options) + (check-singleton-options options '(:default-initargs :documentation :report + :direct-superclasses :direct-slots)) + (let ((report-option (assoc :report options))) + (when report-option + (destructuring-bind (report-name) (cdr report-option) + (assert (typep report-name (or string symbol lambda-expression))) + (let ((slot-spec `(,+condition-report-slot-name+ :allocation :class + :initform ',report-name))) + (push slot-spec (cdr (assoc :direct-slots options))))) + (setq options (remove :report options :key #'car)))) + (class-initargs-form options)) + +(defmacro define-condition (name parent-types slot-specs &rest options) + (let ((*message-prefix* (format nil "DEFINE-CONDITION ~S: " name)) + (options `((:direct-superclasses ,@(or parent-types '(condition))) + (:direct-slots ,@slot-specs) + ,@options))) + `(let ((*message-prefix* ,*message-prefix*)) + (apply #'ensure-class ',name ,(condition-initargs-form options))))) + +;; 9.1.1 Condition Types +;; http://www.lispworks.com/reference/HyperSpec/Body/09_aa.htm +;; > The metaclass of the class condition is not specified. +(define-condition condition (t) () + (:report (lambda (condition stream) + (format stream "Condition ~S is signaled." (class-of condition))))) + +(defun make-condition (type &rest slot-initializations) + ) + +|#
\ No newline at end of file diff --git a/Sacla/condition.lisp b/Sacla/condition.lisp new file mode 100644 index 0000000..d7ec782 --- /dev/null +++ b/Sacla/condition.lisp @@ -0,0 +1,437 @@ +;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp> +;; ALL RIGHTS RESERVED. +;; +;; $Id: condition.lisp,v 1.11 2004/08/19 06:26:06 yuji Exp $ +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; * Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; * Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + + +;; 9.1.1 Condition Types +;; http://www.lispworks.com/reference/HyperSpec/Body/09_aa.htm +;; CONDITION is defined in clos.lisp. +(define-condition warning () ()) +(define-condition style-warning (warning) ()) +(define-condition serious-condition () ()) +(define-condition storage-condition (serious-condition) ()) +(define-condition error (serious-condition) ()) +(define-condition type-error (error) + ((datum :initarg :datum :accessor type-error-datum) + (expected-type :initarg :expected-type :accessor type-error-expected-type)) + (:report (lambda (condition stream) + (format stream "~S is not of type ~S" + (type-error-datum condition) + (type-error-expected-type condition))))) +(define-condition package-error (error) + ((package :initarg :package :accessor package-error-package))) +(define-condition control-error (error) ()) +(define-condition print-not-readable (error) + ((object :initarg :object :accessor print-not-readable-object))) +(define-condition program-error (error) ()) +(define-condition file-error (error) + ((pathname :initarg :pathname :accessor file-error-pathname))) +(define-condition stream-error (error) + ((stream :initarg :stream :accessor stream-error-stream))) +(define-condition end-of-file (stream-error) ()) +(define-condition parse-error (error) ()) +(define-condition reader-error (parse-error stream-error) ()) +(define-condition cell-error (error) + ((name :initarg :name :accessor cell-error-name))) +(define-condition unbound-variable (cell-error) ()) +(define-condition undefined-function (cell-error) ()) +(define-condition unbound-slot (cell-error) + ((instance :initarg :incetance :accessor unbound-slot-instance))) +(define-condition arithmetic-error (error) + ((operation :initarg :operation :accessor arithmetic-error-operation) + (operands :initarg :operands :accessor arithmetic-error-operands))) +(define-condition division-by-zero (arithmetic-error) ()) +(define-condition floating-point-inexact (arithmetic-error) ()) +(define-condition floating-point-invalid-operation (arithmetic-error) ()) +(define-condition floating-point-overflow (arithmetic-error) ()) +(define-condition floating-point-underflow (arithmetic-error) ()) +(define-condition simple-condition (condition) + ((format-control :initarg :format-control + :accessor simple-condition-format-control) + (format-arguments :initarg :format-arguments + :accessor simple-condition-format-arguments)) + (:report (lambda (condition stream) + (apply #'format stream + (simple-condition-format-control condition) + (simple-condition-format-arguments condition))))) +(define-condition simple-warning (simple-condition warning) ()) +(define-condition simple-error (simple-condition error) ()) +(define-condition simple-type-error (simple-condition type-error) ()) +;; non standard +(define-condition simple-program-error (simple-condition program-error) ()) + + + +;; utilities +(defun existing-condition-name-p (object) + (and (symbolp object) (subtypep object 'condition))) +(deftype condition-designator () + '(or string condition (satisfies existing-condition-name-p))) +(defun condition (datum arguments + &optional (default-simple-condition 'simple-condition)) + (typecase datum + (condition (when arguments + (error 'type-error :datum arguments :expected-type 'null)) + datum) + (string (make-condition default-simple-condition + :format-control + (concatenate 'string *message-prefix* datum) + :format-arguments arguments)) + ((satisfies existing-condition-name-p) + (apply #'make-condition datum arguments)) + (t (error 'type-error :datum datum :expected-type 'condition-designator)))) + + + +;; 9.1.4 Handling Conditions +;; http://www.lispworks.com/reference/HyperSpec/Body/09_ad.htm +(defvar *handler-clusters* '()) +(defmacro handler-bind (bindings &body forms) + ;; binding::= (type handler) + ;; type --- a type specifier. + ;; handler --- a form; evaluated to produce a handler-function. + `(let ((*handler-clusters* + (cons (list ,@(mapcar #'(lambda (binding) + (destructuring-bind (type handler) binding + `(cons ',type ,handler))) + bindings)) + *handler-clusters*))) + ,@forms)) + +(defun handler-case-bindings-and-body (block-tag condition-variable + handler-case-clauses) + (loop for clause in handler-case-clauses + for (typespec (var) . rest) = clause + for clause-tag = (gensym) + collect `(,typespec #'(lambda (temp) + ,(if var + `(setq ,condition-variable temp) + '(declare (ignore temp))) + (go ,clause-tag))) + into bindings + append `(,clause-tag (return-from ,block-tag + (let ,(when var `((,var ,condition-variable))) + ,@rest))) + into body + finally (return (values bindings body)))) + +(defmacro handler-case (form &rest clauses) + (let ((no-error-clause (assoc ':no-error clauses))) + (if no-error-clause + (let ((normal-return (gensym "NORMAL-RETURN-")) + (error-return (gensym "ERROR-RETURN-"))) + `(block ,error-return + (multiple-value-call #'(lambda ,@(cdr no-error-clause)) + (block ,normal-return + (return-from ,error-return + (handler-case (return-from ,normal-return ,form) + ,@(remove no-error-clause clauses))))))) + (let ((block-tag (gensym)) + (condition (gensym))) + (multiple-value-bind (bindings body) + (handler-case-bindings-and-body block-tag condition clauses) + `(block ,block-tag + (let ((,condition nil)) + (declare (ignorable ,condition)) + (tagbody + (handler-bind ,bindings + (return-from ,block-tag ,form)) + ,@body)))))))) + +(defmacro ignore-errors (&body body) + `(handler-case (progn ,@body) + (error (condition) (values nil condition)))) + + + +;; 9.1.4.2 Restarts +;; http://www.lispworks.com/reference/HyperSpec/Body/09_adb.htm +(defstruct (restart (:print-object print-restart)) + (name nil :type symbol) + (function (required-argument) :type function) + report-function + interactive-function + (test-function #'(lambda (condition) (declare (ignore condition)) t))) +(defun print-restart (restart stream) + (format stream "#<~A restart (sacla)>" (restart-name restart))) + +(defvar *restart-clusters* 'nil) +(defmacro restart-bind (restart-specs &body forms) + "Execute FORMS in a dynamic environment where specified restarts are ~ + in effect." + ;; restart-spec::= (name function {key-val-pair}*) + ;; key-val-pair::= :interactive-function interactive-function | + ;; :report-function report-function | + ;; :test-function test-function + (flet ((make-restart-form (spec) + (destructuring-bind (name function . initargs) spec + `(make-restart :name ',name :function ,function ,@initargs)))) + `(let ((*restart-clusters* (cons (list ,@(mapcar #'make-restart-form + restart-specs)) + *restart-clusters*))) + ,@forms))) + +(defvar *condition-restarts* 'nil) +(defmacro with-condition-restarts (condition-form restarts-form &body forms) + "Execute FORMS in an environment where restarts are associated with ~ + a condition." + `(let ((*condition-restarts* (acons ,condition-form ,restarts-form + *condition-restarts*))) + ,@forms)) + +(defmacro with-restarts (restarts-form form &environment env) + "Associate a condition to be signaled by FORM with restarts of RESTARTS-FORM." + (flet ((signaling-form-p (form) + (and (consp form) (member (car form) '(cerror error signal warn))))) + (let ((form (macroexpand form env))) + (if (not (signaling-form-p form)) + form + (let* ((condition (gensym)) + (signaler (car form)) + (datum (if (eq signaler 'cerror) (third form) (second form))) + (args (if (eq signaler 'cerror) (cdddr form) (cddr form))) + (default-condition (ecase signaler + ((cerror error) 'simple-error) + (warning 'simple-warning) + (signal 'simple-condition)))) + `(let ((,condition (condition ,datum ',args ',default-condition))) + (with-condition-restarts ,condition + ,restarts-form + ,(if (eq signaler 'cerror) + `(cerror ,(second form) ,condition) + `(,signaler ,condition))))))))) + +(defun restart-case-bindings-and-body (block-tag args-var restart-case-clauses) + ;; restart-case-clause::= (case-name lambda-list + ;; [[:interactive interactive-expression | :report report-expression | + ;; :test test-expression]] declaration* form*) + (loop for clause in restart-case-clauses + for (case-name lambda-list . tail) = clause + for clause-tag = (gensym) + for initargs = + (loop for plist on tail by #'cddr + for (key value) = plist + and names = '(:interactive :report :test) then (remove key names) + if (member key names) + if (eq key :interactive) + append `(:interactive-function #',value) + else if (eq key :report) + append `(:report-function + #',(if (not (stringp value)) + value + `(lambda (stream) + (write-string ,value stream)))) + else if (eq key :test) append `(:test-function #',value) + else do (loop-finish) + finally (setq tail plist)) + collect `(,case-name + #'(lambda (&rest rest) (setq ,args-var rest) (go ,clause-tag)) + ,@initargs) into bindings + append `(,clause-tag + (return-from ,block-tag + (apply #'(lambda ,lambda-list ,@tail) ,args-var))) into body + finally (return (values bindings body)))) + +(defmacro restart-case (restartable-form &body clauses) + "Eval RESTARTABLE-FORM in an environment with restarts specified by CLAUSES." + (let ((block-tag (gensym)) + (args (gensym))) + (multiple-value-bind (bindings body) + (restart-case-bindings-and-body block-tag args clauses) + `(block ,block-tag + (let ((,args nil)) + (declare (ignorable ,args)) + (tagbody + (restart-bind ,bindings + (return-from ,block-tag + (with-restarts (first *restart-clusters*) ,restartable-form))) + ,@body)))))) + +(defmacro with-simple-restart ((restart-name format-string &rest format-arguments) + &body forms) + `(restart-case (progn ,@forms) + (,restart-name () + :report (lambda (stream) (format stream ,format-string ,@format-arguments)) + (values nil t)))) + +(defun compute-restarts (&optional condition) + "Compute a list of the restarts which are currently active." + (let ((visibles nil) + (ignorables nil)) + (dolist (assoc *condition-restarts*) + (if (eq (car assoc) condition) + (setq visibles (append (cdr assoc) visibles)) + (setq ignorables (append (cdr assoc) ignorables)))) + (flet ((visible-p (restart) + (and (or (null condition) + (member restart visibles) + (not (member restart ignorables))) + (funcall (restart-test-function restart) condition)))) + (loop for restart in (mapcan #'copy-list *restart-clusters*) + if (visible-p restart) collect restart)))) + +(defun find-restart (id &optional condition) + "Search for a particular restart in the current dynamic environment." + (if (restart-p id) + (if (funcall (restart-test-function id) condition) + id + nil) + (find id (compute-restarts condition) :key #'restart-name))) + +(defun restart (designator) + (or (find-restart designator) + (error "Restart ~S is not active." designator))) + +(defun invoke-restart (restart-designator &rest values) + (let ((restart (restart restart-designator))) + (apply (restart-function restart) values))) + +(defun invoke-restart-interactively (restart-designator) + (let* ((restart (restart restart-designator)) + (interactive-function (restart-interactive-function restart))) + (apply (restart-function restart) (if interactive-function + (funcall interactive-function) + '())))) + +(defun abort (&optional condition) + (let ((restart (find-restart 'abort condition))) + (when restart + (invoke-restart 'abort)) + (error 'control-error))) + +(defun muffle-warning (&optional condition) + (let ((restart (find-restart 'muffle-warning condition))) + (when restart + (invoke-restart 'muffle-warning)) + (error 'control-error))) + +(defun continue (&optional condition) + (let ((restart (find-restart 'continue condition))) + (when restart + (invoke-restart restart)))) + +(defun store-value (value &optional condition) + (let ((restart (find-restart 'store-value condition))) + (when restart + (invoke-restart 'store-value value)))) + +(defun use-value (value &optional condition) + (let ((restart (find-restart 'use-value condition))) + (when restart + (invoke-restart 'use-value value)))) + + + +(defvar *break-on-signals* 'nil) +(defun break (&optional (format-control "Break") &rest format-arguments) + (with-simple-restart (continue "Return from BREAK.") + (let ((*debugger-hook* nil)) + (invoke-debugger (make-condition 'simple-condition + :format-control format-control + :format-arguments format-arguments)))) + nil) +(defun signal (datum &rest arguments) + (let ((condition (condition datum arguments)) + (*handler-clusters* *handler-clusters*)) + (when (typep condition *break-on-signals*) + (break "~A~%Break entered because of *BREAK-ON-SIGNALS*." condition)) + (loop while *handler-clusters* + do (dolist (handler (pop *handler-clusters*)) + (when (typep condition (car handler)) + (funcall (cdr handler) condition)))) + nil)) + +(defun error (datum &rest arguments) + (let ((condition (condition datum arguments 'simple-error))) + (signal condition) + (invoke-debugger condition))) + +(defun cerror (continue-format-control datum &rest arguments) + (restart-case (error (condition datum arguments 'simple-error)) + (continue () + :report (lambda (stream) + (apply #'format stream continue-format-control arguments)))) + nil) + +(defmacro check-type (place typespec &optional string) + (declare (ignorable string)) + `(loop + until (typep ,place ',typespec) + do (restart-case (error 'type-error :datum ,place :expected-type ',typespec) + (store-value (value) + :report (lambda (stream) (store-value-report stream ',place)) + :interactive store-value-interactive + (setf ,place value))))) + +(defun warn (datum &rest arguments) + (let ((condition (condition datum arguments 'simple-warning))) + (check-type condition warning) + (restart-case (signal condition) + (muffle-warning () + :report "Skip warning." + (return-from warn nil))) + (format *error-output* "~&Warning:~%~A~%" condition) + nil)) + + + +(defun assert-report (names stream) + (format stream "Retry assertion") + (if names + (format stream " with new value~P for ~{~S~^, ~}." (length names) names) + (format stream "."))) +(defun assert-prompt (name value) + (cond ((y-or-n-p "The old value of ~S is ~S.~%~ + Do you want to supply a new value? " + name value) + (format *query-io* "~&Type a form to be evaluated:~%") + (flet ((read-it () (eval (read *query-io*)))) + (if (symbolp name) ;help user debug lexical variables + (progv (list name) (list value) (read-it)) + (read-it)))) + (t value))) +(defmacro assert (test-form &optional places datum-form &rest argument-forms) + `(loop + (when ,test-form (return nil)) + (restart-case (error ,@(if datum-form + `(,datum-form ,@argument-forms) + `("The assertion ~S failed." ',test-form))) + (continue () + :report (lambda (stream) (assert-report ',places stream)) + ,@(mapcar #'(lambda (place) + `(setf ,place (assert-prompt ',place ,place))) + places))))) + +;;Function INVOKE-DEBUGGER +;;Variable *DEBUGGER-HOOK* +;; +;;Defined in clos.lisp +;; Macro DEFINE-CONDITION +;; Function MAKE-CONDITION +;; Function INVALID-METHOD-ERROR +;; Function METHOD-COMBINATION-ERROR diff --git a/Sacla/cons.lisp b/Sacla/cons.lisp new file mode 100644 index 0000000..6276a7f --- /dev/null +++ b/Sacla/cons.lisp @@ -0,0 +1,993 @@ +;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp> +;; ALL RIGHTS RESERVED. +;; +;; $Id: cons.lisp,v 1.4 2004/02/20 07:23:42 yuji Exp $ +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; * Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; * Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(defun atom (object) + "Return true if OBJECT is of type atom; otherwise, return false." + (not (consp object))) + +(defun caar (list) + "Return the car of the car of LIST." + (car (car list))) + +(defun cadr (list) + "Return the car of the cdr of LIST." + (car (cdr list))) + +(defun cdar (list) + "Return the cdr of the car of LIST." + (cdr (car list))) + +(defun cddr (list) + "Return the cdr of the cdr of LIST." + (cdr (cdr list))) + +(defun caaar (list) + "Return the car of the caar of LIST." + (car (caar list))) + +(defun caadr (list) + "Return the car of the cadr of LIST." + (car (cadr list))) + +(defun cadar (list) + "Return the car of the cdar of LIST." + (car (cdar list))) + +(defun caddr (list) + "Return the car of the cddr of LIST." + (car (cddr list))) + +(defun cdaar (list) + "Return the cdr of the caar of LIST." + (cdr (caar list))) + +(defun cdadr (list) + "Return the cdr of the cadr of LIST." + (cdr (cadr list))) + +(defun cddar (list) + "Return the cdr of the cdar of LIST." + (cdr (cdar list))) + +(defun cdddr (list) + "Return the cdr of the cddr of LIST." + (cdr (cddr list))) + +(defun caaaar (list) + "Return the car of the caaar of LIST." + (car (caaar list))) + +(defun caaadr (list) + "Return the car of the caadr of LIST." + (car (caadr list))) + +(defun caadar (list) + "Return the car of the cadar of LIST." + (car (cadar list))) + +(defun caaddr (list) + "Return the car of the caddr of LIST." + (car (caddr list))) + +(defun cadaar (list) + "Return the car of the cdaar of LIST." + (car (cdaar list))) + +(defun cadadr (list) + "Return the car of the cdadr of LIST." + (car (cdadr list))) + +(defun caddar (list) + "Return the car of the cddar of LIST." + (car (cddar list))) + +(defun cadddr (list) + "Return the car of the cdddr of LIST." + (car (cdddr list))) + +(defun cdaaar (list) + "Return the cdr of the caaar of LIST." + (cdr (caaar list))) + +(defun cdaadr (list) + "Return the cdr of the caadr of LIST." + (cdr (caadr list))) + +(defun cdadar (list) + "Return the cdr of the cadar of LIST." + (cdr (cadar list))) + +(defun cdaddr (list) + "Return the cdr of the caddr of LIST." + (cdr (caddr list))) + +(defun cddaar (list) + "Return the cdr of the cdaar of LIST." + (cdr (cdaar list))) + +(defun cddadr (list) + "Return the cdr of the cdadr of LIST." + (cdr (cdadr list))) + +(defun cdddar (list) + "Return the cdr of the cddar of LIST." + (cdr (cddar list))) + +(defun cddddr (list) + "Return the cdr of the cdddr of LIST." + (cdr (cdddr list))) + + +(defsetf caar (x) (v) + `(progn + (rplaca (car ,x) ,v) + ,v)) + +(defsetf cadr (x) (v) + `(progn + (rplaca (cdr ,x) ,v) + ,v)) + +(defsetf cdar (x) (v) + `(progn + (rplacd (car ,x) ,v) + ,v)) + +(defsetf cddr (x) (v) + `(progn + (rplacd (cdr ,x) ,v) + ,v)) + +(defsetf caaar (x) (v) + `(progn + (rplaca (caar ,x) ,v) + ,v)) + +(defsetf caadr (x) (v) + `(progn + (rplaca (cadr ,x) ,v) + ,v)) + +(defsetf cadar (x) (v) + `(progn + (rplaca (cdar ,x) ,v) + ,v)) + +(defsetf caddr (x) (v) + `(progn + (rplaca (cddr ,x) ,v) + ,v)) + +(defsetf cdaar (x) (v) + `(progn + (rplacd (caar ,x) ,v) + ,v)) + +(defsetf cdadr (x) (v) + `(progn + (rplacd (cadr ,x) ,v) + ,v)) + +(defsetf cddar (x) (v) + `(progn + (rplacd (cdar ,x) ,v) + ,v)) + +(defsetf cdddr (x) (v) + `(progn + (rplacd (cddr ,x) ,v) + ,v)) + +(defsetf caaaar (x) (v) + `(progn + (rplaca (caaar ,x) ,v) + ,v)) + +(defsetf caaadr (x) (v) + `(progn + (rplaca (caadr ,x) ,v) + ,v)) + +(defsetf caadar (x) (v) + `(progn + (rplaca (cadar ,x) ,v) + ,v)) + +(defsetf caaddr (x) (v) + `(progn + (rplaca (caddr ,x) ,v) + ,v)) + +(defsetf cadaar (x) (v) + `(progn + (rplaca (cdaar ,x) ,v) + ,v)) + +(defsetf cadadr (x) (v) + `(progn + (rplaca (cdadr ,x) ,v) + ,v)) + +(defsetf caddar (x) (v) + `(progn + (rplaca (cddar ,x) ,v) + ,v)) + +(defsetf cadddr (x) (v) + `(progn + (rplaca (cdddr ,x) ,v) + ,v)) + +(defsetf cdaaar (x) (v) + `(progn + (rplacd (caaar ,x) ,v) + ,v)) + +(defsetf cdaadr (x) (v) + `(progn + (rplacd (caadr ,x) ,v) + ,v)) + +(defsetf cdadar (x) (v) + `(progn + (rplacd (cadar ,x) ,v) + ,v)) + +(defsetf cdaddr (x) (v) + `(progn + (rplacd (caddr ,x) ,v) + ,v)) + +(defsetf cddaar (x) (v) + `(progn + (rplacd (cdaar ,x) ,v) + ,v)) + +(defsetf cddadr (x) (v) + `(progn + (rplacd (cdadr ,x) ,v) + ,v)) + +(defsetf cdddar (x) (v) + `(progn + (rplacd (cddar ,x) ,v) + ,v)) + +(defsetf cddddr (x) (v) + `(progn + (rplacd (cdddr ,x) ,v) + ,v)) + +(defun null (object) + "Return t if OBJECT is the empty list; otherwise, return nil." + (eq object nil)) + +(defun endp (list) + "Return true if LIST is the empty list. Returns false if LIST is a cons." + (check-type list list) + (null list)) + +(defun listp (object) + "Return true if OBJECT is of type list; otherwise, return false." + (or (null object) (consp object))) + + +(defun first (list) + "Return the 1st element in LIST or NIL if LIST is empty." + (car list)) +(defun second (list) + "Return the 2nd element in LIST or NIL if there is no 2nd element." + (cadr list)) +(defun third (list) + "Returns the 3rd element in LIST or NIL if there is no 3rd element." + (caddr list)) +(defun fourth (list) + "Return the 4th element in LIST or NIL if there is no 4th element." + (cadddr list)) +(defun fifth (list) + "Return the 5th element in LIST or NIL if there is no 5th element." + (car (cddddr list))) +(defun sixth (list) + "Return the 6th element in LIST or NIL if there is no 6th element." + (cadr (cddddr list))) +(defun seventh (list) + "Return the 7th element in LIST or NIL if there is no 7th element." + (caddr (cddddr list))) +(defun eighth (list) + "Return the 8th element in LIST or NIL if there is no 8th element." + (cadddr (cddddr list))) +(defun ninth (list) + "Return the 9th element in LIST or NIL if there is no 9th element." + (car (cddddr (cddddr list)))) +(defun tenth (list) + "Return the 10th element in LIST or NIL if there is no 10th element." + (cadr (cddddr (cddddr list)))) + +(defun rest (list) + "Perform the same operation as cdr." + (cdr list)) + + +(defsetf first (x) (v) + `(setf (car ,x) ,v)) + +(defsetf second (x) (v) + `(setf (cadr ,x) ,v)) + +(defsetf third (x) (v) + `(setf (caddr ,x) ,v)) + +(defsetf fourth (x) (v) + `(setf (cadddr ,x) ,v)) + +(defsetf fifth (x) (v) + `(setf (car (cddddr ,x)) ,v)) + +(defsetf sixth (x) (v) + `(setf (cadr (cddddr ,x)) ,v)) + +(defsetf seventh (x) (v) + `(setf (caddr (cddddr ,x)) ,v)) + +(defsetf eighth (x) (v) + `(setf (cadddr (cddddr ,x)) ,v)) + +(defsetf ninth (x) (v) + `(setf (car (cddddr (cddddr ,x))) ,v)) + +(defsetf tenth (x) (v) + `(setf (cadr (cddddr (cddddr ,x))) ,v)) + +(defsetf rest (x) (v) + `(setf (cdr ,x) ,v)) + + +(defun nthcdr (n list) + "Return the tail of LIST that would be obtained by calling cdr N times." + (check-type n (integer 0)) + (do ((i n (1- i)) + (result list (cdr result))) + ((zerop i) result))) + +(defun nth (n list) + "Return the Nth element in LIST, where the car is the zero-th element." + (car (nthcdr n list))) + +(defsetf nth (n list) (v) + `(setf (car (nthcdr ,n ,list)) ,v)) + + +(defun copy-list (list) + "Return a copy of LIST which is either a proper list or a dotted list." + (unless (null list) + (let ((result (cons (car list) nil))) + (do ((x (cdr list) (cdr x)) + (splice result (cdr (rplacd splice (cons (car x) nil))))) + ((atom x) (rplacd splice x))) + result))) + +(defun list (&rest args) + "Return ARGS which is a list of supplied arguments." + (copy-list args)) + +(defun list* (arg &rest others) + "Return a list of the arguments with the last cons being a dotted pair." + (cond ((null others) arg) + ((null (cdr others)) (cons arg (car others))) + (t (let ((others (copy-list others))) + (do ((x others (cdr x))) + ((null (cddr x)) (rplacd x (cadr x)))) + (cons arg others))))) + +(defun list-length (list) + "Return the length of the given LIST, or nil if the LIST is circular." + (do ((n 0 (+ n 2)) ;Counter. + (fast list (cddr fast)) ;Fast pointer: leaps by 2. + (slow list (cdr slow))) ;Slow pointer: leaps by 1. + (nil) + ;; If fast pointer hits the end, return the count. + (when (endp fast) (return n)) + (when (endp (cdr fast)) (return (+ n 1))) + ;; If fast pointer eventually equals slow pointer, + ;; then we must be stuck in a circular list. + ;; (A deeper property is the converse: if we are + ;; stuck in a circular list, then eventually the + ;; fast pointer will equal the slow pointer. + ;; That fact justifies this implementation.) + (when (and (eq fast slow) (> n 0)) (return nil)))) + +(defun make-list (size &key initial-element) + "Return a list of SIZE length, every element of which is INITIAL-ELEMENT." + (check-type size (integer 0)) + (do ((i size (1- i)) + (list '() (cons initial-element list))) + ((zerop i) list))) + +(defun last (list &optional (n 1)) + "Returns the last N conses (not the last N elements) of LIST." + (check-type n (integer 0)) + (do ((l list (cdr l)) + (r list) + (i 0 (1+ i))) + ((atom l) r) + (if (>= i n) (pop r)))) + +(defun butlast (list &optional (n 1)) + "Return a copy of LIST from which the last N conses have been omitted." + (check-type n (integer 0)) + (if (null list) + nil + (let ((length (do ((p (cdr list) (cdr p)) + (i 1 (1+ i))) + ((atom p) i)))) + (do* ((here list (cdr here)) + (result (list nil)) + (splice result) + (count (- length n) (1- count))) + ((<= count 0) (cdr result)) + (setq splice (cdr (rplacd splice (list (car here))))))))) + +(defun nbutlast (list &optional (n 1)) + "Modify LIST to remove the last N conses." + (check-type n (integer 0)) + (if (null list) + nil + (let ((length (do ((p (cdr list) (cdr p)) + (i 1 (1+ i))) + ((atom p) i)))) + (unless (<= length n) + (do ((1st (cdr list) (cdr 1st)) + (2nd list 1st) + (count (- length n 1) (1- count))) + ((zerop count) (rplacd 2nd ()) list)))))) + +(defun nconc (&rest lists) + "Concatenate LISTS by changing them." + (setq lists (do ((p lists (cdr p))) + ((or (car p) (null p)) p))) + (do* ((top (car lists)) + (splice top) + (here (cdr lists) (cdr here))) + ((null here) top) + (rplacd (last splice) (car here)) + (when (car here) + (setq splice (car here))))) + +(defun append (&rest lists) + "Concatenate LISTS by copying them." + (setq lists (do ((p lists (cdr p))) + ((or (car p) (null p)) p))) + (cond + ((null lists) '()) + ((null (cdr lists)) (car lists)) + (t (let* ((top (list (caar lists))) + (splice top)) + (do ((x (cdar lists) (cdr x))) + ((atom x)) + (setq splice (cdr (rplacd splice (list (car x)))))) + (do ((p (cdr lists) (cdr p))) + ((null (cdr p)) (rplacd splice (car p)) top) + (do ((x (car p) (cdr x))) + ((atom x)) + (setq splice (cdr (rplacd splice (list (car x))))))))))) + +(defun revappend (list tail) + "Return (nconc (reverse list) tail)." + (do ((top list (cdr top)) + (result tail (cons (car top) result))) + ((endp top) result))) + +(defun nreconc (list tail) + "Return (nconc (nreverse list) tail)." + (do ((1st (cdr list) (if (atom 1st) 1st (cdr 1st))) + (2nd list 1st) + (3rd tail 2nd)) + ((atom 2nd) 3rd) + (rplacd 2nd 3rd))) + +(defun tailp (object list) + "Return true if OBJECT is the same as some tail of LIST, otherwise false." + (if (null list) + (null object) + (do ((list list (cdr list))) + ((atom (cdr list)) (or (eql object list) (eql object (cdr list)))) + (if (eql object list) + (return t))))) + +(defun ldiff (list object) + "Return a copy of LIST before the part which is the same as OBJECT." + (unless (eql list object) + (do* ((result (list (car list))) + (splice result) + (list (cdr list) (cdr list))) + ((atom list) (when (eql list object) (rplacd splice nil)) result) + (if (eql list object) + (return result) + (setq splice (cdr (rplacd splice (list (car list))))))))) + +(defun acons (key datum alist) + "Construct a new alist by adding the pair (key . datum) to alist." + (cons (cons key datum) alist)) + +(defun assoc (item alist &key key (test #'eql) test-not) + "Return the cons in ALIST whose car is equal (by TEST) to ITEM." + (when test-not + (setq test (complement test-not))) + (dolist (pair alist nil) + (when (and pair (funcall test item (apply-key key (car pair))) + (return pair))))) + +(defun assoc-if (predicate alist &key key) + "Return the cons in ALIST whose car satisfies PREDICATE." + (dolist (pair alist nil) + (when (and pair (funcall predicate (apply-key key (car pair)))) + (return pair)))) + +(defun assoc-if-not (predicate alist &key key) + "Return the cons in ALIST whose car does not satisfy PREDICATE." + (assoc-if (complement predicate) alist :key key)) + +(defun rassoc (item alist &key key (test #'eql) test-not) + "Return the cons in ALIST whose cdr is equal (by TEST) to ITEM." + (when test-not + (setq test (complement test-not))) + (dolist (pair alist nil) + (when (and pair (funcall test item (apply-key key (cdr pair)))) + (return pair)))) + +(defun rassoc-if (predicate alist &key key) + "Return the cons in ALIST whose cdr satisfies PREDICATE." + (dolist (pair alist nil) + (when (and pair (funcall predicate (apply-key key (cdr pair)))) + (return pair)))) + +(defun rassoc-if-not (predicate alist &key key) + "Return the cons in ALIST whose cdr does not satisfy PREDICATE." + (rassoc-if (complement predicate) alist :key key)) + +(defun copy-alist (alist) + "Return a copy of ALIST." + (if (null alist) + nil + (let* ((new-alist (list (cons (caar alist) (cdar alist)))) + (tail new-alist)) + (dolist (pair (cdr alist)) + (rplacd tail (list (cons (car pair) (cdr pair)))) + (setq tail (cdr tail))) + new-alist))) + +(defun pairlis (keys data &optional (alist '())) + "Construct an association list from keys and data (adding to alist)" + (do ((x keys (cdr x)) + (y data (cdr y))) + ((endp x) alist) + (setq alist (acons (car x) (car y) alist)))) + + +(defun sublis (alist tree &key key (test #'eql) test-not) + "Substitute data of ALIST for subtrees matching keys of ALIST." + (when test-not + (setq test (complement test-not))) + (labels ((sub (subtree) + (let ((assoc (assoc (apply-key key subtree) alist :test test))) + (cond + (assoc (cdr assoc)) + ((atom subtree) subtree) + (t (let ((car (sub (car subtree))) + (cdr (sub (cdr subtree)))) + (if (and (eq car (car subtree)) (eq cdr (cdr subtree))) + subtree + (cons car cdr)))))))) + (sub tree))) + +(defun nsublis (alist tree &key key (test #'eql) test-not) + "Substitute data of ALIST for subtrees matching keys of ALIST destructively." + (when test-not + (setq test (complement test-not))) + (labels ((sub (subtree) + (let ((assoc (assoc (apply-key key subtree) alist :test test))) + (cond + (assoc (cdr assoc)) + ((atom subtree) subtree) + (t + (rplaca subtree (sub (car subtree))) + (rplacd subtree (sub (cdr subtree))) + subtree))))) + (sub tree))) + +(defun copy-tree (tree) + "Create a copy of TREE (a structure of conses)." + (if (consp tree) + (cons (copy-tree (car tree)) (copy-tree (cdr tree))) + tree)) + +(defun subst (new old tree &key key (test #'eql) test-not) + "Substitute NEW for subtrees matching OLD." + (when test-not + (setq test (complement test-not))) + (labels ((sub (subtree) + (cond + ((funcall test old (apply-key key subtree)) new) + ((atom subtree) subtree) + (t (let ((car (sub (car subtree))) + (cdr (sub (cdr subtree)))) + (if (and (eq car (car subtree)) (eq cdr (cdr subtree))) + subtree + (cons car cdr))))))) + (sub tree))) + +(defun nsubst (new old tree &key key (test #'eql) test-not) + "Substitute NEW for subtrees matching OLD destructively." + (when test-not + (setq test (complement test-not))) + (labels ((sub (subtree) + (cond + ((funcall test old (apply-key key subtree)) new) + ((atom subtree) subtree) + (t (rplaca subtree (sub (car subtree))) + (rplacd subtree (sub (cdr subtree))) + subtree)))) + (sub tree))) + +(defun subst-if (new predicate tree &key key) + "Substitute NEW for subtrees for which PREDICATE is true." + (labels ((sub (subtree) + (cond + ((funcall predicate (apply-key key subtree)) new) + ((atom subtree) subtree) + (t (let ((car (sub (car subtree))) + (cdr (sub (cdr subtree)))) + (if (and (eq car (car subtree)) (eq cdr (cdr subtree))) + subtree + (cons car cdr))))))) + (sub tree))) + +(defun subst-if-not (new predicate tree &key key) + "Substitute NEW for subtrees for which PREDICATE is false." + (subst-if new (complement predicate) tree :key key)) + +(defun nsubst-if (new predicate tree &key key) + "Substitute NEW for subtrees for which PREDICATE is true destructively." + (labels ((sub (subtree) + (cond + ((funcall predicate (apply-key key subtree)) new) + ((atom subtree) subtree) + (t (rplaca subtree (sub (car subtree))) + (rplacd subtree (sub (cdr subtree))) + subtree)))) + (sub tree))) + +(defun nsubst-if-not (new predicate tree &key key) + "Substitute NEW for subtrees for which PREDICATE is false destructively." + (nsubst-if new (complement predicate) tree :key key)) + +(defun tree-equal (a b &key (test #'eql) test-not) + "Test whether two trees are of the same shape and have the same leaves." + (when test-not + (setq test (complement test-not))) + (labels ((teq (a b) + (if (atom a) + (and (atom b) (funcall test a b)) + (and (consp b) + (teq (car a) (car b)) + (teq (cdr a) (cdr b)))))) + (teq a b))) + + + +(defmacro push (item place &environment env) + "Prepend item to the list in PLACE, store the list in PLACE, and returns it." + (if (symbolp place) + `(setq ,place (cons ,item ,place)) + (multiple-value-bind (temporary-vars values stores setter getter) + (get-setf-expansion place env) + (let ((item-var (gensym))) + `(let* ((,item-var ,item) + ,@(mapcar #'list temporary-vars values) + (,(car stores) (cons ,item-var ,getter))) + ,setter))))) + +(defmacro pop (place &environment env) + "Return the car of the list in PLACE, storing the cdr of it back into PLACE." + (if (symbolp place) + `(prog1 (car ,place) (setq ,place (cdr ,place))) + (multiple-value-bind (temporary-vars values stores setter getter) + (get-setf-expansion place env) + (let ((list-var (gensym))) + `(let* (,@(mapcar #'list temporary-vars values) + (,list-var ,getter) + (,(car stores) (cdr ,list-var))) + ,setter + (car ,list-var)))))) + + + +(defun member (item list &key key (test #'eql) test-not) + "Return the tail of LIST beginning with an element equal to ITEM." + (when test-not + (setq test (complement test-not))) + (do ((here list (cdr here))) + ((or (null here) (funcall test item (apply-key key (car here)))) here))) + +(defun member-if (predicate list &key key) + "Return the tail of LIST beginning with an element satisfying PREDICATE." + (do ((here list (cdr here))) + ((or (endp here) (funcall predicate (apply-key key (car here)))) here))) + +(defun member-if-not (predicate list &key key) + "Return the tail of LIST beginning with an element not satisfying PREDICATE." + (member-if (complement predicate) list :key key)) + +(defun adjoin (item list &key key (test #'eql) test-not) + "Add ITEM to LIST unless it is already a member." + (when test-not + (setq test (complement test-not))) + (if (member (apply-key key item) list :key key :test test) + list + (cons item list))) + +(defun intersection (list-1 list-2 &key key (test #'eql) test-not) + "Return the intersection of LIST-1 and LIST-2." + (when test-not + (setq test (complement test-not))) + (let (result) + (dolist (element list-1) + (when (member (apply-key key element) list-2 :key key :test test) + (push element result))) + result)) + +(defun nintersection (list-1 list-2 &key key (test #'eql) test-not) + "Return the intersection of LIST-1 and LIST-2 destructively modifying LIST-1." + (when test-not + (setq test (complement test-not))) + (let* ((result (list nil)) + (splice result)) + (do ((list list-1 (cdr list))) + ((endp list) (rplacd splice nil) (cdr result)) + (when (member (apply-key key (car list)) list-2 :key key :test test) + (setq splice (cdr (rplacd splice list))))))) + +(defun union (list-1 list-2 &key key (test #'eql) test-not) + "Return the union of LIST-1 and LIST-2." + (when test-not + (setq test (complement test-not))) + (let ((result list-2)) + (dolist (element list-1) + (unless (member (apply-key key element) list-2 :key key :test test) + (push element result))) + result)) + +(defun nunion (list-1 list-2 &key key (test #'eql) test-not) + "Return the union of LIST-1 and LIST-2 destructively modifying them." + (when test-not + (setq test (complement test-not))) + (do* ((result list-2) + (list-1 list-1) + tmp) + ((endp list-1) result) + (if (member (apply-key key (car list-1)) list-2 :key key :test test) + (setq list-1 (cdr list-1)) + (setq tmp (cdr list-1) + result (rplacd list-1 result) + list-1 tmp)))) + +(defun subsetp (list-1 list-2 &key key (test #'eql) test-not) + "Return T if every element in LIST-1 is also in LIST-2." + (when test-not + (setq test (complement test-not))) + (dolist (element list-1 t) + (unless (member (apply-key key element) list-2 :key key :test test) + (return nil)))) + +(defun set-difference (list-1 list-2 &key key (test #'eql) test-not) + "Return the elements of LIST-1 which are not in LIST-2." + (when test-not + (setq test (complement test-not))) + (let ((result nil)) + (dolist (element list-1) + (unless (member (apply-key key element) list-2 :key key :test test) + (push element result))) + result)) + +(defun nset-difference (list-1 list-2 &key key (test #'eql) test-not) + "Return the elements of LIST-1 which are not in LIST-2, modifying LIST-1." + (when test-not + (setq test (complement test-not))) + (do* ((result nil) + (list-1 list-1) + tmp) + ((endp list-1) result) + (if (member (apply-key key (car list-1)) list-2 :key key :test test) + (setq list-1 (cdr list-1)) + (setq tmp (cdr list-1) + result (rplacd list-1 result) + list-1 tmp)))) + +(defun set-exclusive-or (list-1 list-2 &key key (test #'eql) test-not) + "Return a list of elements that appear in exactly one of LIST-1 and LIST-2." + (when test-not + (setq test (complement test-not))) + (let ((result nil)) + (dolist (element list-1) + (unless (member (apply-key key element) list-2 :key key :test test) + (push element result))) + (dolist (element list-2) + (unless (member (apply-key key element) list-1 :key key :test test) + (push element result))) + result)) + +(defun nset-exclusive-or (list-1 list-2 &key key (test #'eql) test-not) + "The destructive version of set-exclusive-or." + (when test-not + (setq test (complement test-not))) + (do* ((head-1 (cons nil list-1)) + (head-2 (cons nil list-2)) + (p-1 head-1)) + ((or (endp (cdr p-1)) (endp (cdr head-2))) + (progn (rplacd (last p-1) (cdr head-2)) + (cdr head-1))) + (do ((p-2 head-2 (cdr p-2))) + ((endp (cdr p-2)) (setq p-1 (cdr p-1))) + (when (funcall test (apply-key key (cadr p-1)) (apply-key key (cadr p-2))) + (rplacd p-1 (cddr p-1)) + (rplacd p-2 (cddr p-2)) + (return))))) + +(defmacro pushnew (item place &rest keys &environment env) + "Test if ITEM is the same as any element of the list in PLACE. If not, prepend it to the list, then the new list is stored in PLACE." + (if (symbolp place) + `(setq ,place (adjoin ,item ,place ,@keys)) + (multiple-value-bind (temporary-vars values stores setter getter) + (get-setf-expansion place env) + (let ((item-var (gensym))) + `(let* ((,item-var ,item) + ,@(mapcar #'list temporary-vars values) + (,(car stores) (adjoin ,item-var ,getter ,@keys))) + ,setter))))) + + +(defun mapc (function list &rest more-lists) + "Apply FUNCTION to successive elements of lists, return LIST." + (do* ((lists (cons list more-lists)) + (args (make-list (length lists)))) + ((do ((l lists (cdr l)) + (a args (cdr a))) + ((or (null l) (endp (car l))) l) + (rplaca a (caar l)) + (rplaca l (cdar l))) + list) + (apply function args))) + +(defun mapcar (function list &rest more-lists) + "Apply FUNCTION to successive elements of lists, return list of results." + (do* ((lists (cons list more-lists)) + (len (length lists)) + (args (make-list len) (make-list len)) + (result (list nil)) + (splice result)) + ((do ((l lists (cdr l)) + (a args (cdr a))) + ((or (null l) (endp (car l))) l) + (rplaca a (caar l)) + (rplaca l (cdar l))) + (cdr result)) + (setq splice (cdr (rplacd splice (list (apply function args))))))) + +(defun mapcan (function list &rest more-lists) + "Apply FUNCTION to successive elements of lists, return nconc of results." + (apply #'nconc (apply #'mapcar function list more-lists))) + +(defun mapl (function list &rest more-lists) + "Apply FUNCTION to successive sublists of list, return LIST." + (do* ((lists (cons list more-lists))) + ((member nil lists) list) + (apply function lists) + (do ((l lists (cdr l))) + ((endp l)) + (rplaca l (cdar l))))) + +(defun maplist (function list &rest more-lists) + "Apply FUNCTION to successive sublists of list, return list of results." + (do* ((lists (cons list more-lists)) + (result (list nil)) + (splice result)) + ((member nil lists) (cdr result)) + (setq splice (cdr (rplacd splice (list (apply function lists))))) + (do ((l lists (cdr l))) + ((endp l)) + (rplaca l (cdar l))))) + +(defun mapcon (function list &rest more-lists) + "Apply FUNCTION to successive sublists of lists, return nconc of results." + (apply #'nconc (apply #'maplist function list more-lists))) + + + +(defun get-properties (plist indicator-list) + "Look up any of several property list entries all at once." + (do ((plist plist (cddr plist))) + ((endp plist) (values nil nil nil)) + (when (member (car plist) indicator-list) + (return (values (car plist) (cadr plist) plist))))) + +(defun getf (plist indicator &optional (default ())) + "Find a property on PLIST whose property indicator is identical to INDICATOR, and returns its corresponding property value." + (do ((plist plist (cddr plist))) + ((endp plist) default) + (when (eq indicator (car plist)) + (return (cadr plist))))) + + + +(define-setf-expander getf (place indicator + &optional (default nil default-supplied) + &environment env) + (multiple-value-bind (temporary-vars values stores setter getter) + (get-setf-expansion place env) + (let ((value-var (gensym)) + (indicator-var (gensym)) + (place-var (gensym)) + (tail-var (gensym)) + (default-var (when default-supplied (gensym)))) + (values + `(,@temporary-vars ,indicator-var ,@(when default-supplied + `(,default-var))) + `(,@values ,indicator ,@(when default-supplied `(,default))) + `(,value-var) + `(let ((,place-var ,getter)) + (multiple-value-bind (,(gensym) ,(gensym) ,tail-var) + (get-properties ,place-var (list ,indicator-var)) + (if ,tail-var + (rplaca (cdr ,tail-var) ,value-var) + (let ((,(car stores) (cons ,indicator-var + (cons ,value-var ,place-var)))) + ,setter + ,value-var)) + ,value-var)) + `(getf ,getter ,indicator-var ,@(when default-supplied + `(,default-var))))))) + +(defmacro remf (place indicator &environment env) + "Remove from the property list stored in PLACE a property with a property indicator identical to INDICATOR." + (multiple-value-bind (temporary-vars values stores setter getter) + (get-setf-expansion place env) + (let ((indicator-var (gensym)) + (plist-var (gensym)) + (splice-var (gensym))) + `(do* (,@(mapcar #'list temporary-vars values) + (,indicator-var ,indicator) + (,plist-var (cons nil ,getter)) + (,splice-var ,plist-var (cddr ,splice-var)) + ,(car stores)) + ((endp ,splice-var) nil) + (when (eq ,indicator-var (cadr ,splice-var)) + (rplacd ,splice-var (cdddr ,splice-var)) + (setq ,(car stores) (cdr ,plist-var)) + ,setter + (return t)))))) + diff --git a/Sacla/core.lisp b/Sacla/core.lisp new file mode 100644 index 0000000..509f0ab --- /dev/null +++ b/Sacla/core.lisp @@ -0,0 +1,726 @@ +;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp> +;; ALL RIGHTS RESERVED. +;; +;; $Id: core.lisp,v 1.30 2004/05/26 07:57:52 yuji Exp $ +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; * Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; * Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;;; primitives +;;(defun alloc-pointers (n) +;; (alloc-pointers n)) + + +;;; objects + +;; cons +(defstruct (cons (:constructor cons (car cdr)) + (:conc-name "") (:predicate consp) (:copier nil)) + (car) + (cdr) + ) + +(defun rplaca (cons object) + "Replace the car of CONS with OBJECT." + (setf (car cons) object) + cons) + +(defun rplacd (cons object) + "Replace the cdr of CONS with OBJECT." + (setf (cdr cons) object) + cons) + + +;; symbol +(defstruct (symbol (:constructor make-symbol (name)) (:predicate symbolp) (:copier nil)) + (name "" (:type string)) + (%value 'unbound) + (function nil) + (package nil) + (plist nil (:type list)) + ) + +(defconstant unbound + 'nil + "Represent variable's unbound state as a symbol itself.") + +(defconstant nil + 'nil + "Represent both boolean (and generalized boolean) false and the empty list.") + +(defconstant t + 't + "The boolean representing true, and the canonical generalized boolean representing true.") + +(defun boundp (symbol) + (not (eq (symbol-%value symbol) 'unbound))) + +(defun makunbound (symbol) + (setf (symbol-%value symbol) 'unbound)) + +(defun symbol-value (symbol) + (if (boundp symbol) + (symbol-%value symbol) + (error 'unbound-variable :name symbol))) + +(defsetf symbol-value (symbol) (new-value) + (setf (symbol-%value symbol) new-value)) + +(defun set (symbol value) + (setf (symbol-value symbol) value)) + +(defvar *gensym-counter* 0) +(defun gensym (&optional (x "G")) + (gensym x)) + + +;; function +(defstruct (function (:predicate functionp)) + (lambda-expression) + ) +;; functionp,,, are defined here + +(defun fdefinition (function-name) + (etypecase function-name + (symbol (symbol-function function-name)) + (setf-function-name ))) + +(defsetf fdefinition (function-name) (new-function) + ) + +(defun fboundp (name) + ) + +(defun fmakunbound (name) + ) + +(defun function-lambda-expression (function) + ) + +(defun compiled-function-p (object) + ) + +(defmacro function (name) + ) + + + +;;; special operators +(defmacro quote (object) + ) + +(defmacro eval-when (situations &body body) + ) + +(defmacro if (test-form then-form &optional else-form) + ) + +(defmacro load-time-value (form &optional read-only-p) + ) + +(defmacro locally (&rest declarations-and-forms) + ) + +(defmacro symbol-macrolet ((symbol-expansions) &body body) + ) + +(defmacro the (value-type form) + ) + + +;; data and control flow +(defun apply (function arg &rest more-args) + ) + +(defmacro defun (function-name lambda-list &body body) + ) + +(defmacro flet (functions &body body) + ) + +(defmacro labels (functions &body body) + ) + +(defmacro macrolet (macros &body body) + ) + +(defun funcall (function &rest args) + (when (and (symbolp function) + (or (not (fboundp function)) + (do ((x '(block catch eval-when flet function go if labels let + let* load-time-value locally macrolet + multiple-value-call multiple-value-prog1 progn progv + quote return-from setq symbol-macrolet tagbody the + throw unwind-protect) + (cdr x))) + ((null x) nil) + (when (eq function (car x)) + (return t))) + (macro-function function))) + (error 'undefined-function :name function)) + (apply function args)) + +(defconstant call-arguments-limit + 50 + "An integer not smaller than 50 and at least as great as the value of lambda-parameters-limit, the exact magnitude of which is implementation-dependent.") + +(defconstant lambda-parameters-limit + 50 + "A positive integer that is the upper exclusive bound on the number of parameter names that can appear in a single lambda list.") + +(defconstant lambda-list-keywords + '(&allow-other-keys &aux &body &environment &key &optional &rest &whole) + "a list, the elements of which are implementation-dependent, but which must contain at least the symbols &allow-other-keys, &aux, &body, &environment, &key, &optional, &rest, and &whole.") + +(defmacro defparameter (name initial-value + &optional (documentation nil documentation-p)) + `(progn (declaim (special ,name)) + (setf (symbol-value ',name) ,initial-value) + ,(when documentation-p + `(setf (documentation ',name 'variable) ',documentation)) + ',name)) + +(defmacro defvar (name &optional + (initial-value nil initial-value-p) + (documentation nil documentation-p)) + `(progn (declaim (special ,name)) + ,(when initial-value-p + `(unless (boundp ',name) + (setf (symbol-value ',name) ,initial-value))) + ,(when documentation-p + `(setf (documentation ',name 'variable) ',documentation)) + ',name)) + + +(defmacro defconstant (name initial-value &optional documentation) + ) + +(defmacro destructuring-bind (lambda-list expression &body body) + ) + +(defmacro let (vars &body body) + ) + +(defmacro let* (vars &body body) + ) + +(defmacro progv (symbols values &body body) + ) + +(defmacro setq (&rest pairs) + ) + +(defmacro block (name &body body) + ) + +(defmacro catch (tag &body body) + ) + +(defmacro go (tag) + ) + +(defmacro return-from (name &optional result) + ) + +(defmacro tagbody (&body body) + ) + +(defmacro throw (tag result-form) + ) + +(defmacro unwind-protect (protected-form &rest cleanup-forms) + ) + +(defun eq (x y) + ) + +(defun eql (x y) + (or (eq x y) + (and (numberp x) (numberp y) (= x y) (eq (type-of x) (type-of y))) + (and (characterp x) (characterp y) (char= x y)))) + +(defun equalp (x y) + (cond + ((eq x y) t) + ((characterp x) (and (characterp y) (char-equal x y))) + ((numberp x) (and (numberp y) (= x y))) + ((consp x) (and (consp y) (equalp (car x) (car y)) (equalp (cdr x) (cdr y)))) + ((arrayp x) (and (arrayp y) + (equal (array-dimensions x) (array-dimensions y)) + (dotimes (i (array-total-size x) t) + (unless (equalp (row-major-aref x i) (row-major-aref y i)) + (return nil))))) + ((hash-table-p x) (and (hash-table-p y) + (= (hash-table-count x) (hash-table-count y)) + (eq (hash-table-test x) (hash-table-test y)) + (with-hash-table-iterator (get x) + (loop + (multiple-value-bind (entry-returned key x-value) + (get) + (unless entry-returned + (return t)) + (multiple-value-bind (y-value present-p) + (gethash key y) + (unless (and present-p (equalp x-value y-value)) + (return nil)))))))) + ((typep x 'structure-object) (and (typep x 'structure-object) + (eq (class-of x) (class-of y)) + )) + (t nil))) + + +(defun values (&rest object) + ) + +(defmacro multiple-value-call (function-form &body body) + ) + +(defmacro multiple-value-prog1 (first-form &rest forms) + ) + +(defconstant multiple-values-limit most-positive-fixnum "") + +(defmacro progn (&rest forms) + ) + +(defmacro define-modify-macro (name lambda-list function &optional documentation) + ) + +(defmacro defsetf (access-fn &rest rest) + ) + +(defmacro define-setf-expander (access-fn lambda-list &body body) + ) + +(defun get-setf-expansion (place &optional environment) + ) + + +;; eval +(defun compile (name &optional definition) + (compile name definition)) + +(defun eval (form) + ) + +(defun compiler-macro-function (name &optional environment) + ) + +(defsetf compiler-macro-function (name &optional environment) (new-function) + ) + +(defmacro define-compiler-macro (name lambda-list &body body) + ) + +(defmacro defmacro (name lambda-list &body body) + ) + +(defun macro-function (symbol &optional environment) + ) + +(defsetf macro-function (symbol &optional environment) (new-function) + ) + +(defun macroexpand-1 (form &optional env) + ) + +(defmacro define-symbol-macro (symbol expansion) + ) + +(defvar *macroexpand-hook* #'funcall + "") + +(defun proclaim (declaration-specifier) + ) + +(defmacro declaim (&rest declaration-specifiers) + ) + +(defun constantp (form &optional environment) + ) + + +;; array +(defun arrayp (object) + (arrayp object)) + +(defun make-array (dimensions &key (element-type t) + initial-element initial-contents adjustable + fill-pointer displaced-to displaced-index-offset) + ) + +(defun adjust-array (array new-dimensions &key + (element-type (array-element-type array)) + initial-element initial-contents + fill-pointer displaced-to displaced-index-offset) + ) + + +(defun adjustable-array-p (array) + (adjustable-array-p array)) + +(defun array-dimensions (array) + (array-dimensions array)) + +(defun array-element-type (array) + (array-element-type array)) + +(defun array-has-fill-pointer-p (array) + (array-has-fill-pointer-p array)) + +(defun array-displacement (array) + (array-displacement array)) + +(defun fill-pointer (vector) + (fill-pointer vector)) + +(defsetf fill-pointer (vector) (value) + `(setf (fill-pointer ,vector) ,value)) + +(defun row-major-aref (array index) + (row-major-aref array index)) + +(defsetf row-major-aref (array index) (value) + `(setf (row-major-aref ,array ,index) ,value)) + +(defun upgraded-array-element-type (typespec &optional environment) + (upgraded-array-element-type typespec environment)) + +(defconst array-dimension-limit 1024 + "") + +(defconst array-rank-limit 8 + "") + +(defconst array-total-size-limit 1024 + "") + +(defun simple-vector-p (object) + "" + (simple-vector-p object)) + +(defun svref (simple-vector index) + "" + (svref simple-vector index)) + +(defsetf svref (simple-vector index) (value) + `(setf (svref ,simple-vector ,index) ,value)) + +(defun bit (bit-array &rest subscripts) + (apply #'bit bit-array subscripts)) + +(defsetf bit (bit-array &rest subscripts) (value) + `(setf (apply #'bit ,bit-array ,subscripts) ,value)) + +(defun sbit (bit-array &rest subscripts) + (apply #'sbit bit-array subscripts)) + +(defsetf sbit (bit-array &rest subscripts) (value) + `(setf (apply #'sbit ,bit-array ,subscripts) ,value)) + + +(defun bit-and (bit-array1 bit-array2 &optional opt-arg) + (bit-and bit-array1 bit-array2 opt-arg)) + +(defun bit-ior (bit-array1 bit-array2 &optional opt-arg) + (bit-ior bit-array1 bit-array2 opt-arg)) + +(defun bit-xor (bit-array1 bit-array2 &optional opt-arg) + (bit-xor bit-array1 bit-array2 opt-arg)) + +(defun bit-not (bit-array &optional opt-arg) + (bit-not bit-array opt-arg)) + + +;; string +(defun char (string index) + (char string index)) + +(defsetf char (string index) (value) + `(setf (char ,string ,index) ,value)) + +(defun schar (string index) + (schar string index)) + +(defsetf schar (string index) (value) + `(setf (schar ,string ,index) ,value)) + + +;; character +(defconst char-code-limit 256 + "") + +(defun char= (character &rest more-characters) + (apply #'char= character more-characters)) + +(defun char< (character &rest more-characters) + (apply #'char< character more-characters)) + +(defun characterp (object) + (characterp object)) + +(defun alpha-char-p (character) + (alpha-char-p character)) + +(defun alphanumericp (character) + (alphanumericp character)) + +(defun graphic-char-p (character) + (graphic-char-p character)) + +(defun char-upcase (character) + (char-upcase character)) + +(defun char-downcase (character) + (char-downcase character)) + +(defun upper-case-p (character) + (upper-case-p character)) + +(defun lower-case-p (character) + (lower-case-p character)) + +(defun both-case-p (character) + (both-case-p character)) + +(defun char-code (character) + (char-code character)) + +(defun char-int (character) + (char-int character)) + +(defun char-name (character) + (char-name character)) + +(defun name-char (name) + (name-char name)) + + +;; sequence +(defun make-sequence (result-type size &key initial-element) + "Return a sequence of the type RESULT-TYPE and of length SIZE." + ) + + +;; hash-table + +;; (defun hash-table-p (object) +;; ) +;; +;; (defun make-hash-table (&key test size rehash-size rehash-threshold) +;; ) + +;; (defun hash-table-count (hash-table) +;; ) +;; +;; (defun hash-table-size (hash-table) +;; ) +;; +;; (defun hash-table-rehash-size (hash-table) +;; ) +;; +;; (defun hash-table-rehash-threshold (hash-table) +;; ) +;; +;; (defun hash-table-test (hash-table) +;; ) + +;; (defun gethash (key hash-table &optional default) +;; ) +;; +;; (defsetf gethash (key hash-table &optional default) (value) +;; `(setf (gethash ,key ,hash-table ,default) ,value)) + +;; (defun remhash (key hash-table) +;; ) + +;; (defmacro with-hash-table-iterator ((name hash-table) &body body) +;; ) + +;; (defun clrhash (hash-table) +;; ) + +(defun sxhash (object) + (rem (equal-hash) most-positive-fixnum)) + + +;; stream +(defun streamp (object) + ) + +(defun input-stream-p (stream) + ) + +(defun output-stream-p (stream) + ) + +(defun interactive-stream-p (stream) + ) + +(defun open-stream-p (stream) + ) + +(defun stream-element-type (stream) + ) + +(defun read-byte (stream &optional eof-error-p eof-value) + ) + +(defun write-byte (byte stream) + ) + +(defun peek-char (&optional peek-type input-stream eof-error-p eof-value + recursive-p) + ) + +(defun read-char (&optional input-stream eof-error-p eof-value recursive-p) + ) + +(defun read-char-no-hang (&optional input-stream eof-error-p eof-value + recursive-p) + ) + +(defun unread-char (character &optional input-stream) + ) + +(defun write-char (character &optional output-stream) + ) + +(defun fresh-line (&optional output-stream) + ) + +(defun file-length (stream) + ) + +(defun file-position (stream &optional position) + ) + +(defun file-string-length (stream object) + ) + +(defun open (filespec &key direction element-type + if-exists if-does-not-exist external-format) + ) + +(defun stream-external-format (stream) + ) + +(defun close (stream &key abort) + ) + +(defun listen (&optional input-stream) + ) + +(defun clear-input (&optional input-stream) + ) + +(defun finish-output (&optional output-stream) + ) + +(defun force-output (&optional output-stream) + ) + +(defun clear-output (&optional output-stream) + ) + +(defun y-or-n-p (&optional control &rest arguments) + ) + +(defun yes-or-no-p (&optional control &rest arguments) + ) + +(defun make-synonym-stream (symbol) + ) + +(defun synonym-stream-symbol (synonym-stream) + ) + +(defun make-broadcast-stream (&rest streams) + ) + +(defun broadcast-stream-streams (broadcast-stream) + ) + +(defun make-two-way-stream (input-stream output-stream) + ) + +(defun two-way-stream-input-stream (two-way-stream) + ) + +(defun two-way-stream-output-stream (two-way-stream) + ) + +(defun make-echo-stream (input-stream output-stream) + ) + +(defun echo-stream-input-stream (echo-stream) + ) + +(defun echo-stream-output-stream (echo-stream) + ) + +(defun make-concatenated-stream (&rest input-streams) + ) + +(defun concatenated-stream-streams (concatenated-stream) + ) + + +(defun make-string-input-stream (string &optional start end) + ) + +(defun make-string-output-stream (&key element-type) + ) + +(defun get-output-stream-string (string-output-stream) + ) + + +(defun stream-error-stream (condition) + ) + +(defvar *DEBUG-IO*) +(defvar *ERROR-OUTPUT*) +(defvar *QUERY-IO*) +(defvar *STANDARD-INPUT*) +(defvar *STANDARD-OUTPUT*) +(defvar *TRACE-OUTPUT*) +(defvar *TERMINAL-IO*) + +(defmacro with-input-from-string ((var string &key index (start 0) end) + &body body) + (multiple-value-bind (decls forms) (declarations-and-forms body) + `(let ((,var (make-string-input-stream ,string ,start ,end))) + ,@decls + (unwind-protect + (progn ,@forms) + (close ,var) + ,@(when index + `((setf ,index (string-input-stream-current-position ,var)))))))) + + +(defmacro with-output-to-string ((var &optional string-form &key element-type) + &body body)) + + +;;; package diff --git a/Sacla/data-and-control.lisp b/Sacla/data-and-control.lisp new file mode 100644 index 0000000..cea7493 --- /dev/null +++ b/Sacla/data-and-control.lisp @@ -0,0 +1,388 @@ +;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp> +;; ALL RIGHTS RESERVED. +;; +;; $Id: data-and-control.lisp,v 1.17 2004/09/02 06:59:43 yuji Exp $ +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; * Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; * Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(defun expand-case (keyform clauses &key (test #'eql)) + (let ((key (gensym)) + (last (car (last clauses)))) + `(let ((,key ,keyform)) + (declare (ignorable ,key)) + (cond + ,@(mapcar + #'(lambda (clause) + (let ((key-list (first clause)) + (forms (rest clause))) + (cond + ((and (eq clause last) (member key-list '(otherwise t))) + `(t ,@forms)) + ((not (listp key-list)) + `((funcall ',test ,key ',key-list) ,@forms)) + ((null key-list) + `(nil ,@forms)) + ((rest key-list) + `((member ,key ',key-list :test ',test) ,@forms)) + (t + `((funcall ',test ,key ',(car key-list)) ,@forms))))) + clauses))))) + +(defmacro psetq (&rest pairs) + ;; not use reverse for build order consistency + (do* ((pairs pairs (cddr pairs)) + (tmp (gensym) (gensym)) + (inits (list nil)) + (inits-splice inits) + (setqs (list nil)) + (setqs-splice setqs)) + ((null pairs) (when (cdr inits) + `(let ,(cdr inits) + (setq ,@(cdr setqs)) + nil))) + (setq inits-splice + (cdr (rplacd inits-splice (list (list tmp (cadr pairs))))) + setqs-splice + (cddr (rplacd setqs-splice (list (car pairs) tmp)))))) + + +(defmacro return (&optional result) + `(return-from nil ,result)) + +(defun not (x) + (if x nil t)) + +(defun equal (x y) + (cond + ((eql x y) t) + ((consp x) (and (consp y) (equal (car x) (car y)) (equal (cdr x) (cdr y)))) + ((stringp x) (and (stringp y) (string= x y))) + ((bit-vector-p x) (and (bit-vector-p y) (= (length x) (length y)) + (dotimes (i (length x) t) + (unless (eql (aref x i) (aref y i)) + (return nil))))) + ((pathnamep x) (and (pathnamep y) + (equal (pathname-host x) (pathname-host y)) + (equal (pathname-device x) (pathname-device y)) + (equal (pathname-directory x) (pathname-directory y)) + (equal (pathname-name x) (pathname-name y)) + (equal (pathname-type x) (pathname-type y)) + (equal (pathname-version x) (pathname-version y)))) + (t nil))) + +(defun identity (object) + object) + +(defun complement (function) + #'(lambda (&rest arguments) (not (apply function arguments)))) + +(defun constantly (object) + #'(lambda (&rest arguments) + (declare (ignore arguments)) + object)) + +(defmacro and (&rest forms) + (cond + ((null forms) t) + ((null (cdr forms)) (car forms)) + (t `(when ,(car forms) + (and ,@(cdr forms)))))) + +(defmacro or (&rest forms) + (cond + ((null forms) nil) + ((null (cdr forms)) (car forms)) + (t (let ((tmp (gensym))) + `(let ((,tmp ,(car forms))) + (if ,tmp + ,tmp + (or ,@(cdr forms)))))))) + +(defmacro cond (&rest clauses) + (when clauses + (let ((test1 (caar clauses)) + (forms1 (cdar clauses))) + (if forms1 + `(if ,test1 + (progn ,@forms1) + (cond ,@(cdr clauses))) + (let ((tmp (gensym))) + `(let ((,tmp ,test1)) + (if ,tmp + ,tmp + (cond ,@(cdr clauses))))))))) + +(defmacro when (test-form &rest forms) + `(if ,test-form + (progn ,@forms) + nil)) + +(defmacro unless (test-form &rest forms) + `(if ,test-form + nil + (progn ,@forms))) + + +(defmacro case (keyform &rest clauses) + (expand-case keyform clauses)) + +(defmacro ccase (keyplace &rest clauses) + (let* ((clauses (mapcar #'(lambda (clause) + (let ((key (first clause)) + (forms (rest clause))) + `(,(%list key) ,@forms))) + clauses)) + (expected-type `(member ,@(apply #'append (mapcar #'car clauses)))) + (block-name (gensym)) + (tag (gensym))) + `(block ,block-name + (tagbody + ,tag + (return-from ,block-name + (case ,keyplace + ,@clauses + (t (restart-case (error 'type-error :datum ,keyplace + :expected-type ',expected-type) + (store-value (value) + :report (lambda (stream) + (store-value-report stream ',keyplace)) + :interactive store-value-interactive + (setf ,keyplace value) + (go ,tag)))))))))) + + +(defmacro ecase (keyform &rest clauses) + (let* ((clauses (mapcar #'(lambda (clause) + (let ((key (first clause)) + (forms (rest clause))) + `(,(%list key) ,@forms))) + clauses)) + (expected-type `(member ,@(apply #'append (mapcar #'car clauses))))) + `(case ,keyform + ,@clauses + (t (error 'type-error :datum ,keyform :expected-type ',expected-type))))) + +(defmacro typecase (keyform &rest clauses) + (let* ((last (car (last clauses))) + (clauses (mapcar #'(lambda (clause) + (let ((type (first clause)) + (forms (rest clause))) + (if (and (eq clause last) + (member type '(otherwise t))) + clause + `((,type) ,@forms)))) + clauses))) + (expand-case keyform clauses :test #'typep))) + +(defmacro ctypecase (keyplace &rest clauses) + (let ((expected-type `(or ,@(mapcar #'car clauses))) + (block-name (gensym)) + (tag (gensym))) + `(block ,block-name + (tagbody + ,tag + (return-from ,block-name + (typecase ,keyplace + ,@clauses + (t (restart-case (error 'type-error + :datum ,keyplace + :expected-type ',expected-type) + (store-value (value) + :report (lambda (stream) + (store-value-report stream ',keyplace)) + :interactive store-value-interactive + (setf ,keyplace value) + (go ,tag)))))))))) + + + +(defmacro etypecase (keyform &rest clauses) + `(typecase ,keyform + ,@clauses + (t (error 'type-error + :datum ',keyform :expected-type '(or ,@(mapcar #'car clauses)))))) + + +(defmacro multiple-value-bind (vars values-form &body body) + (cond + ((null vars) + `(progn ,@body)) + ((null (cdr vars)) + `(let ((,(car vars) ,values-form)) + ,@body)) + (t + (let ((rest (gensym))) + `(multiple-value-call #'(lambda (&optional ,@vars &rest ,rest) + (declare (ignore ,rest)) + ,@body) + ,values-form))))) + + + +(defmacro multiple-value-list (form) + `(multiple-value-call #'list ,form)) + +(defmacro multiple-value-setq (vars form) + `(values (setf (values ,@vars) ,form))) +;; (let ((temps (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) vars))) +;; `(multiple-value-bind ,temps ,form +;; (setq ,@(mapcan #'(lambda (var temp) (list var temp)) vars temps)) +;; ,(car temps)))) + +(defun values-list (list) + (check-type list proper-list) + (apply #'values list)) + +(defmacro nth-value (n form) + `(nth ,n (multiple-value-list ,form))) + +(define-setf-expander values (&rest places &environment env) + (let (all-temps all-vars 1st-newvals rest-newvals all-setters all-getters) + (dolist (place places) + (multiple-value-bind (temps vars newvals setter getter) + (get-setf-expansion place env) + (setq all-temps (cons temps all-temps) + all-vars (cons vars all-vars) + 1st-newvals (cons (car newvals) 1st-newvals) + rest-newvals (cons (cdr newvals) rest-newvals) + all-setters (cons setter all-setters) + all-getters (cons getter all-getters)))) + (values (apply #'append (reverse (append rest-newvals all-temps))) + (append (apply #'append (reverse all-vars)) + (make-list (reduce #'+ rest-newvals :key #'length))) + (reverse 1st-newvals) + `(values ,@(reverse all-setters)) + `(values ,@(reverse all-getters))))) + +;;(define-setf-expander apply (function &rest args) +;; (assert (and (listp function) +;; (= (list-length function) 2) +;; (eq (first function) 'function) +;; (symbolp (second function)))) +;; (let ((function (cadr function)) +;; (newvals (list (gensym))) +;; (temps (mapcar #'(lambda (arg) (gensym)) args))) +;; (values temps +;; args +;; newvals +;; `(apply #'(setf ,function) ,(car newvals) ,@vars) +;; `(apply #',function ,@temps)))) + +(defmacro prog (vars &body body) + (flet ((declare-p (expr) + (and (consp expr) (eq (car expr) 'declare)))) + (do ((decls nil) + (forms body (cdr forms))) + ((not (declare-p (car forms))) `(block nil + (let ,vars + ,@(reverse decls) + (tagbody ,@forms)))) + (push (car forms) decls)))) + +(defmacro prog* (vars &body body) + (multiple-value-bind (decls forms) (declarations-and-forms body) + `(block nil + (let* ,vars + ,@(reverse decls) + (tagbody ,@forms))))) + +(defmacro prog1 (first-form &rest more-forms) + (let ((result (gensym))) + `(let ((,result ,first-form)) + ,@more-forms + ,result))) + +(defmacro prog2 (first-form second-form &rest more-forms) + `(prog1 (progn ,first-form ,second-form) ,@more-forms)) + + +(defmacro setf (&rest pairs &environment env) + (let ((nargs (length pairs))) + (assert (evenp nargs)) + (cond + ((zerop nargs) nil) + ((= nargs 2) + (let ((place (car pairs)) + (value-form (cadr pairs))) + (cond + ((symbolp place) + `(setq ,place ,value-form)) + ((consp place) + (if (eq (car place) 'the) + `(setf ,(caddr place) (the ,(cadr place) ,value-form)) + (multiple-value-bind (temps vars newvals setter getter) + (get-setf-expansion place env) + (declare (ignore getter)) + `(let (,@(mapcar #'list temps vars)) + (multiple-value-bind ,newvals ,value-form + ,setter)))))))) + (t + (do* ((pairs pairs (cddr pairs)) + (setfs (list 'progn)) + (splice setfs)) + ((endp pairs) setfs) + (setq splice (cdr (rplacd splice + `((setf ,(car pairs) ,(cadr pairs))))))))))) + +(defmacro psetf (&rest pairs &environment env) + (let ((nargs (length pairs))) + (assert (evenp nargs)) + (if (< nargs 4) + `(progn (setf ,@pairs) nil) + (let ((setters nil)) + (labels ((expand (pairs) + (if pairs + (multiple-value-bind (temps vars newvals setter getter) + (get-setf-expansion (car pairs) env) + (declare (ignore getter)) + (setq setters (cons setter setters)) + `(let (,@(mapcar #'list temps vars)) + (multiple-value-bind ,newvals ,(cadr pairs) + ,(expand (cddr pairs))))) + `(progn ,@setters nil)))) + (expand pairs)))))) + +(defmacro shiftf (&rest places-and-newvalue &environment env) + (let ((nargs (length places-and-newvalue))) + (assert (>= nargs 2)) + (let ((place (car places-and-newvalue))) + (multiple-value-bind (temps vars newvals setter getter) + (get-setf-expansion place env) + `(let (,@(mapcar #'list temps vars)) + (multiple-value-prog1 ,getter + (multiple-value-bind ,newvals + ,(if (= nargs 2) + (cadr places-and-newvalue) + `(shiftf ,@(cdr places-and-newvalue))) + ,setter))))))) + +(defmacro rotatef (&rest places &environment env) + (if (< (length places) 2) + nil + (multiple-value-bind (temps vars newvals setter getter) + (get-setf-expansion (car places) env) + `(let (,@(mapcar #'list temps vars)) + (multiple-value-bind ,newvals (shiftf ,@(cdr places) ,getter) + ,setter) + nil)))) diff --git a/Sacla/do.lisp b/Sacla/do.lisp new file mode 100644 index 0000000..6b7d3fd --- /dev/null +++ b/Sacla/do.lisp @@ -0,0 +1,85 @@ +;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp> +;; ALL RIGHTS RESERVED. +;; +;; $Id: do.lisp,v 1.12 2004/05/26 07:57:52 yuji Exp $ +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; * Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; * Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + +(defun do-expand (var-init-step-list test-and-result-forms body parallel-p) + (let ((top (gensym)) + (test-form (first test-and-result-forms)) + (result-forms (rest test-and-result-forms)) + (let-operator (if parallel-p 'let 'let*)) + (setq-operator (if parallel-p 'psetq 'setq))) + (multiple-value-bind (declarations forms) (declarations-and-forms body) + `(block nil + (,let-operator (,@(mapcar #'(lambda (x) (if (atom x) x (subseq x 0 2))) + var-init-step-list)) + ,@declarations + (tagbody + ,top + (when ,test-form (return (progn ,@result-forms))) + ,@forms + (,setq-operator ,@(mapcan #'(lambda (x) + (when (and (consp x) (= (length x) 3)) + `(,(first x) ,(third x)))) + var-init-step-list)) + (go ,top))))))) + +(defmacro do (var-init-step-list test-and-result-forms &body body) + (do-expand var-init-step-list test-and-result-forms body 'parallel)) + +(defmacro do* (var-init-step-list test-and-result-forms &body body) + (do-expand var-init-step-list test-and-result-forms body nil)) + +(defmacro dotimes ((var count-form &optional result-form) &body body) + (let ((max (gensym))) + `(do* ((,max ,count-form) + (,var 0 (1+ ,var))) + ((>= ,var ,max) ,result-form) + ,@body))) + +(defmacro dolist ((var list-form &optional result-form) &body body) + (let ((top (gensym)) + (tag (gensym)) + (list (gensym))) + (multiple-value-bind (declarations forms) (declarations-and-forms body) + `(block nil + (let ((,list ,list-form) + (,var nil)) + (declare (ignorable ,var)) + (unless (atom ,list) + (let ((,var (car ,list))) + ,@declarations + (block ,tag + (tagbody + ,top + ,@forms + (setq ,list (cdr ,list)) + (when (atom ,list) (return-from ,tag)) + (setq ,var (car ,list)) + (go ,top))))) + ,result-form))))) + diff --git a/Sacla/eval.lisp b/Sacla/eval.lisp new file mode 100644 index 0000000..fec502a --- /dev/null +++ b/Sacla/eval.lisp @@ -0,0 +1,46 @@ +;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp> +;; ALL RIGHTS RESERVED. +;; +;; $Id: eval.lisp,v 1.6 2004/02/20 07:23:42 yuji Exp $ +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; * Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; * Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;;(defmacro lambda (lambda-list &body body) +;; (function `(lambda ,lambda-list ,@body))) + +;;(defun macroexpand (form &optional env) +;; (multiple-value-bind (expansion expanded-p) +;; (macroexpand-1 form env) +;; (if (not expanded-p) +;; (return (values form nil))) +;; (loop +;; (multiple-value-bind (expansion expanded-p) +;; (macroexpand-1 expansion expanded-p)) +;; (unless expanded-p +;; (return (values expansion t)))))) + +(defun special-operator-p (symbol) + (check-type symbol symbol) + (member symbol '(block catch eval-when flet function go if labels let let* load-time-value locally macrolet multiple-value-call multiple-value-prog1 progn progv quote return-from setq symbol-macrolet tagbody the throw unwind-protect))) + diff --git a/Sacla/hash-table.lisp b/Sacla/hash-table.lisp new file mode 100644 index 0000000..d45ebcb --- /dev/null +++ b/Sacla/hash-table.lisp @@ -0,0 +1,248 @@ +;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp> +;; ALL RIGHTS RESERVED. +;; +;; $Id: hash-table.lisp,v 1.14 2004/09/02 06:59:43 yuji Exp $ +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; * Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; * Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(defun %print-hash-table (hash-table stream depth) + (declare (ignore depth)) + (format stream "#<~A hash table (sumire), ~D entr~@:P>" + (symbol-name (hash-table-test hash-table)) + (hash-table-count hash-table))) + +;;(defun prime () +;; (do ((primes (list 3)) +;; (n 5 (+ n 2))) +;; ((> n 10000)) +;; (dolist (prime primes (progn (push n primes) (print n))) +;; (when (zerop (rem n prime)) +;; (return))))) +;; +;;(defun prime-p (n) +;; (do ((i 2 (1+ i))) +;; ((= i n) t) +;; (when (zerop (rem n i)) +;; (return nil)))) + +(defun touch-up-size (size) + (let ((primes '(211 307 401 503 601 701 809 907 1009 1259 1511 2003 3001 + 4001 5003 6007 7001 8009 9001 10007 12007 14009 16001 18013 + 20011 30011 40009 50021 60013 70001 80021 90001 100003))) + (dolist (prime primes) + (when (> prime size) + (return-from touch-up-size prime)))) + (setq size (ceiling size)) + (when (zerop (rem size 2)) (incf size)) + (when (zerop (rem size 3)) (incf size 2)) + (when (zerop (rem size 7)) (incf size 4)) + size) + +(defun calculate-rehash-count (size rehash-threshold) + (floor (* size (max 0.2 rehash-threshold)))) + +(defstruct (hash-table + (:constructor %make-hash-table) + (:print-function %print-hash-table)) + "" + (count 0 :type (integer 0 *)) + (size (required-argument) :type (integer 0 *)) + (rehash-size (required-argument) + :type (or (integer 1 *) (float (1.0) *)) :read-only t) + (rehash-threshold (required-argument) :type (real 0 1) :read-only t) + (test (required-argument) :type symbol :read-only t) + (test-function (required-argument) :type function :read-only t) + (hash-function (required-argument) :type function :read-only t) + (buckets (required-argument) :type vector) + (rehash-count (required-argument) :type (integer 0 *))) + +(defun make-hash-table (&key (test 'eql) + (size 67) + (rehash-size 1.5) + (rehash-threshold 0.5)) + (cond + ((eq test #'eq) (setq test 'eq)) + ((eq test #'eql) (setq test 'eql)) + ((eq test #'equal) (setq test 'equal)) + ((eq test #'equalp) (setq test 'equalp))) + (let* ((hash-function (ecase test + (eq #'eq-hash) + (eql #'eql-hash) + (equal #'equal-hash) + (equalp #'equalp-hash))) + (size (touch-up-size size)) + (buckets (make-array size :initial-element nil)) + (rehash-count (calculate-rehash-count size rehash-threshold)) + (hash-table (%make-hash-table :size size + :rehash-size rehash-size + :rehash-threshold rehash-threshold + :rehash-count rehash-count + :buckets buckets + :test test + :test-function (symbol-function test) + :hash-function hash-function))) + hash-table)) + +(defun gethash (key hash-table &optional default) + (let* ((hash (funcall (hash-table-hash-function hash-table) key)) + (size (hash-table-size hash-table)) + (test-function (hash-table-test-function hash-table)) + (chain (aref (hash-table-buckets hash-table) (rem hash size)))) + (do ((plist chain (cddr plist))) + ((atom plist) (values default nil)) + (when (funcall test-function (car plist) key) + (return (values (cadr plist) t)))))) + +(defun puthash (key value hash-table) + (let* ((hash (funcall (hash-table-hash-function hash-table) key)) + (size (hash-table-size hash-table)) + (test-function (hash-table-test-function hash-table)) + (buckets (hash-table-buckets hash-table)) + (index (rem hash size)) + (chain (aref buckets index))) + (do ((plist chain (cddr plist))) + ((atom plist) (progn + (setf (aref buckets index) (cons key (cons value chain))) + (incf (hash-table-count hash-table)))) + (when (funcall test-function (car plist) key) + (rplaca (cdr plist) value) + (return)))) + value) + +(defun rehash-hash-table (hash-table) + (let* ((old-size (hash-table-size hash-table)) + (old-buckets (hash-table-buckets hash-table)) + (rehash-threshold (hash-table-rehash-threshold hash-table)) + (rehash-size (hash-table-rehash-size hash-table)) + (count (hash-table-count hash-table)) + (size (touch-up-size (max (funcall (if (integerp rehash-size) #'+ #'*) + old-size rehash-size) + (/ count (max 0.5 rehash-threshold))))) + (buckets (make-array size :initial-element nil))) + (setf (hash-table-count hash-table) 0 + (hash-table-size hash-table) size + (hash-table-buckets hash-table) buckets + (hash-table-rehash-count hash-table) (calculate-rehash-count + size rehash-threshold)) + (dotimes (i old-size) + (do ((chain (aref old-buckets i) (cddr chain))) + ((atom chain)) + (puthash (car chain) (cadr chain) hash-table)))) + hash-table) + +(defun (setf gethash) (value key hash-table &optional default) + (declare (ignore default)) + (when (>= (hash-table-count hash-table) (hash-table-rehash-count hash-table)) + (rehash-hash-table hash-table)) + (puthash key value hash-table) + value) + +(defun remhash (key hash-table) + (let* ((hash (funcall (hash-table-hash-function hash-table) key)) + (size (hash-table-size hash-table)) + (test-function (hash-table-test-function hash-table)) + (buckets (hash-table-buckets hash-table)) + (index (rem hash size)) + (chain (aref buckets index))) + (do ((plist chain (cddr plist)) + (last nil (cdr plist))) + ((atom plist) nil) + (when (funcall test-function (car plist) key) + (if last + (rplacd last (cddr plist)) + (setf (aref buckets index) (cddr plist))) + (decf (hash-table-count hash-table)) + (return t))))) + + +(defun clrhash (hash-table) + (let ((buckets (hash-table-buckets hash-table)) + (size (hash-table-size hash-table))) + (dotimes (i size) + (setf (elt buckets i) nil)) + (setf (hash-table-count hash-table) 0) + hash-table)) + +(defun hash-table-iterator-1 (table) + (let* ((index 0) + (size (hash-table-size table)) + (chain (aref (hash-table-buckets table) 0))) + #'(lambda () + (block iterator + (loop + (when chain (return)) + (incf index) + (when (= index size) (return-from iterator nil)) + (setq chain (aref (hash-table-buckets table) index))) + (multiple-value-prog1 (values t (first chain) (second chain)) + (setq chain (cddr chain))))))) + +(defun hash-table-iterator (hash-table-list) + (let ((tables (%list hash-table-list))) + (cond + ((null tables) (constantly nil)) + ((null (rest tables)) (hash-table-iterator-1 (car tables))) + (t (let ((iterator (hash-table-iterator-1 (pop tables)))) + #'(lambda () + (loop + (multiple-value-bind (more key value) (funcall iterator) + (cond + (more (return (values more key value))) + (tables (setq iterator (hash-table-iterator-1 (pop tables)))) + (t (return nil))))))))))) + +(defmacro with-hash-table-iterator ((name hash-table-form) &body body) + (let ((iterator (gensym))) + `(let ((,iterator (hash-table-iterator ,hash-table-form))) + (declare (ignorable ,iterator)) + (macrolet ((,name () '(funcall ,iterator))) + ,@body)))) + + +(defun maphash (function hash-table) + (with-hash-table-iterator (next-entry hash-table) + (loop (multiple-value-bind (more key value) (next-entry) + (unless more (return nil)) + (funcall function key value))))) + + +(defun eq-hash (key) + (sxhash key)) +(defun eql-hash (key) + (sxhash key)) + +(defun equal-hash (key) + (sxhash key)) + +(defun equalp-hash (key) + (typecase key + (character (sxhash (char-upcase key))) + (float (sxhash (rationalize key))) + (cons 10) + (array 20) + (hash-table (logand (equalp-hash (hash-table-count key)) + (equalp-hash (hash-table-test key)))) + (structure-object (sxhash (class-of key))) + (t (sxhash key)))) + diff --git a/Sacla/init.lisp b/Sacla/init.lisp new file mode 100755 index 0000000..031b8e7 --- /dev/null +++ b/Sacla/init.lisp @@ -0,0 +1,55 @@ +;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp> +;; ALL RIGHTS RESERVED. +;; +;; $Id: init.lisp,v 1.7 2004/09/02 06:59:43 yuji Exp $ +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; * Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; * Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;;; Commentary: +;; I mainly use clisp, but other common lisp implementations should work +;; with a minor tweak. +;; Set *sacla-dir* to the dir where the sacla tree sits, +;; like (setq *sacla-dir* /path/to/sacla). +;; Load this file first (load "init"), then enter (in-package "TB"). +;; Load and test a lisp file like the following, +;; (ld "reader") +;; (test "must-reader"). +;; + +(defvar *sacla-dir* "/usr/local/src/lisp/sacla") +(defvar *sacla-lisp-dir* (concatenate 'string *sacla-dir* "/lisp")) +(defvar *sacla-lisp-tests-dir* (concatenate 'string *sacla-dir* "/lisp/tests")) +;;"/cygdrive/c/src/lisp/sacla/lisp" +;;(setq *print-circle* t) + +#+clisp (ext:cd *sacla-lisp-dir*) +#+cmu (unix:unix-chdir *sacla-lisp-dir*) + +(load (concatenate 'string *sacla-lisp-dir* "/testbed")) + +(in-package "TB") +(setq tb::*testbed-compile* t) +(tb::ld "share") + +(push :sacla *features*) diff --git a/Sacla/loop.lisp b/Sacla/loop.lisp new file mode 100644 index 0000000..f1ab322 --- /dev/null +++ b/Sacla/loop.lisp @@ -0,0 +1,1142 @@ +;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp> +;; ALL RIGHTS RESERVED. +;; +;; $Id: loop.lisp,v 1.38 2005/04/16 07:34:27 yuji Exp $ +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; * Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; * Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +#-sacla +(progn + (defpackage "SACLA-LOOP" + (:documentation "An ANSI Common Lisp Loop facility.") + (:use "COMMON-LISP") + (:shadow "ERROR" "WARN" "LOOP" "LOOP-FINISH") + (:export "LOOP" "LOOP-FINISH")) + (in-package "SACLA-LOOP")) + +#-sacla +(progn + (defvar *message-prefix* "") + (defun error (datum &rest arguments) + (when (stringp datum) + (setq datum (concatenate 'string *message-prefix* datum))) + (apply #'cl:error datum arguments)) + (defun warn (datum &rest arguments) + (when (stringp datum) + (setq datum (concatenate 'string *message-prefix* datum))) + (apply #'cl:warn datum arguments)) + + + (defun %list (designator) + (if (listp designator) designator (list designator))) + (defun %keyword (designator) + (intern (string designator) "KEYWORD")) + (define-modify-macro appendf (&rest args) append "Append onto list") + (defun mapappend (function &rest lists) + (apply #'append (apply #'mapcar function lists))) + (define-condition simple-program-error (simple-condition program-error) ()) +) + +(defun globally-special-p (symbol) + (assert (symbolp symbol)) + (if (constantp symbol) + (values nil t) + #+abcl (values (EXT:SPECIAL-VARIABLE-P symbol t)) + #+allegro (values (excl::variable-special-p symbol nil) t) + #+clisp (values (ext:special-variable-p symbol nil) t) + #+cmu (values (walker:variable-globally-special-p symbol) t) + #+ecl (values (si:specialp symbol) t) + #+gcl (values (si:specialp symbol) t) + #+lispworks (values (eq :special (hcl:variable-information symbol)) t) + #+sbcl (values (sb-walker:var-globally-special-p symbol) t) + #-(or abcl allegro clisp cmu ecl gcl lispworks sbcl) + (progn + (warn "Implementation-specific globally-special-p should be defined.") + (values nil nil)))) + +(defvar *loop-clauses* + (let ((table (make-hash-table))) + (mapc #'(lambda (spec) + (destructuring-bind (clause-name . keywords) spec + (dolist (key keywords) (setf (gethash key table) clause-name)))) + '((for-as-clause :for :as) + (with-clause :with) + (do-clause :do :doing) + (return-clause :return) + (initially-clause :initially) + (finally-clause :finally) + (accumulation-clause :collect :collecting :append :appending + :nconc :nconcing :count :counting :sum :summing :maximize :maximizing + :minimize :minimizing) + (conditional-clause :if :when :unless) + (repeat-clause :repeat) + (always-never-thereis-clause :always :never :thereis) + (while-clause :while) + (until-clause :until))) + table) + "A table mapping loop keywords to their processor function-designator.") + +(defvar *for-as-subclauses* + (let ((table (make-hash-table))) + (mapc #'(lambda (spec) + (destructuring-bind (subclause-name . keywords) spec + (dolist (key keywords) + (setf (gethash key table) subclause-name)))) + '((for-as-arithmetic-subclause + :from :downfrom :upfrom :to :downto :upto :below :above :by) + (for-as-in-list-subclause :in) + (for-as-on-list-subclause :on) + (for-as-equals-then-subclause :=) + (for-as-across-subclause :across) + (for-as-being-subclause :being))) + table) + "A table mapping for-as prepositions to their processor function-designator.") + +(defvar *for-as-prepositions* + (let ((prepositions nil)) + (maphash #'(lambda (key value) (declare (ignore value)) (push key prepositions)) + *for-as-subclauses*) + prepositions)) + +(defvar *environment*) +(defvar *loop-tokens*) +(defvar *current-keyword* nil) +(defvar *current-clause* nil) + +(defun append-context (message) + (concatenate 'string message + (let ((clause (ldiff *current-clause* *loop-tokens*))) + (format nil "~%Current LOOP context:~{ ~S~}" clause)))) + + +(defun loop-error (datum &rest arguments) + (when (stringp datum) (setq datum (append-context datum))) + (apply #'error datum arguments)) + +(defun loop-warn (datum &rest arguments) + (when (stringp datum) (setq datum (append-context datum))) + (apply #'warn datum arguments)) + + +(defun keyword? (&optional keyword-list-designator) + (and *loop-tokens* + (symbolp (car *loop-tokens*)) + (let ((keyword-list (%list keyword-list-designator)) + (keyword (%keyword (car *loop-tokens*)))) + (and (or (null keyword-list) (find keyword keyword-list)) + (setq *current-clause* *loop-tokens* + *loop-tokens* (rest *loop-tokens*) + *current-keyword* keyword))))) + +(defun keyword1 (keyword-list-designator &key prepositionp) + (let ((keywords (%list keyword-list-designator))) + (or (keyword? keywords) + (let ((length (length keywords)) + (kind (if prepositionp "preposition" "keyword"))) + (case length + (0 (loop-error "A loop ~A is missing." kind)) + (1 (loop-error "Loop ~A ~S is missing." kind (car keywords))) + (t (loop-error "One of the loop ~As ~S must be supplied." + kind keywords))))))) + +(defun preposition? (&optional keyword-list-designator) + (let ((*current-keyword* *current-keyword*) + (*current-clause* *current-clause*)) + (keyword? keyword-list-designator))) + +(defun preposition1 (&optional keyword-list-designator) + (let ((*current-keyword* *current-keyword*) + (*current-clause* *current-clause*)) + (keyword1 keyword-list-designator :prepositionp t))) + + + +(defvar *loop-name* nil) +(defvar *it-symbol* nil) +(defvar *it-visible-p* nil) +(defvar *anonymous-accumulator* nil) +(defvar *boolean-terminator* nil) +(defvar *accumulators* nil) +(defvar *loop-components* nil) + + + +(defun clause1 () + (multiple-value-bind (clause-function-designator present-p) + (gethash *current-keyword* *loop-clauses*) + (unless present-p + (loop-error "Unknown loop keyword ~S encountered." (car *current-clause*))) + (let ((*message-prefix* (format nil "LOOP ~A clause: " *current-keyword*))) + (funcall clause-function-designator)))) + +(defun clause* () + (loop + (let ((key (keyword?))) + (unless key (return)) + (clause1)))) + +(defun lp (&rest tokens) + (let ((*loop-tokens* tokens) + *current-keyword* + *current-clause*) + (clause*) + (when *loop-tokens* (error "~S remained after lp." *loop-tokens*)))) + +(defun form1 () + (unless *loop-tokens* (loop-error "A normal lisp form is missing.")) + (pop *loop-tokens*)) + +(defun compound-forms* () + (when (and *loop-tokens* (consp (car *loop-tokens*))) + (cons (pop *loop-tokens*) (compound-forms*)))) + +(defun compound-forms+ () + (or (compound-forms*) (loop-error "At least one compound form is needed."))) + +(defun simple-var-p (var) (and (not (null var)) (symbolp var))) + +(defun simple-var1 () + (unless (and *loop-tokens* (simple-var-p (car *loop-tokens*))) + (loop-error "A simple variable name is missing.")) + (pop *loop-tokens*)) + +(defun empty-p (d-var-spec) + (or (null d-var-spec) + (and (consp d-var-spec) + (empty-p (car d-var-spec)) + (empty-p (cdr d-var-spec))))) + +(defun d-var-spec-p (spec) + (or (simple-var-p spec) + (null spec) + (and (consp spec) (d-var-spec-p (car spec)) (d-var-spec-p (cdr spec))))) + +(defun d-var-spec1 () + (unless (and *loop-tokens* (d-var-spec-p (car *loop-tokens*))) + (loop-error "A destructured-variable-spec is missing.")) + (let ((d-var-spec (pop *loop-tokens*))) + d-var-spec)) + +(defun stray-of-type-error () + (loop-error "OF-TYPE keyword should be followed by a type spec.")) + +(defun type-spec? () + (let ((type t) + (supplied-p nil)) + (when (or (and (preposition? :of-type) (or *loop-tokens* (stray-of-type-error))) + (and *loop-tokens* (member (car *loop-tokens*) '(fixnum float t nil)))) + (setq type (pop *loop-tokens*) supplied-p t)) + (values type supplied-p))) + + +(defun car-type (d-type-spec) + (if (consp d-type-spec) (car d-type-spec) d-type-spec)) +(defun cdr-type (d-type-spec) + (if (consp d-type-spec) (cdr d-type-spec) d-type-spec)) +(defun default-value (type) + (cond + ((subtypep type 'bignum) (1+ most-positive-fixnum)) + ((subtypep type 'integer) 0) + ((subtypep type 'ratio) 1/10) + ((subtypep type 'float) 0.0) + ((subtypep type 'number) 0) + ((subtypep type 'character) #\Space) + ((subtypep type 'string) "") + ((subtypep type 'bit-vector) #*0) + ((subtypep type 'vector) #()) + ((subtypep type 'package) *package*) + (t nil))) +(defun default-type (type) + (if (eq type t) + t + (let ((value (default-value type))) + (if (typep value type) + type + (let ((default-type (type-of value))) + (if (subtypep type default-type) + default-type + (if (null value) + `(or null ,type) + `(or ,default-type ,type)))))))) + +(defun default-binding (type var) + `(,(default-type type) ,var ,(default-value type))) + +(defvar *temporaries* nil + "Temporary variables used in with-clauses and for-as-clauses.") + +(defvar *ignorable* nil + "Ignorable temporary variables in *temporaries*.") + +(defun constant-bindings (d-type-spec d-var-spec value) + (let ((bindings nil)) + (labels ((dig (type var value) + (cond + ((null var) nil) ;; do nothing + ((simple-var-p var) (appendf bindings `((,type ,var ',value)))) + (t (dig (car-type type) (car var) (car value)) + (dig (cdr-type type) (cdr var) (cdr value)))))) + (dig d-type-spec d-var-spec value) + bindings))) + +(defun default-bindings (d-type-spec d-var-spec) + (let ((bindings nil)) + (labels ((dig (type var) + (cond + ((null var) nil) ;; do nothing + ((simple-var-p var) + (appendf bindings `(,(default-binding type var)))) + (t (dig (car-type type) (car var)) + (dig (cdr-type type) (cdr var)))))) + (dig d-type-spec d-var-spec) + bindings))) + +(defun ordinary-bindings (d-type-spec d-var-spec value-form) + (let ((temporaries *temporaries*) + (bindings nil)) + (labels + ((dig (type var form temp) + ;; a TEMP moves horizontally, or cdr-wise, on an FORM. + ;; a TEMP can be reused by pushing it back onto TEMPORARIES. + (cond + ((empty-p var) nil) + ((simple-var-p var) + (when temp (push temp temporaries)) + (appendf bindings `((,type ,var ,form)))) + ((empty-p (car var)) + (dig (cdr-type type) (cdr var) `(cdr ,form) temp)) + ((empty-p (cdr var)) + (when temp (push temp temporaries)) + (dig (car-type type) (car var) `(car ,form) nil)) + (t (unless temp (setq temp (or (pop temporaries) (gensym)))) + (dig (car-type type) (car var) `(car (setq ,temp ,form)) nil) + (dig (cdr-type type) (cdr var) `(cdr ,temp) temp))))) + (dig d-type-spec d-var-spec value-form nil) + (setq *temporaries* temporaries) + bindings))) + +(defun quoted-form-p (form) + (let ((expansion (macroexpand form *environment*))) + (and (consp expansion) (eq (first expansion) 'quote)))) + +(defun quoted-object (form) + (let ((expansion (macroexpand form *environment*))) + (destructuring-bind (quote-special-operator object) expansion + (assert (eq quote-special-operator 'quote)) + object))) + +(defun bindings (d-type-spec d-var-spec + &optional (value-form "NEVER USED" value-form-p)) + (cond + ((null value-form-p) (default-bindings d-type-spec d-var-spec)) + ((quoted-form-p value-form) (constant-bindings d-type-spec d-var-spec + (quoted-object value-form))) + (t (ordinary-bindings d-type-spec d-var-spec value-form)))) + +(defun fill-in (&rest args) + (when args + (appendf (getf *loop-components* (first args)) (second args)) + (apply #'fill-in (cddr args)))) + +(defun declarations (bindings) + (let ((declarations (mapcan #'(lambda (binding) + (destructuring-bind (type var . rest) binding + (declare (ignore rest)) + (unless (eq type 't) `((type ,type ,var))))) + bindings))) + (when declarations `((declare ,@declarations))))) + +(defun let-form (bindings) `(let ,(mapcar #'cdr bindings) ,@(declarations bindings))) + +(defun with (var &optional (type t) &key (= (default-value type))) + (fill-in :binding-forms `(,(let-form `((,type ,var ,=)))))) + +(defun multiple-value-list-form-p (form) + (let (expanded-p) + (loop + (when (and (consp form) (eq (first form) 'multiple-value-list)) + (return t)) + (multiple-value-setq (form expanded-p) (macroexpand-1 form *environment*)) + (unless expanded-p (return nil))))) + +(defun multiple-value-list-argument-form (form) + (let ((expansion form) + (expanded-p nil)) + (loop + (when (and (consp expansion) (eq (first expansion) 'multiple-value-list)) + (return (second expansion))) + (multiple-value-setq (expansion expanded-p) + (macroexpand-1 expansion *environment*)) + (unless expanded-p + (error "~S is not expanded into a multiple-value-list form." form))))) + +(defun destructuring-multiple-value-bind (d-type-spec d-var-spec value-form) + (let ((mv-bindings nil) + (d-bindings nil) + (padding-temps nil) + temp) + (do ((vars d-var-spec (cdr vars)) + (types d-type-spec (cdr-type types))) + ((endp vars)) + (if (listp (car vars)) + (progn (setq temp (gensym)) + (appendf mv-bindings `((t ,temp))) + (appendf d-bindings `((,(car-type types) ,(car vars) ,temp))) + (when (empty-p (car vars)) (push temp padding-temps))) + (appendf mv-bindings `((,(car-type types) ,(car vars)))))) + (fill-in :binding-forms `((multiple-value-bind ,(mapcar #'second mv-bindings) + ,(multiple-value-list-argument-form value-form) + ,@(declarations mv-bindings) + ,@(when padding-temps + `((declare (ignore ,@padding-temps))))))) + (let ((bindings (mapappend #'(lambda (d-binding) (apply #'bindings d-binding)) + d-bindings))) + (when bindings (fill-in :binding-forms `(,(let-form bindings))))))) + +(defun d-var-type-spec () + (let ((var (d-var-spec1)) + (type (type-spec?))) + (when (empty-p var) + (unless (member type '(nil t)) (loop-warn "Type spec ~S is ignored." type)) + (setq var (gensym) + type t)) + (values var type))) + +(defun with-clause () + (let ((d-bindings nil)) + (loop (multiple-value-bind (var type) (d-var-type-spec) + (let ((rest (when (preposition? :=) `(,(form1))))) + (appendf d-bindings `((,type ,var ,@rest))))) + (unless (preposition? :and) (return))) + (destructuring-bind (d-binding0 . rest) d-bindings + (if (and (null rest) + (cddr d-binding0) + (destructuring-bind (type var form) d-binding0 + (declare (ignore type)) + (and (consp var) (multiple-value-list-form-p form)))) + (apply #'destructuring-multiple-value-bind d-binding0) + (let ((bindings (mapappend #'(lambda (d-binding) + (apply #'bindings d-binding)) + d-bindings))) + (fill-in :binding-forms `(,(let-form bindings)))))))) + + +(defun dispatch-for-as-subclause (var type) + (unless *loop-tokens* (loop-error "A preposition is missing.")) + (let ((preposition (preposition1 *for-as-prepositions*))) + (multiple-value-bind (subclause-function-designator present-p) + (gethash preposition *for-as-subclauses*) + (unless present-p + (loop-error "Unknown preposition ~S is supplied." preposition)) + (push preposition *loop-tokens*) + (funcall subclause-function-designator var type)))) + +(defun for (var type &rest rest) + (let ((*loop-tokens* rest)) + (dispatch-for-as-subclause var type))) + +(defvar *for-as-components*) +(defun for-as-fill-in (&rest key-list-pairs) + (when key-list-pairs + (destructuring-bind (key list . rest) key-list-pairs + (appendf (getf *for-as-components* key) list) + (apply #'for-as-fill-in rest)))) + +(defvar *hash-group* '(:hash-key :hash-keys :hash-value :hash-values)) +(defvar *symbol-group* '(:symbol :symbols :present-symbol :present-symbols + :external-symbol :external-symbols)) + +(defun loop-finish-test-forms (tests) + (case (length tests) + (0 nil) + (1 `((when ,@tests (loop-finish)))) + (t `((when (or ,@tests) (loop-finish)))))) + +(defun psetq-forms (args) + (assert (evenp (length args))) + (case (length args) + (0 nil) + (2 `((setq ,@args))) + (t `((psetq ,@args))))) + +(defun for-as-clause () + (let ((*for-as-components* nil)) + (loop (multiple-value-bind (var type) (d-var-type-spec) + (dispatch-for-as-subclause var type)) + (unless (preposition? :and) (return))) + (destructuring-bind (&key bindings bindings2 + before-head head-psetq head-tests after-head + before-tail tail-psetq tail-tests after-tail) + *for-as-components* + (fill-in :binding-forms `(,@(when bindings `(,(let-form bindings))) + ,@(when bindings2 `(,(let-form bindings2)))) + :head `(,@before-head + ,@(psetq-forms head-psetq) + ,@(loop-finish-test-forms head-tests) + ,@after-head) + :tail `(,@before-tail + ,@(psetq-forms tail-psetq) + ,@(loop-finish-test-forms tail-tests) + ,@after-tail))))) + +(defun for-as-parallel-p () + (or *for-as-components* + (and *loop-tokens* + (symbolp (car *loop-tokens*)) + (string= (symbol-name (car *loop-tokens*)) "AND")))) + +(defun gensym-ignorable () + (let ((var (gensym))) + (push var *ignorable*) + var)) + +(defun destructuring-multiple-value-setq (d-var-spec value-form &key iterator-p) + (let (d-bindings mv-vars temp) + (do ((vars d-var-spec (cdr vars))) + ((endp vars)) + (if (listp (car vars)) + (progn (setq temp (or (pop *temporaries*) (gensym-ignorable))) + (appendf mv-vars `(,temp)) + (appendf d-bindings `((t ,(car vars) ,temp)))) + (appendf mv-vars `(,(car vars))))) + (let ((mv-setq-form `(multiple-value-setq ,mv-vars ,value-form)) + (bindings nil)) + (do ((d-bindings d-bindings (cdr d-bindings))) + ((endp d-bindings)) + (destructuring-bind (type var temp) (car d-bindings) + (declare (ignore type var)) + (push temp *temporaries*) + (appendf bindings (apply #'bindings (car d-bindings))))) + (when iterator-p (setq mv-setq-form `(unless ,mv-setq-form (loop-finish)))) + (if bindings + `(progn ,mv-setq-form (setq ,@(mapappend #'cdr bindings))) + mv-setq-form)))) + +(defun along-with (var type &key equals (then equals)) + (for-as-fill-in :bindings (apply #'bindings type var (when (quoted-form-p equals) + `(,equals)))) + (unless (quoted-form-p equals) + (for-as-fill-in :after-head + `((setq ,@(mapappend #'cdr (bindings type var equals)))))) + (for-as-fill-in :after-tail + `((setq ,@(mapappend #'cdr (bindings type var then)))))) + +(defun for-as-equals-then-subclause (var type) + ;; 6.1.1.4 Expanding Loop Forms + ;; http://www.lispworks.com/reference/HyperSpec/Body/06_aad.htm + ;; the form1 and form2 in a for-as-equals-then form includes the lexical + ;; environment of all the loop variables. + (preposition1 :=) + (let* ((first (form1)) + (then (if (preposition? :then) (form1) first)) + (parallel-p (for-as-parallel-p))) + (for-as-fill-in :bindings (apply #'bindings type var (when (quoted-form-p first) + `(,first)))) + (if (and (not parallel-p) (consp var) (multiple-value-list-form-p first)) + (for-as-fill-in :before-head + `(,(destructuring-multiple-value-setq var + (multiple-value-list-argument-form first)))) + (unless (quoted-form-p first) + (for-as-fill-in :head-psetq (mapappend #'cdr (bindings type var first))))) + (if (and (not parallel-p) (consp var) (multiple-value-list-form-p then)) + (for-as-fill-in :before-tail + `(,(destructuring-multiple-value-setq var + (multiple-value-list-argument-form then)))) + (for-as-fill-in :tail-psetq (mapappend #'cdr (bindings type var then)))))) + + +(defun for-as-arithmetic-step-and-test-functions (used-prepositions) + (let ((up-p (subsetp used-prepositions '(:below :upto :upfrom :from :to :by)))) + (values (if up-p '+ '-) + (cond ((member :to used-prepositions) (if up-p '> '<)) + ((member :upto used-prepositions) '>) + ((member :below used-prepositions) '>=) + ((member :downto used-prepositions) '<) + ((member :above used-prepositions) '<=) + (t nil))))) + +(defun zero (type) + (cond + ((subtypep type 'short-float) 0.0s0) + ((subtypep type 'single-float) 0.0f0) + ((subtypep type 'double-float) 0.0d0) + ((subtypep type 'long-float) 0.0l0) + ((subtypep type 'float) 0.0) + (t 0))) + +(defun one (type) + (cond + ((subtypep type 'short-float) 1.0s0) + ((subtypep type 'single-float) 1.0f0) + ((subtypep type 'double-float) 1.0d0) + ((subtypep type 'long-float) 1.0l0) + ((subtypep type 'float) 1.0) + (t 1))) + +(defun for-as-arithmetic-possible-prepositions (used-prepositions) + (append + (cond + ((intersection '(:from :downfrom :upfrom) used-prepositions) nil) + ((intersection '(:downto :above) used-prepositions) '(:from :downfrom)) + ((intersection '(:upto :below) used-prepositions) '(:from :upfrom)) + (t '(:from :downfrom :upfrom))) + (cond + ((intersection '(:to :downto :upto :below :above) used-prepositions) nil) + ((find :upfrom used-prepositions) '(:to :upto :below)) + ((find :downfrom used-prepositions) '(:to :downto :above)) + (t '(:to :downto :upto :below :above))) + (unless (find :by used-prepositions) '(:by)))) + +(defun for-as-arithmetic-subclause (var type) + (unless (simple-var-p var) (loop-error "Destructuring on a number is invalid.")) + (multiple-value-bind (subtype-p valid-p) (subtypep type 'real) + (when (and (not subtype-p) valid-p) (setq type 'real))) + (let (from to by preposition used candidates bindings) + (loop (setq candidates (or (for-as-arithmetic-possible-prepositions used) + (return))) + (push (or (setq preposition (preposition? candidates)) (return)) + used) + (let ((value-form (form1))) + (if (member preposition '(:from :downfrom :upfrom)) + (progn (setq from value-form) + (appendf bindings `((,type ,var ,from)))) + (progn (when (not (constantp value-form *environment*)) + (let ((temp (gensym))) + (appendf bindings `((number ,temp ,value-form))) + (setq value-form temp))) + (ecase preposition + ((:to :downto :upto :below :above) (setq to value-form)) + (:by (setq by value-form))))))) + (unless (intersection used '(:from :downfrom :upfrom)) + (appendf bindings `((,type ,var ,(zero type))))) + (multiple-value-bind (step test) (for-as-arithmetic-step-and-test-functions used) + (let ((tests (when test `((,test ,var ,to))))) + (for-as-fill-in :bindings bindings + :head-tests tests + :tail-psetq `(,var (,step ,var ,(or by (one type)))) + :tail-tests tests))))) + + +(defun cl-external-p (symbol) + (multiple-value-bind (cl-symbol status) + (find-symbol (symbol-name symbol) "CL") + (and (eq symbol cl-symbol) (eq status :external)))) + +(defun constant-function-p (form) + (let ((expansion (macroexpand form *environment*))) + (and (consp expansion) + (eq (first expansion) 'function) + (symbolp (second expansion)) + (let ((symbol (second expansion))) + (and (cl-external-p symbol) (fboundp symbol)))))) + +(defvar *list-end-test* 'atom) +(defun by-step-fun () (if (preposition? :by) (form1) '#'cdr)) + +(defun for-as-on-list-subclause (var type) + (preposition1 :on) + ;; Check with atom. See 6.1.2.1.3 The for-as-on-list subclause. + ;; http://www.lispworks.com/reference/HyperSpec/Body/06_abac.htm + (let* ((form (form1)) + (by-step-fun (by-step-fun)) + (test *list-end-test*) + (list-var (if (simple-var-p var) var (gensym "LIST-"))) + (list-type (if (simple-var-p var) type t)) + (at-least-one-iteration-p (and (quoted-form-p form) + (not (funcall test (quoted-object form)))))) + (for-as-fill-in :bindings `((,list-type ,list-var ,form) + ,@(unless (constant-function-p by-step-fun) + (let ((temp (gensym "STEPPER-"))) + (prog1 `((t ,temp ,by-step-fun)) + (setq by-step-fun temp))))) + :head-tests (unless at-least-one-iteration-p + `((,test ,list-var))) + :tail-psetq `(,list-var (funcall ,by-step-fun ,list-var)) + :tail-tests `((,test ,list-var))) + (unless (simple-var-p var) + (along-with var type :equals (if at-least-one-iteration-p form list-var) + :then list-var)))) + +(defun for-as-in-list-subclause (var type) + (preposition1 :in) + ;; Check with endp. See 6.1.2.1.2 The for-as-in-list subclause. + ;; http://www.lispworks.com/reference/HyperSpec/Body/06_abab.htm + (let ((*list-end-test* 'endp)) + (for `(,var) `(,type) :on (form1) :by (by-step-fun)))) + +(defun constant-vector-p (form) (or (quoted-form-p form) (vectorp form))) +(defun constant-vector (form) + (cond + ((quoted-form-p form) (quoted-object form)) + ((vectorp form) form) + (t (error "~S is not a vector form." form)))) + +(defun for-as-across-subclause (var type) + (preposition1 :across) + (let* ((form (form1)) + (vector (if (constant-vector-p form) form (gensym "VECTOR-"))) + (length (if (constant-vector-p form) + (length (constant-vector form)) + (gensym "LENGTH-"))) + (i (gensym "INDEX-")) + (at-least-one-iteration-p (and (constant-vector-p form) (plusp length)))) + (unless (constant-vector-p form) + (for-as-fill-in :bindings `((t ,vector ,form)) + :bindings2 `((fixnum ,length (length ,vector))))) + (for-as-fill-in :bindings `((fixnum ,i 0)) + :head-tests (unless at-least-one-iteration-p `((= ,i ,length))) + :tail-psetq `(,i (1+ ,i)) + :tail-tests `((= ,i ,length))) + (along-with var type :equals (if at-least-one-iteration-p + `',(aref (constant-vector form) 0) + `(aref ,vector ,i)) + :then `(aref ,vector ,i)))) + +(defun using-other-var (kind) + (let ((using-phrase (when (preposition? :using) (pop *loop-tokens*))) + (other-key-name (if (find kind '(:hash-key :hash-keys)) + "HASH-VALUE" + "HASH-KEY"))) + (when using-phrase + (destructuring-bind (other-key other-var) using-phrase + (unless (string= other-key other-key-name) + (loop-error "Keyword ~A is missing." other-key-name)) + other-var)))) + +(defun hash-d-var-spec (returned-p var other-var kind) + (if (find kind '(:hash-key :hash-keys)) + `(,returned-p ,var ,other-var) + `(,returned-p ,other-var ,var))) + +(defun for-as-hash-subclause (var type kind) + (let* ((hash-table (progn (preposition1 '(:in :of)) (form1))) + (other-var (using-other-var kind)) + (for-as-parallel-p (for-as-parallel-p)) + (returned-p (or (pop *temporaries*) (gensym-ignorable))) + (iterator (gensym)) + narrow-typed-var narrow-type) + (when (and (simple-var-p var) (not (typep 'nil type))) + (setq narrow-typed-var var + narrow-type type) + (setq var (gensym) + type `(or null ,type)) + (for-as-fill-in :bindings `(,(default-binding narrow-type narrow-typed-var)))) + (flet ((iterator-form () `(with-hash-table-iterator (,iterator ,hash-table)))) + (if for-as-parallel-p + (progn (unless (constantp hash-table *environment*) + (let ((temp (gensym "HASH-TABLE-"))) + (for-as-fill-in :bindings `((t ,temp ,hash-table))) + (setq hash-table temp))) + (fill-in :iterator-forms `(,(iterator-form)))) + (fill-in :binding-forms `(,(iterator-form))))) + (let* ((d-var-spec (hash-d-var-spec returned-p var other-var kind)) + (d-mv-setq (destructuring-multiple-value-setq d-var-spec `(,iterator) + :iterator-p t)) + (setters `(,d-mv-setq + ,@(when narrow-typed-var `((setq ,narrow-typed-var ,var)))))) + (push returned-p *temporaries*) + (for-as-fill-in :bindings `(,@(bindings type var) + ,@(when other-var (bindings t other-var))) + :after-head setters + :after-tail setters)))) + + + +(defun for-as-package-subclause (var type kind) + (let* ((package (if (preposition? '(:in :of)) (form1) '*package*)) + (for-as-parallel-p (for-as-parallel-p)) + (returned-p (or (pop *temporaries*) (gensym-ignorable))) + (iterator (gensym)) + (kinds (ecase kind + ((:symbol :symbols) '(:internal :external :inherited)) + ((:present-symbol :present-symbols) '(:internal :external)) + ((:external-symbol :external-symbols) '(:external))))) + (unless (typep 'nil type) (setq type `(or null ,type))) + (flet ((iterator-form () `(with-package-iterator (,iterator ,package ,@kinds)))) + (if for-as-parallel-p + (progn (unless (constantp package *environment*) + (let ((temp (gensym "PACKAGE-"))) + (for-as-fill-in :bindings `((t ,temp ,package))) + (setq package temp))) + (fill-in :iterator-forms `(,(iterator-form)))) + (fill-in :binding-forms `(,(iterator-form))))) + (let* ((d-var-spec `(,returned-p ,var)) + (d-mv-setq (destructuring-multiple-value-setq d-var-spec `(,iterator) + :iterator-p t))) + (push returned-p *temporaries*) + (for-as-fill-in :bindings (bindings type var) + :after-head `(,d-mv-setq) + :after-tail `(,d-mv-setq))))) + +(defun for-as-being-subclause (var type) + (preposition1 :being) + (preposition1 '(:each :the)) + (let* ((kind (preposition1 (append *hash-group* *symbol-group*)))) + (cond + ((find kind *hash-group*) (for-as-hash-subclause var type kind)) + ((find kind *symbol-group*) (for-as-package-subclause var type kind)) + (t (loop-error "Internal logic error"))))) + +(defun form-or-it () + (if (and *it-visible-p* (preposition? :it)) + (or *it-symbol* (setq *it-symbol* (gensym))) + (form1))) + +(defun enumerate (items) + (case (length items) + (1 (format nil "~S" (first items))) + (2 (format nil "~S and ~S" (first items) (second items))) + (t (format nil "~{~S, ~}and ~S" (butlast items) (first (last items)))))) + +(defun invalid-accumulator-combination-error (keys) + (loop-error "Accumulator ~S cannot be mixed with ~S." + *current-keyword* (enumerate keys))) + +(defun accumulator-kind (key) + (ecase key + ((:collect :collecting :append :appending :nconc :nconcing) :list) + ((:sum :summing :count :counting) :total) + ((:maximize :maximizing :minimize :minimizing) :limit))) + +(defun accumulator-spec (name) + (let* ((kind (accumulator-kind *current-keyword*)) + (spec (assoc name *accumulators*)) + (plist (cdr spec))) + (if spec + (if (not (eq kind (getf plist :kind))) + (invalid-accumulator-combination-error (reverse (getf plist :keys))) + (progn + (pushnew *current-keyword* (getf plist :keys)) + (when (member kind '(:total :limit)) + (multiple-value-bind (type supplied-p) (type-spec?) + (when supplied-p (push type (getf plist :types))))))) + (let ((var (or name (gensym "ACCUMULATOR-")))) + (setq plist `(:var ,var :kind ,kind :keys (,*current-keyword*))) + (ecase kind + (:list (setf (getf plist :splice) (gensym "SPLICE-")) + (unless name (fill-in :results `((cdr ,var))))) + ((:total :limit) + (multiple-value-bind (type supplied-p) (type-spec?) + (when supplied-p (push type (getf plist :types)))) + (when (eq kind :limit) + (let ((first-p (gensym "FIRST-P-"))) + (setf (getf plist :first-p) first-p) + (with first-p t := t))) + (unless name (fill-in :results `(,var))))) + (push (setq spec `(,name ,@plist)) *accumulators*))) + spec)) + +(defun ambiguous-loop-result-error () + (error 'simple-program-error + :format-control + (append-context "~S cannot be used without `into' preposition with ~S") + :format-arguments `(,*anonymous-accumulator* ,*boolean-terminator*))) + +(defun accumulate-in-list (form accumulator-spec) + (destructuring-bind (name &key var splice &allow-other-keys) accumulator-spec + (declare (ignore name)) + (let* ((copy-f (ecase *current-keyword* + ((:collect :collecting) 'list) + ((:append :appending) 'copy-list) + ((:nconc :nconcing) 'identity))) + (collecting-p (member *current-keyword* '(:collect :collecting))) + (last-f (if collecting-p 'cdr 'last)) + (splicing-form (if collecting-p + `(rplacd ,splice (setq ,splice (list ,form))) + `(setf (cdr ,splice) (,copy-f ,form) + ,splice (,last-f ,splice))))) + (if (globally-special-p var) + (lp :do `(if ,splice + ,splicing-form + (setq ,splice (,last-f (setq ,var (,copy-f ,form)))))) + (lp :do splicing-form))))) + +(defun accumulation-clause () + (let* ((form (form-or-it)) + (name (if (preposition? :into) + (simple-var1) + (progn + (setq *anonymous-accumulator* *current-keyword*) + (when *boolean-terminator* (ambiguous-loop-result-error)) + nil))) + (accumulator-spec (accumulator-spec name))) + (destructuring-bind (name &rest plist &key var &allow-other-keys) + accumulator-spec + (declare (ignore name)) + (ecase *current-keyword* + ((:collect :collecting :append :appending :nconc :nconcing) + (accumulate-in-list form accumulator-spec)) + ((:count :counting) (lp :if form :do `(incf ,var))) + ((:sum :summing) (lp :do `(incf ,var ,form))) + ((:maximize :maximizing :minimize :minimizing) + (let ((first-p (getf plist :first-p)) + (fun (if (member *current-keyword* '(:maximize :maximizing)) '< '>))) + (lp :do `(let ((value ,form)) + (cond + (,first-p (setq ,first-p nil ,var value)) + ((,fun ,var value) (setq ,var value))))))))))) + +(defun return-clause () (lp :do `(return-from ,*loop-name* ,(form-or-it)))) + + +(defun do-clause () (fill-in :body (compound-forms+))) + +(defun selectable-clause () + (let ((*current-keyword* *current-keyword*) + (*current-clause* *current-clause*)) + (unless (keyword? '(:if :when :unless :do :doing :return :collect :collecting + :append :appending :nconc :nconcing :count :counting + :sum :summing :maximize :maximizing :minimize :minimizing)) + (loop-error "A selectable-clause is missing.")) + (ecase *current-keyword* + ((:if :when :unless) (conditional-clause)) + ((:do :doing) (do-clause)) + ((:return) (return-clause)) + ((:collect :collecting :append :appending :nconc :nconcing :count :counting + :sum :summing :maximize :maximizing :minimize :minimizing) + (accumulation-clause))))) + +(defun conditional-clause () + (let* ((*it-symbol* nil) + (middle (gensym "MIDDLE-")) + (bottom (gensym "BOTTOM-")) + (test-form (if (eq *current-keyword* :unless) `(not ,(form1)) (form1))) + (condition-form `(unless ,test-form (go ,middle)))) + ;; condition-form is destructively modified in the following code for IT. + (lp :do condition-form) + (let ((*it-visible-p* t)) (selectable-clause)) + (loop (unless (preposition? :and) (return)) (selectable-clause)) + (cond + ((preposition? :else) + (lp :do `(go ,bottom)) + (fill-in :body `(,middle)) + (let ((*it-visible-p* t)) (selectable-clause)) + (loop (unless (preposition? :and) (return)) (selectable-clause)) + (fill-in :body `(,bottom))) + (t (fill-in :body `(,middle)))) + (preposition? :end) + (when *it-symbol* + (with *it-symbol*) + (setf (second condition-form) + `(setq ,*it-symbol* ,(second condition-form)))))) + +(defun initially-clause () (fill-in :initially (compound-forms+))) +(defun finally-clause () (fill-in :finally (compound-forms+))) +(defun while-clause () (lp :unless (form1) :do '(loop-finish) :end)) +(defun until-clause () (lp :while `(not ,(form1)))) +(defun repeat-clause () + (let* ((form (form1)) + (type (typecase (if (quoted-form-p form) (quoted-object form) form) + (fixnum 'fixnum) + (t 'real)))) + (lp :for (gensym) :of-type type :downfrom form :to 1))) +(defun always-never-thereis-clause () + (setq *boolean-terminator* *current-keyword*) + (when *anonymous-accumulator* (ambiguous-loop-result-error)) + (ecase *current-keyword* + (:always (lp :unless (form1) :return nil :end) (fill-in :results '(t))) + (:never (lp :always `(not ,(form1)))) + (:thereis (lp :if (form1) :return :it :end) (fill-in :results '(nil))))) + +(defun variable-clause* () + (loop (let ((key (keyword? '(:with :initially :finally :for :as)))) + (if key (clause1) (return))))) + +(defun main-clause* () + (loop + (if (keyword? '(:do :doing :return :if :when :unless :initially :finally + :while :until :repeat :always :never :thereis + :collect :collecting :append :appending :nconc :nconcing + :count :counting :sum :summing :maximize :maximizing + :minimize :minimizing)) + (clause1) + (return)))) + +(defun name-clause? () + (when (keyword? :named) + (unless *loop-tokens* (loop-error "A loop name is missing.")) + (let ((name (pop *loop-tokens*))) + (unless (symbolp name) + (loop-error "~S cannot be a loop name which must be a symbol." name)) + (setq *loop-name* name)))) + +(defun bound-variables (binding-form) + (let ((operator (first binding-form)) + (second (second binding-form))) + (ecase operator + ((let let* symbol-macrolet) (mapcar #'first second)) + ((multiple-value-bind) second) + ((with-package-iterator with-hash-table-iterator) `(,(first second)))))) + +(defun check-multiple-bindings (variables) + (mapl #'(lambda (vars) + (when (member (first vars) (rest vars)) + (loop-error 'simple-program-error + :format-control "Variable ~S is bound more than once." + :format-arguments (list (first vars))))) + variables)) + + +(defmacro with-loop-context (tokens &body body) + `(let ((*loop-tokens* ,tokens) + (*loop-name* nil) + (*current-keyword* nil) + (*current-clause* nil) + (*loop-components* nil) + (*temporaries* nil) + (*ignorable* nil) + (*accumulators* nil) + (*anonymous-accumulator* nil) + (*boolean-terminator* nil) + (*message-prefix* "LOOP: ")) + ,@body)) + +(defun with-iterator-forms (iterator-forms form) + (if (null iterator-forms) + form + (destructuring-bind ((iterator-macro spec) . rest) iterator-forms + `(,iterator-macro ,spec + ,(with-iterator-forms rest form))))) + +(defun with-binding-forms (binding-forms form) + (if (null binding-forms) + form + (destructuring-bind (binding-form0 . rest) binding-forms + (append binding-form0 (list (with-binding-forms rest form)))))) + +(defun with-temporaries (temporary-specs form) + (destructuring-bind (temporaries &key ignorable) temporary-specs + (if temporaries + `(let ,temporaries + ,@(when ignorable `((declare (ignorable ,@ignorable)))) + ,form) + form))) + +(defun with-list-accumulator (accumulator-spec form) + (destructuring-bind (name &key var splice &allow-other-keys) accumulator-spec + (let* ((anonymous-p (null name)) + (list-var (if (or anonymous-p (globally-special-p var)) + var + (gensym "LIST-"))) + (value-form (if (and (not anonymous-p) (globally-special-p var)) + nil + '(list nil))) + (form (if (and (not anonymous-p) (not (globally-special-p var))) + `(symbol-macrolet ((,var (cdr ,list-var))) + ,form) + form))) + `(let ((,list-var ,value-form)) + ;;(declare (dynamic-extent ,list-var)) + (declare (type list ,list-var)) + (let ((,splice ,list-var)) + (declare (type list ,splice)) + ,form))))) + +(defun with-numeric-accumulator (accumulator-spec form) + (destructuring-bind (name &key var types &allow-other-keys) accumulator-spec + (labels ((type-eq (a b) (and (subtypep a b) (subtypep b a)))) + (when (null types) (setq types '(number))) + (destructuring-bind (type0 . rest) types + (when (and rest (notevery #'(lambda (type) (type-eq type0 type)) types)) + (warn "Different types ~A are declared for ~A accumulator." + (enumerate types) (or name "the anonymous"))) + (let ((type (if rest `(or ,type0 ,@rest) type0))) + `(let ((,var ,(zero type))) + (declare (type ,type ,var)) + ,form)))))) + +(defun with-accumulators (accumulator-specs form) + (if (null accumulator-specs) + form + (destructuring-bind (spec . rest) accumulator-specs + (ecase (getf (cdr spec) :kind) + (:list + (with-list-accumulator spec (with-accumulators rest form))) + ((:total :limit) + (with-numeric-accumulator spec (with-accumulators rest form))))))) + +(defun reduce-redundant-code () + (when (null (getf *loop-components* :initially)) + (let ((rhead (reverse (getf *loop-components* :head))) + (rtail (reverse (getf *loop-components* :tail))) + (neck nil)) + (loop + (when (or (null rhead) (null rtail) (not (equal (car rhead) (car rtail)))) + (return)) + (push (pop rhead) neck) + (pop rtail)) + (setf (getf *loop-components* :head) (nreverse rhead) + (getf *loop-components* :neck) neck + (getf *loop-components* :tail) (nreverse rtail))))) + +(defmacro extended-loop (&rest tokens &environment environment) + (let ((*environment* environment)) + (with-loop-context tokens + (let ((body-tag (gensym "LOOP-BODY-")) + (epilogue-tag (gensym "LOOP-EPILOGUE-"))) + (name-clause?) + (variable-clause*) + (main-clause*) + (when *loop-tokens* + (error "Loop form tail ~S remained unprocessed." *loop-tokens*)) + (reduce-redundant-code) + (destructuring-bind (&key binding-forms iterator-forms initially + head neck body tail finally results) + *loop-components* + (check-multiple-bindings + (append *temporaries* (mapappend #'bound-variables binding-forms) + (mapcar #'(lambda (spec) (getf (cdr spec) :var)) *accumulators*))) + `(block ,*loop-name* + ,(with-temporaries `(,*temporaries* :ignorable ,*ignorable*) + (with-accumulators *accumulators* + (with-binding-forms binding-forms + (with-iterator-forms iterator-forms + `(macrolet ((loop-finish () '(go ,epilogue-tag))) + (tagbody + ,@head + ,@initially + ,body-tag + ,@neck + ,@body + ,@tail + (go ,body-tag) + ,epilogue-tag + ,@finally + ,@(when results + `((return-from ,*loop-name* ,(car results)))))))))))))))) + +(defmacro simple-loop (&rest compound-forms) + (let ((top (gensym))) + `(block nil + (tagbody + ,top + ,@compound-forms + (go ,top))))) + +(defmacro loop (&rest forms) + (if (every #'consp forms) + `(simple-loop ,@forms) + `(extended-loop ,@forms))) + + diff --git a/Sacla/package.lisp b/Sacla/package.lisp new file mode 100644 index 0000000..09e4efc --- /dev/null +++ b/Sacla/package.lisp @@ -0,0 +1,633 @@ +;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp> +;; ALL RIGHTS RESERVED. +;; +;; $Id: package.lisp,v 1.21 2004/09/02 06:59:43 yuji Exp $ +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; * Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; * Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(defstruct (package + (:constructor %make-package) + (:print-object print-package) + (:predicate packagep)) + "" + (%name nil :type (or string null)) + (%nicknames nil :type list) + (%shadowing-symbols nil :type list) + (%use-list nil :type list) + (%used-by-list nil :type list) + (internal-symbols (make-hash-table :test 'equal) :type hash-table) + (external-symbols (make-hash-table :test 'equal) :type hash-table)) + +(defun print-package (package stream) + (format stream "#<~A package (sumire)>" (package-%name package))) + +(defvar *keyword-package* (%make-package :%name "KEYWORD" :%nicknames '()) + "") + +(defvar *cl-package* (%make-package :%name "COMMON-LISP" :%nicknames (list "CL")) + "") + +(defvar *cl-user-package* + (%make-package :%name "COMMON-LISP-USER" :%nicknames (list "CL-USER") + :%use-list (list *cl-package*)) + "") + +(setf (package-%used-by-list *cl-package*) (list *cl-user-package*)) + +(defvar *package* *cl-user-package* + "The current package.") + +(defvar *all-packages* (list *cl-user-package* *cl-package* *keyword-package*) + "") + +(define-condition non-existent-package-name-error (package-error) ()) + +(defun %package (designator) + (or (find-package designator) + (and (typep designator 'package-designator) + (error 'non-existent-package-name-error :package designator)) + (error 'type-error :datum designator :expected-type 'package-designator))) + +(defun %package-list (designator) + (mapcar #'%package (%list designator))) + +(defmacro in-package (name) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (setq *package* (%package ',name)))) + +(defun list-all-packages () + (copy-list *all-packages*)) + +(defun find-registered-package (name) + (block this + (dolist (package *all-packages* nil) + (when (string= name (package-%name package)) + (return-from this package)) + (dolist (nickname (package-%nicknames package)) + (when (string= name nickname) + (return-from this package)))))) + +(defun find-package (name) + (if (packagep name) + name + (find-registered-package (string name)))) + +(defun unuse-package (packages-to-unuse &optional (package *package*)) + (let ((packages-to-unuse (%package-list packages-to-unuse)) + (package (%package package))) + (dolist (unuse packages-to-unuse t) + (setf (package-%use-list package) + (remove unuse (package-%use-list package))) + (setf (package-%used-by-list unuse) + (remove package (package-%used-by-list unuse)))))) + +(defun package-name (package) + (copy-seq (package-%name (%package package)))) + +(defun package-nicknames (package) + (copy-list (package-%nicknames (%package package)))) + +(defun package-shadowing-symbols (package) + (copy-list (package-%shadowing-symbols (%package package)))) + +(defun package-use-list (package) + (copy-list (package-%use-list (%package package)))) + +(defun package-used-by-list (package) + (copy-list (package-%used-by-list (%package package)))) + +(define-condition package-name-error (simple-error) + ((name :type string :reader package-name-error-name :initarg :name)) + (:report (lambda (condition stream) + (format stream "A package named ~S already exists." + (package-name-error-name condition))))) + +(defun rename-package (package new-name &optional new-nicknames) + (let* ((package (%package package)) + (new-name (string new-name)) + (new-nicknames (string-list new-nicknames))) + (dolist (name (cons new-name new-nicknames)) + (let ((found (find-package name))) + (when (and found (not (eq package found))) + (error 'package-name-error :name name)))) + (setf (package-%name package) new-name + (package-%nicknames package) new-nicknames) + package)) + +(defun find-symbol (name &optional (package *package*)) + (let ((name (string name)) + (package (%package package))) + (multiple-value-bind (symbol registered-p) + (gethash name (package-external-symbols package)) + (if registered-p + (values symbol :external) + (multiple-value-bind (symbol registered-p) + (gethash name (package-internal-symbols package)) + (if registered-p + (values symbol :internal) + (dolist (used (package-use-list package) (values nil nil)) + (multiple-value-bind (symbol registered-p) + (gethash name (package-external-symbols used)) + (when registered-p + (return (values symbol :inherited))))))))))) + +(defun find-all-symbols (name) + (let ((name (string name)) + (all-symbols nil)) + (dolist (package (list-all-packages) (remove-duplicates all-symbols)) + (multiple-value-bind (symbol status) (find-symbol name package) + (case status ((:internal :external) (push symbol all-symbols))))))) + +(defun accessible-symbol-p (symbol package) + (multiple-value-bind (symbol-found status) + (find-symbol (symbol-name symbol) package) + (and (eq symbol symbol-found) status))) + +(defun present-symbol-p (symbol package) + (multiple-value-bind (symbol-found status) + (find-symbol (symbol-name symbol) package) + (and (eq symbol-found symbol) (find status '(:internal :external))))) + +(define-condition unintern-would-reveal-name-conflict-error (package-error) + ((symbol :type symbol :reader unintern-error-symbol :initarg :symbol))) + +(defun unintern (symbol &optional (package *package*)) + (flet ((conflicting-inherited-symbols (name package) + (let ((symbols nil)) + (dolist (used-package (package-use-list package)) + (multiple-value-bind (symbol-found foundp) + (gethash name (package-external-symbols used-package)) + (when foundp + (pushnew symbol-found symbols)))) + (if (cdr symbols) symbols nil)))) + (let* ((name (symbol-name symbol)) + (package (%package package)) + (present-p (present-symbol-p symbol package))) + (when present-p + (when (member symbol (package-shadowing-symbols package)) + (when (conflicting-inherited-symbols name package) + (error 'unintern-would-reveal-name-conflict-error + :symbol symbol :package package)) + (setf (package-%shadowing-symbols package) + (remove symbol (package-%shadowing-symbols package)))) + (remhash name (ecase present-p + (:internal (package-internal-symbols package)) + (:external (package-external-symbols package)))) + (when (eq (symbol-package symbol) package) + (setf (symbol-package symbol) nil)) + t)))) + + +(defun shadowing-import (symbol-list-designator &optional (package *package*)) + (let ((symbol-list (symbol-list symbol-list-designator)) + (package (%package package))) + (dolist (symbol symbol-list t) + (let ((name (symbol-name symbol))) + (multiple-value-bind (symbol-found status) (find-symbol name package) + (let ((present-p (member status '(:internal :external)))) + (when (and present-p (not (eq symbol symbol-found))) + (unintern symbol-found package)) + (unless (and present-p (eq symbol symbol-found)) + (setf (gethash name (package-internal-symbols package)) symbol)) + (pushnew symbol (package-%shadowing-symbols package)))))))) + +(define-condition import-would-cause-shadowing-error (package-error) + ((symbol :type symbol :reader import-error-symbol :initarg :symbol))) + +(defun import (symbol-list-designator &optional (package *package*)) + (let ((symbol-list (symbol-list symbol-list-designator)) + (package (%package package))) + (dolist (symbol symbol-list t) + (let ((name (symbol-name symbol))) + (multiple-value-bind (symbol-found status) (find-symbol name package) + (cond + ((and status (not (eq symbol symbol-found))) + (cerror "Import this symbol with shadowing-import." + 'import-would-cause-shadowing-error + :package package :symbol symbol) + (shadowing-import symbol package)) + ((and (member status '(:internal :external)) + (eq symbol symbol-found)) + ;; The spec says `If the symbol is already present + ;; in the importing package, import has no effect.' + ) + (t + (setf (gethash name (package-internal-symbols package)) symbol) + (when (null (symbol-package symbol)) + (setf (symbol-package symbol) package))))))))) + +(define-condition use-package-would-cause-name-conflict-error (package-error) + ((names :type list :reader use-package-error-names :initarg :names) + (package-to-use :type package :reader use-package-error-package-to-use + :initarg :package-to-use))) + +(defun check-use-package-name-conflict (using-package package-to-use) + (let* ((conflicting-names nil) + (shadows (package-shadowing-symbols using-package)) + (user-tables (cons (package-internal-symbols using-package) + (cons (package-external-symbols using-package) + (mapcar #'package-external-symbols + (package-use-list using-package))))) + (fat-user + (> (reduce #'+ user-tables :key #'hash-table-count) + (hash-table-count (package-external-symbols package-to-use)))) + (tables (if fat-user + (list (package-external-symbols package-to-use)) + user-tables)) + (package (if fat-user using-package package-to-use))) + (mapc #'(lambda (table) + (maphash + #'(lambda (name symbol) + (multiple-value-bind (symbol-found status) + (find-symbol name package) + (when (and status + (not (eq symbol symbol-found)) + (not (member name shadows :test #'string=))) + (push name conflicting-names)))) + table)) + tables) + (when conflicting-names + (restart-case (error 'use-package-would-cause-name-conflict-error + :names conflicting-names :package package + :package-to-use package-to-use) + (continue () + :report "Shadowing-import the conflicting symbols." + (shadowing-import (mapcar #'(lambda (name) + (find-symbol name package-to-use)) + conflicting-names) + package)))))) + +(defun use-package (package-to-use-list &optional (package *package*)) + (let ((package-to-use-list (%package-list package-to-use-list)) + (package (%package package))) + (dolist (package-to-use package-to-use-list t) + (cond + ((member package-to-use (package-use-list package))) + ((eq package-to-use *keyword-package*) + (warn "The keyword package cannot be used by other packages.")) + ((eq package-to-use package) + (warn "A package cannot use-package itself.")) + (t (check-use-package-name-conflict package package-to-use) + (push package-to-use (package-%use-list package)) + (push package (package-%used-by-list package-to-use))))))) + +(defun make-package (name &key nicknames use) + (let ((package + (%make-package + :%name (cond + ((not (find-package name)) (string name)) + (t (cerror "Return the existing package." + 'package-name-error :name name) + (return-from make-package (find-package name)))) + :%nicknames (mapcan + #'(lambda (nickname) + (cond + ((string= nickname name) nil) + ((find-package nickname) + (cerror "Don't use this nickname." + 'package-name-error :name nickname)) + (t (list (string nickname))))) + nicknames)))) + (use-package use package) + (pushnew package *all-packages*) + package)) + +(define-condition non-accessible-symbol-error (package-error) + ((symbol :type symbol + :reader non-accessible-symbol-error-symbol :initarg :symbol))) +(define-condition export-would-cause-conflict-in-user-package-error + (package-error) + ((symbol :type symbol :reader export-error-symbol :initarg :symbol) + (user-package :type package + :reader export-error-user-package :initarg :user-package))) + +(defun export (symbol-list-designator &optional (package *package*)) + (let ((symbol-list (symbol-list symbol-list-designator)) + (package (%package package)) + status) + (dolist (symbol symbol-list t) + (loop until (setq status (accessible-symbol-p symbol package)) + do + (cerror "Import this symbol." 'non-accessible-symbol-error + :package package :symbol symbol) + (import (list symbol) package)) + (unless (eq status :external) + (let ((name (symbol-name symbol))) + (dolist (user (package-used-by-list package)) + (loop + (multiple-value-bind (symbol-found status) (find-symbol name user) + (when (or (null status) (eq symbol symbol-found)) + (return)) + (cerror "Shadowing-import the symbol in the user package." + 'export-would-cause-conflict-in-user-package-error + :package package :user-package user :symbol symbol) + (shadowing-import (list symbol) user)))) + (when (eq status :inherited) + (import (list symbol) package)) + (remhash name (package-internal-symbols package)) + (setf (gethash name (package-external-symbols package)) symbol)))))) + +(defun unexport (symbol-list-designator &optional (package *package*)) + (let ((symbol-list (symbol-list symbol-list-designator)) + (package (%package package)) + status) + (dolist (symbol symbol-list t) + (unless (setq status (accessible-symbol-p symbol package)) + (cerror "Import this symbol." 'non-accessible-symbol-error + :package package :symbol symbol)) + (when (eq status :external) + (remhash (symbol-name symbol) (package-external-symbols package)) + (setf (gethash (symbol-name symbol) (package-internal-symbols package)) + symbol))))) + +(defun intern (name &optional (package *package*)) + (let ((name (string name)) + (package (%package package))) + (multiple-value-bind (symbol status) (find-symbol name package) + (if status + (values symbol status) + (let ((symbol (make-symbol name))) + (import (list symbol) package) + (when (eq package *keyword-package*) + (export (list symbol) package) + (setf (symbol-value symbol) symbol)) + (values symbol nil)))))) + +(defun shadow (symbol-names &optional (package *package*)) + (let ((symbol-names (string-list symbol-names)) + (package (%package package))) + (dolist (name symbol-names t) + (multiple-value-bind (symbol status) (find-symbol name package) + (when (or (not status) (eq status :inherited)) + (setq symbol (make-symbol name)) + (setf (symbol-package symbol) package) + (setf (gethash name (package-internal-symbols package)) symbol)) + (pushnew symbol (package-%shadowing-symbols package)))))) + +(defun hash-table-values (table) + (let ((values nil)) + (with-hash-table-iterator (get table) + (loop (multiple-value-bind (more k v) (get) + (declare (ignore k)) + (unless more (return)) + (push v values)))) + values)) + +(defun package-symbol-tables (package type) + (ecase type + (:internal (list (package-internal-symbols package))) + (:external (list (package-external-symbols package))) + (:inherited (mapcar #'package-external-symbols + (package-use-list package))))) + +(define-condition package-symbol-types-error (program-error) + ((types :reader symbol-types-error-types :initarg :types))) + +(defun shadowed-name-p (name package) + (member name (package-shadowing-symbols package) :test #'string=)) + +(defun package-iterator (package &rest symbol-types) + (unless symbol-types (error 'package-symbol-types-error :types symbol-types)) + (unless package (return-from package-iterator (constantly nil))) + (let* ((package-list (%package-list package)) + (package (pop package-list)) + (type (first symbol-types)) + (type-list (rest symbol-types)) + (iterator (hash-table-iterator (package-symbol-tables package type)))) + #'(lambda () + (loop + (multiple-value-bind (more name symbol) (funcall iterator) + (cond + (more + (unless (and (eq type :inherited) (shadowed-name-p name package)) + (return (values more symbol type package)))) + (t + (cond + (type-list (setq type (pop type-list))) + (package-list (setq type (first symbol-types) + type-list (rest symbol-types) + package (pop package-list))) + (t (return nil))) + (setq iterator + (hash-table-iterator (package-symbol-tables package + type)))))))))) + +(defmacro with-package-iterator ((name package-list-form &rest symbol-types) + &body body) + (unless symbol-types (error 'package-symbol-types-error :types symbol-types)) + (let ((iterator (gensym))) + `(let ((,iterator (package-iterator ,package-list-form ,@symbol-types))) + (macrolet ((,name () '(funcall ,iterator))) + ,@body)))) + +(defmacro do-package-symbols ((var package result-form &rest type-list) + &body body) + (let ((get (gensym)) + (more (gensym)) + (type (gensym)) + (pkg (gensym))) + (multiple-value-bind (declarations forms) (declarations-and-forms body) + `(with-package-iterator (,get ,package ,@type-list) + (loop + (multiple-value-bind (,more ,var ,type ,pkg) (,get) + (declare (ignore ,type ,pkg)) + ,@declarations + (unless ,more (return ,result-form)) + (tagbody + ,@forms))))))) + +(defmacro do-symbols ((var &optional (package-form '*package*) + result-form) + &body body) + (let ((package (gensym))) + `(let ((,package (%package ,package-form))) + (do-package-symbols (,var ,package ,result-form + :external :internal :inherited) + ,@body)))) + +(defmacro do-external-symbols ((var &optional (package-form '*package*) + result-form) + &body body) + (let ((package (gensym))) + `(let ((,package (%package ,package-form))) + (do-package-symbols (,var ,package ,result-form :external) + ,@body)))) + +(defmacro do-all-symbols ((var &optional result-form) &body body) + (let ((package (gensym)) + (body-function (gensym))) + (multiple-value-bind (declarations forms) (declarations-and-forms body) + `(block nil + (flet ((,body-function (,var) + (declare (ignorable ,var)) + ,@declarations + (tagbody ,@forms))) + (dolist (,package (list-all-packages) (let ((,var nil)) + (declare (ignorable ,var)) + ,@declarations + ,result-form)) + (do-symbols (,var ,package nil) + (,body-function ,var)))))))) + +(define-condition deleting-package-used-by-others-error (package-error) + ()) + +(defun delete-package (package) + (let ((package (or (find-package package) + (return-from delete-package + (cerror "Return NIL." 'non-existent-package-name-error + :package package))))) + (when (package-name package) + (when (package-used-by-list package) + (cerror "Remove dependency in other packages." + 'deleting-package-used-by-others-error :package package) + (dolist (user (package-used-by-list package)) + (unuse-package package user))) + (unuse-package (package-use-list package) package) + (do-symbols (symbol package) + (unintern symbol package)) + (setf (package-%name package) nil) + (setq *all-packages* (remove package *all-packages*)) + t))) + +(define-condition unsupported-defpackage-option-error (program-error) + ((option :reader unsupported-defpackage-option-error-option :initarg :option))) + +(define-condition non-accessible-symbol-name-error (package-error) + ((name :type string + :reader non-accessible-symbol-name-error-name :initarg :name))) + +(defun %accessible-symbols (name-list package) + (mapcar #'(lambda (name) + (loop + (multiple-value-bind (symbol status) + (find-symbol name package) + (when status + (return symbol)) + (cerror "Intern this symbol." 'non-accessible-symbol-name-error + :package package :name name) + (intern (string name) package)))) + name-list)) + +(defun check-disjoint(&rest args) + ;; An arg is (:key . set) + (do ((list args (cdr list))) + ((endp list)) + (loop + with x = (car list) + for y in (rest list) + for z = (remove-duplicates (intersection (cdr x)(cdr y) :test #'string=)) + when z do (error 'program-error + :format-control "Parameters ~S and ~S must be disjoint ~ + but have common elements ~% ~S" + :format-arguments (list (car x)(car y) z))))) + +(defmacro defpackage (package-name &rest options) + (let ((package-name (string package-name)) + forms nicknames shadow shadowing-import-from use import-from intern + export documentation size) + (loop + for (key . values) in options + do + (case key + (:nicknames (setq nicknames (append nicknames values))) + (:documentation (setq documentation (first values))) + (:shadow (setq shadow (append shadow values))) + (:shadowing-import-from (push values shadowing-import-from)) + (:use (setq use (append use values))) + (:import-from (push values import-from)) + (:intern (setq intern (append intern values))) + (:export (setq export (append export values))) + (:size (setq size (first values))) + (t (error 'unsupported-defpackage-option :option (cons key values))))) + (check-disjoint `(:intern ,@intern) + `(:import-from ,@(apply #'append (mapcar #'rest + import-from))) + `(:shadow ,@shadow) + `(:shadowing-import-from + ,@(apply #'append (mapcar #'rest shadowing-import-from)))) + (check-disjoint `(:intern ,@intern) `(:export ,@export)) + + (push `(let ((package (find-package ,package-name))) + (if package + (rename-package package + ,package-name (union ',(string-list nicknames) + (package-nicknames package) + :test #'string=)) + (make-package ,package-name :nicknames ',nicknames :use nil))) + forms) + (when documentation + (push `(setf (documentation ,package-name 'package) ,documentation) forms)) + (when shadow (push `(shadow ',(string-list shadow) ,package-name) forms)) + (when shadowing-import-from + (loop for (from . names) in shadowing-import-from + do (push `(let ((names ',(string-list names))) + (shadowing-import (%accessible-symbols names ',from) + ,package-name)) + forms))) + (when use (push `(use-package ',use ,package-name) forms)) + (when import-from + (loop for (from . names) in import-from + do (push `(let ((names ',(string-list names))) + (import (%accessible-symbols names ',from) ,package-name)) + forms))) + (when intern + (dolist (symbol intern) + (push `(intern ',symbol ,package-name) forms))) + (when export + (push `(export + (mapcar #'(lambda (name) (intern name ,package-name)) ',export) + ,package-name) + forms)) + (push `(find-package ,package-name) forms) + `(eval-when (:load-toplevel :compile-toplevel :execute) + ,@(nreverse forms)))) + +;;; +(defun clone-package-system () + (let ((src-list (mapcar #'cl:find-package + '("CL" "CL-USER" "KEYWORD" "TESTBED")))) + (dolist (src src-list) + (format t "Cloning the package ~S~%" src) + (let* ((name (cl:package-name src)) + (nicknames (cl:package-nicknames src)) + (dest (or (tb::find-package name) + (tb::make-package name :nicknames nicknames)))) + (cl:with-package-iterator (get src :internal :external) + (loop + (multiple-value-bind (more symbol status package) (get) + (declare (ignore status package)) + (unless more (return)) + ;;(format t "shadowing symbols = ~S~%" (cl:package-shadowing-symbols src)) + (if (member symbol (cl:package-shadowing-symbols src)) + (shadowing-import (list symbol) dest) + (progn + ;;(format t "calling import~%") + (import (list symbol) dest) + ;;(format t "called import~%" + ))))) + (cl:do-external-symbols (symbol src) + (export (list symbol) dest)))) + (setq *package* (find-package (cl:package-name cl:*package*))))) + diff --git a/Sacla/printer.lisp b/Sacla/printer.lisp new file mode 100644 index 0000000..fbdcf27 --- /dev/null +++ b/Sacla/printer.lisp @@ -0,0 +1,582 @@ +;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp> +;; ALL RIGHTS RESERVED. +;; +;; $Id: printer.lisp,v 1.14 2004/03/01 05:18:11 yuji Exp $ +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; * Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; * Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;;; Commentary: + +;; Need to load reader.lisp in advance for the function SYNTAX-TYPE. +;; + +;;; printer control variables +;; number +(defvar *print-base* 10 + "The radix in which the printer will print rationals.") +(defvar *print-radix* nil + "If true, print a radix specifier when printing a rational number.") + +;; symbol +(defvar *print-case* :upcase + "One of the symbols :upcase, :downcase, or :capitalize.") +(defvar *print-gensym* t + "If true, print `#:' before apparently uninterned symbols.") + +;; container +(defvar *print-array* t ; implementation-dependent + "If true, arrays are printed in readable #(...), #*, or #nA(...) syntax.") +(defvar *print-level* nil + "Control how many levels deep a nested object will print.") +(defvar *print-length* nil + "Control how many elements at a given level are printed.") +(defvar *print-circle* nil + "If true, detect circularity and sharing in an object being printed.") + +;; symbol, string +(defvar *print-escape* t + "If false, escape characters and package prefixes are not output.") + +;; readability +;; *print-readably* +;; true +;; true: *print-escape*, *print-array*, and *print-gensym* +;; false: *print-length*, *print-level*, and *print-lines* +(defvar *print-readably* nil + "If true, print objects readably.") + +;; layout +(defvar *print-pretty* t ; implementation-dependent + "If true, the pretty printer is used when printing.") +;;(defvar *print-pprint-dispatch* +;; ) +(defvar *print-lines* nil + "Limit on the number of output lines produced when pretty printing.") +(defvar *print-miser-width* nil ; implementation-dependent + "Switch to a compact style of output whenever the width available for printing a substructure is less than or equal to this many ems when pretty printing.") +(defvar *print-right-margin* nil + "Specify the right margin to use when the pretty printer is making layout decisions.") + +(defmacro with-standard-io-syntax (&rest forms) + "Bind all reader/printer control vars to the standard values then eval FORMS." + `(let ((*package* (find-package "CL-USER")) + (*print-array* t) + (*print-base* 10) + (*print-case* :upcase) + (*print-circle* nil) + (*print-escape* t) + (*print-gensym* t) + (*print-length* nil) + (*print-level* nil) + (*print-lines* nil) + (*print-miser-width* nil) + ;;(*print-pprint-dispatch* *standard-print-pprint-dispatch*) + (*print-pretty* nil) + (*print-radix* nil) + (*print-readably* t) + (*print-right-margin* nil) + (*read-base* 10) + (*read-default-float-format* 'single-float) + (*read-eval* t) + (*read-suppress* nil) + (*readtable* (copy-readtable nil))) + ,@forms)) + +(defgeneric print-object (object stream)) + +(defun write (object &key + ((:array *print-array*) *print-array*) + ((:base *print-base*) *print-base*) + ((:case *print-case*) *print-case*) + ((:circle *print-circle*) *print-circle*) + ((:escape *print-escape*) *print-escape*) + ((:gensym *print-gensym*) *print-gensym*) + ((:length *print-length*) *print-length*) + ((:level *print-level*) *print-level*) + ((:lines *print-lines*) *print-lines*) + ((:miser-width *print-miser-width*) *print-miser-width*) + ((:pprint-dispatch *print-pprint-dispatch*) + *print-pprint-dispatch*) + ((:pretty *print-pretty*) *print-pretty*) + ((:radix *print-radix*) *print-radix*) + ((:readably *print-readably*) *print-readably*) + ((:right-margin *print-right-margin*) *print-right-margin*) + (stream *standard-output*)) + ;; http://www.lispworks.com/reference/HyperSpec/Body/22_ab.htm + ;; 22.1.2 Printer Dispatching + ;; The Lisp printer makes its determination of how to print an object as + ;; follows: If the value of *print-pretty* is true, printing is controlled + ;; by the current pprint dispatch table; see Section 22.2.1.4 (Pretty Print + ;; Dispatch Tables). + ;; Otherwise (if the value of *print-pretty* is false), the object's + ;; print-object method is used; + ;; see Section 22.1.3 (Default Print-Object Methods). + (if *print-pretty* + (print-object-prettily object stream) + (print-object object stream)) + object) + +(defun write-to-string (object &key + ((:array *print-array*) *print-array*) + ((:base *print-base*) *print-base*) + ((:case *print-case*) *print-case*) + ((:circle *print-circle*) *print-circle*) + ((:escape *print-escape*) *print-escape*) + ((:gensym *print-gensym*) *print-gensym*) + ((:length *print-length*) *print-length*) + ((:level *print-level*) *print-level*) + ((:lines *print-lines*) *print-lines*) + ((:miser-width *print-miser-width*) *print-miser-width*) + ((:pprint-dispatch *print-pprint-dispatch*) + *print-pprint-dispatch*) + ((:pretty *print-pretty*) *print-pretty*) + ((:radix *print-radix*) *print-radix*) + ((:readably *print-readably*) *print-readably*) + ((:right-margin *print-right-margin*) *print-right-margin*)) + (with-output-to-string (stream) + (if *print-pretty* + (print-object-prettily object stream) + (print-object object stream)))) + +(defun prin1 (object &optional output-stream) + (write object :stream output-stream :escape t)) + +(defun prin1-to-string (object) (write-to-string object :escape t)) + +(defun princ (object &optional output-stream) + (write object :stream output-stream :escape nil :readably nil)) + +(defun princ-to-string (object) + (write-to-string object :escape nil :readably nil)) + +(defun print (object &optional output-stream) + (terpri output-stream) + (prin1 object output-stream) + (write-char #\Space output-stream) + object) + +(defun pprint (object &optional output-stream) + (terpri output-stream) + (write object :stream output-stream :pretty t :escape t) + (values)) + + +;; function pprint-dispatch +;; macro pprint-logical-block +;; local macro pprint-pop +;; local macro pprint-exit-if-list-exhausted +;; function pprint-newline +;; function pprint-tab +;; function pprint-fill, pprint-linear, pprint-tabular +;; function pprint-indent + +(defun printer-escaping-enabled-p () (or *print-escape* *print-readably*)) + +(defmethod print-object ((object integer) stream) (print-integer object stream)) +(defun print-integer (integer stream) + (let ((chars "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ") + digits) + (loop with n = (abs integer) + do (multiple-value-bind (q r) (floor n *print-base*) + (push (char chars r) digits) + (setq n q)) + until (zerop n)) + (when *print-radix* + (case *print-base* + (2 (write-string "#b" stream)) + (8 (write-string "#o" stream)) + (16 (write-string "#x" stream)) + (10 nil) + (t (write-char #\# stream) + (let ((base *print-base*) + (*print-base* 10) + (*print-radix* nil)) + (print-integer base stream)) + (write-char #\r stream)))) + (write-string (concatenate 'string + (when (minusp integer) '(#\-)) + digits + (when (and *print-radix* (= *print-base* 10)) + ".")) + stream) + integer)) + +(defmethod print-object ((ratio ratio) stream) + ;; http://www.lispworks.com/reference/HyperSpec/Body/v_pr_bas.htm + ;; For integers, base ten is indicated by a trailing decimal point instead + ;; of a leading radix specifier; for ratios, #10r is used. + (if (and *print-radix* (= *print-base* 10)) + (progn + (write-string "#10r" stream) + (let ((*print-radix* nil)) + (print-integer (numerator ratio) stream))) + (print-integer (numerator ratio) stream)) + (write-char #\/ stream) + (let ((*print-radix* nil)) (print-integer (denominator ratio) stream)) + ratio) + +(defmethod print-object ((complex complex) stream) + (write-string "#C(" stream) + (print-object (realpart complex) stream) + (write-char #\Space stream) + (print-object (imagpart complex) stream) + (write-char #\)) + complex) + + +(defmethod print-object ((character character) stream) + (cond + ((printer-escaping-enabled-p) + (write-string "#\\" stream) + (if (and (graphic-char-p character) (not (char= character #\Space))) + (write-char character stream) + (write-string (char-name character) stream))) + (t (write-char character stream))) + character) + +(defun string-invert (str) + (cond + ((every #'(lambda (c) (or (not (alpha-char-p c)) (upper-case-p c))) str) + (map 'string #'char-downcase str)) + ((every #'(lambda (c) (or (not (alpha-char-p c)) (lower-case-p c))) str) + (map 'string #'char-upcase str)) + (t str))) + +(defun make-str (chars) + (make-array (length chars) :element-type 'character :initial-contents chars)) + +(defun print-symbol-as-is (symbol stream) + (let ((name (symbol-name symbol))) + (ecase (readtable-case *readtable*) + (:upcase + (write-string + (ecase *print-case* + (:upcase name) + (:downcase (map 'string #'char-downcase name)) + (:capitalize + (make-str (loop for c across name and prev = nil then c + collecting + (if (and (upper-case-p c) prev (alpha-char-p prev)) + (char-downcase c) + c))))) + stream)) + (:downcase + (write-string + (ecase *print-case* + (:upcase (map 'string #'char-upcase name)) + (:downcase name) + (:capitalize + (make-str (loop for c across name and prev = nil then c + collecting + (if (and (lower-case-p c) + (or (null prev) (not (alpha-char-p prev)))) + (char-upcase c) + c))))) + stream)) + (:preserve (write-string name stream)) + (:invert (write-string (string-invert name) stream))) + symbol)) + +(defun print-name-escaping (name stream &key force-escaping) + (let ((readtable-case (readtable-case *readtable*))) + (if (or force-escaping + (loop with standard-table = (copy-readtable nil) + for c across name + thereis (not (and (eq (syntax-type c standard-table) :constituent) + (eq (syntax-type c) :constituent)))) + (notevery #'graphic-char-p name) + (and (eq readtable-case :upcase) (some 'lower-case-p name)) + (and (eq readtable-case :downcase) (some 'upper-case-p name))) + (let ((escaped (loop for c across name + if (find c '(#\\ #\|)) append (list #\\ c) + else collect c))) + (write-string (concatenate 'string "|" escaped "|") stream)) + (write-string (case readtable-case + ((:upcase :downcase) + (ecase *print-case* + (:upcase (string-upcase name)) + (:downcase (string-downcase name)) + (:capitalize (string-capitalize name)))) + (:invert + (cond + ((notany #'both-case-p name) name) + ((notany #'upper-case-p name) (string-upcase name)) + ((notany #'lower-case-p name) (string-downcase name)) + (t name))) + (t name)) + stream)))) + +(defun print-symbol-escaping (symbol stream) + (let* ((name (symbol-name symbol)) + (accessible-p (eq symbol (find-symbol name)))) + (cond + (accessible-p nil) + ((symbol-package symbol) + (let ((package-name (package-name (symbol-package symbol)))) + (unless (string= package-name "KEYWORD") + (print-name-escaping package-name stream)) + (multiple-value-bind (symbol status) (find-symbol name package-name) + (declare (ignore symbol)) + (write-string (if (eq status :external) ":" "::") stream)))) + ((or *print-readably* *print-gensym*) (write-string "#:" stream)) + (t nil)) + (print-name-escaping + name stream + :force-escaping (and accessible-p + (every #'(lambda (c) (digit-char-p c *print-base*)) + name))) + symbol)) + +(defmethod print-object ((symbol symbol) stream) + (funcall (if (printer-escaping-enabled-p) + #'print-symbol-escaping + #'print-symbol-as-is) + symbol + stream)) + + +(defvar *shared-object-table* (make-hash-table)) +(defvar *shared-object-label* (make-hash-table)) +(defvar *shared-object-label-counter* 0) +(defvar *current-print-level* 0) + +(defun print-max-level-p () + (and (not *print-readably*) + *print-level* + (= *current-print-level* *print-level*))) +(defun print-max-length-p (n) + (and (not *print-readably*) *print-length* (= n *print-length*))) + +(defun inc-shared-object-reference (object) + (if (and (symbolp object) (symbol-package object)) + 0 + (multiple-value-bind (n present-p) (gethash object *shared-object-table*) + (if present-p + (progn (when (zerop n) + (setf (gethash object *shared-object-label*) + (incf *shared-object-label-counter*))) + (incf (gethash object *shared-object-table*))) + (setf (gethash object *shared-object-table*) 0))))) + +(defmethod search-shared-object :around ((object t)) + (if (zerop *current-print-level*) + (progn (setq *shared-object-label* (clrhash *shared-object-label*) + *shared-object-table* (clrhash *shared-object-table*) + *shared-object-label-counter* 0) + (inc-shared-object-reference object) + (call-next-method object) + (maphash #'(lambda (object n) + (if (zerop n) + (remhash object *shared-object-table*) + (setf (gethash object *shared-object-table*) + 0))) + *shared-object-table*)) + (when (zerop (inc-shared-object-reference object)) + (call-next-method object)))) + +(defun search-shared-element (object) + (let ((*current-print-level* (1+ *current-print-level*))) + (unless (print-max-level-p) (search-shared-object object)))) + +(defmethod search-shared-object ((object t))) ; do nothing +(defmethod search-shared-object ((list list)) + (do ((x list) + (l 0 (1+ l))) + ((or (print-max-level-p) (print-max-length-p l) (atom x))) + (search-shared-element (car x)) + (setq x (cdr x)) + (when (plusp (inc-shared-object-reference x)) + (return)))) + +(defmethod search-shared-object ((vector vector)) + (do ((i 0 (1+ i))) + ((or (= i (length vector)) (print-max-level-p) (print-max-length-p i))) + (search-shared-element (aref vector i)))) + +(defmethod search-shared-object ((array array)) + (do ((i 0 (1+ i))) + ((or (= i (array-total-size array)) + (print-max-level-p) (print-max-length-p i))) + (search-shared-element (row-major-aref array i)))) + +(defun print-element (object stream) + (let ((*current-print-level* (1+ *current-print-level*))) + (multiple-value-bind (n present-p) (gethash object *shared-object-table*) + (if (and present-p *print-circle*) + (if (zerop n) + (progn + (print-label object stream) + (print-object object stream)) + (print-reference object stream)) + (print-object object stream))))) + +(defun print-label (object stream) + (multiple-value-bind (n present-p) (gethash object *shared-object-label*) + (assert present-p) + (write-string "#" stream) + (let ((*print-base* 10) (*print-radix* nil)) (print-integer n stream)) + (write-string "=" stream) + (incf (gethash object *shared-object-table*)))) + +(defun print-reference (object stream) + (multiple-value-bind (n present-p) (gethash object *shared-object-label*) + (assert present-p) + (write-string "#" stream) + (let ((*print-base* 10) (*print-radix* nil)) (print-integer n stream)) + (write-string "#" stream))) + +(defmethod print-object ((list cons) stream) + (when (and *print-circle* (zerop *current-print-level*)) + (search-shared-object list)) + (if (print-max-level-p) + (write-string "#" stream) + (let ((x list) + (l 0)) + (multiple-value-bind (n present-p) (gethash x *shared-object-table*) + (when (and (zerop *current-print-level*) present-p *print-circle*) + (print-label x stream)) + (write-string "(" stream) + (loop (when (atom x) + (when x + (write-string " . " stream) + (print-element x stream)) + (write-string ")" stream) + (return)) + (when (print-max-length-p l) + (write-string "...)" stream) + (return)) + (print-element (car x) stream) + (setq x (cdr x) + l (1+ l)) + (when (consp x) + (write-string " " stream) + (multiple-value-setq (n present-p) + (gethash x *shared-object-table*)) + (when (and present-p *print-circle*) + (write-string ". " stream) + (if (zerop n) + (print-element x stream) + (print-reference x stream)) + (write-string ")" stream) + (return)))))))) + +(defmethod print-object :around ((array array) stream) + (cond + ((and (not *print-readably*) (not *print-array*) (not (stringp array))) + ;; 22.1.3.4 Printing Strings + ;; http://www.lispworks.com/reference/HyperSpec/Body/22_acd.htm + ;; The printing of strings is not affected by *print-array*. + (print-unreadable-object (array stream :type t :identity t))) + ((and (print-max-level-p) (not (stringp array)) (not (bit-vector-p array))) + ;; Variable *PRINT-LEVEL*, *PRINT-LENGTH* + ;; http://www.lispworks.com/reference/HyperSpec/Body/v_pr_lev.htm + ;; *print-level* and *print-length* affect the printing of + ;; an any object printed with a list-like syntax. They do not affect + ;; the printing of symbols, strings, and bit vectors. + (write-string "#" stream)) + (t (when (and *print-circle* (zerop *current-print-level*) + (not (stringp array)) (not (bit-vector-p array))) + (search-shared-object array) + (multiple-value-bind (n present-p) + (gethash array *shared-object-table*) + (declare (ignore n)) + (when present-p (print-label array stream)))) + (call-next-method array stream)))) + +(defmethod print-object ((vector vector) stream) + (let ((l 0) + (length (length vector))) + (write-string "#(" stream) + (loop (when (= l length) + (write-string ")" stream) + (return)) + (when (print-max-length-p l) + (write-string "...)" stream) + (return)) + (print-element (aref vector l) stream) + (setq l (1+ l)) + (when (< l length) (write-string " " stream))))) + +(defmethod print-object ((array array) stream) + (let* ((dimensions (array-dimensions array)) + (indices (make-list (array-rank array) :initial-element 0))) + (labels + ((p-array (i-list d-list) + (cond + ((print-max-level-p) (write-string "#" stream)) + ((null i-list) (print-element (apply #'aref array indices) stream)) + (t (write-string "(" stream) + (do ((i 0 (1+ i))) + ((= i (car d-list))) + (when (plusp i) (write-string " " stream)) + (when (print-max-length-p i) + (write-string "..." stream) + (return)) + (setf (car i-list) i) + (if (null (cdr i-list)) + (print-element (apply #'aref array indices) stream) + (let ((*current-print-level* (1+ *current-print-level*))) + (p-array (cdr i-list) (cdr d-list))))) + (write-string ")" stream))))) + (write-string "#" stream) + (let ((*print-base* 10) (*print-radix* nil)) + (print-integer (array-rank array) stream)) + (write-string "A" stream) + (p-array indices dimensions)))) + +(defmethod print-object ((string string) stream) + (let ((escape-p (printer-escaping-enabled-p))) + (when escape-p (write-char #\" stream)) + (loop for c across string + if (and escape-p (member c '(#\" #\\))) do (write-char #\\ stream) + do (write-char c stream)) + (when escape-p (write-char #\" stream)) + string)) + +(defmethod print-object ((bit-vector bit-vector) stream) + (if (or *print-array* *print-readably*) + (progn + (write-string "#*" stream) + (loop for bit across bit-vector + do (write-char (if (zerop bit) #\0 #\1) stream))) + (print-unreadable-object (bit-vector stream :type t :identity t))) + bit-vector) + +(defmethod print-object ((object t) stream) + (print-unreadable-object (object stream :type t :identity t))) + +(defun print-object-prettily (object stream) + (print-object object stream)) + + + +;; format +;; (defun format (destination format-control &rest args) +;; (apply (if (stringp format-control) (formatter format-control) format-control) +;; destination args)) +;; +;; +;; (defmacro formatter (control-string) +;; +;; ) diff --git a/Sacla/reader.lisp b/Sacla/reader.lisp new file mode 100644 index 0000000..2c87418 --- /dev/null +++ b/Sacla/reader.lisp @@ -0,0 +1,797 @@ +;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp> +;; ALL RIGHTS RESERVED. +;; +;; $Id: reader.lisp,v 1.13 2004/07/22 06:06:33 yuji Exp $ +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; * Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; * Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + +(defstruct (readtable (:predicate readtablep) (:copier nil)) + "Map characters into syntax types and reader macro functions." + (syntax (make-hash-table) :type hash-table) + (case :upcase :type (member :upcase :downcase :preserve :invert))) + +(defvar *read-base* '10 + "The radix in which integers and ratios are to be read by the Lisp reader.") +(defvar *read-default-float-format* 'single-float + "Used for a floating-point number having no exponent marker or e or E.") +(defvar *read-eval* 't + "If true, the #. reader macro has its normal effect. If false, reader-error.") +(defvar *read-suppress* 'nil + "If true, the reader reads an object and returns a primary value of nil.") +(defvar *readtable* nil + "The current readtable. Control the parsing behavior of the Lisp reader.") + + +(defvar *sharp-equal-alist* nil) +(defvar *sharp-sharp-alist* nil) +(defvar *consing-dot-allowed* nil) +(defvar *consing-dot* (gensym)) +(defvar *preserve-whitespace-p* nil) +(defvar *input-stream* nil) +(defvar *backquote-level* 0) +(defvar *dispatch-macro-char* nil) +(defvar *standard-readtable*) + +(define-condition invalid-character-error (reader-error) + ((character :type character :reader invalid-character-error-character + :initarg :character)) + (:report + (lambda (condition stream) + (format stream "Invalid character ~S is read." + (invalid-character-error-character condition))))) + +(defun reader-error (&optional format-control &rest format-arguments) + (error 'reader-error + :format-control format-control :format-arguments format-arguments)) + +(defun copy-readtable (&optional (from-readtable *readtable*) to-readtable) + "Copy FROM-READTABLE. If TO-READTABLE is nil, a new table is to be created." + (flet ((copy-syntax (src) + (let ((new (make-hash-table))) + (maphash + #'(lambda (k v) + (let ((plist (copy-list v))) + (setf (gethash k new) plist) + (when (getf plist :dispatch-table) + (let ((hash (make-hash-table))) + (maphash #'(lambda (k v) (setf (gethash k hash) v)) + (getf plist :dispatch-table)) + (setf (getf plist :dispatch-table) hash))))) + src) + new))) + (let ((from (or from-readtable *standard-readtable*))) + (if to-readtable + (prog1 to-readtable + (setf (readtable-syntax to-readtable) + (copy-syntax (readtable-syntax from))) + (setf (readtable-case to-readtable) (readtable-case from))) + (make-readtable :syntax (copy-syntax (readtable-syntax from)) + :case (readtable-case from)))))) + +(defun syntax-type (char &optional (readtable *readtable*)) + (let ((plist (gethash char (readtable-syntax readtable)))) + (getf plist :syntax :constituent))) + +(defun get-macro-character (char &optional (readtable *readtable*)) + "Return a macro function for CHAR and non-terminating-p as the secondary value." + (unless readtable (setq readtable *standard-readtable*)) + (let ((plist (gethash char (readtable-syntax readtable)))) + (case (syntax-type char readtable) + (:terminating-macro-char (values (getf plist :macro-function) nil)) + (:non-terminating-macro-char (values (getf plist :macro-function) t)) + (t (values nil nil))))) + +(defun set-macro-character (char new-function + &optional non-terminating-p (readtable *readtable*)) + "Make CHAR a macro character associated with NEW-FUNCTION in READTABLE." + (check-type char character) + (check-type new-function function-designator) + (when (null readtable) + (error "Standard readtable must not be changed.")) + (let ((plist (gethash char (readtable-syntax readtable)))) + (setf (getf plist :syntax) (if non-terminating-p + :non-terminating-macro-char + :terminating-macro-char) + (getf plist :macro-function) new-function + (gethash char (readtable-syntax readtable)) plist)) + t) + +(defun get-dispatch-macro-character (disp-char sub-char + &optional (readtable *readtable*)) + "Retrieve the dispatch function for DISP-CHAR and SUB-CHAR in READTABLE." + (unless readtable (setq readtable *standard-readtable*)) + (unless (eq (get-macro-character disp-char readtable) + 'dispatch-macro-character) + (error "~S is not a dispatching macro character." disp-char)) + (let* ((syntax-table (readtable-syntax readtable)) + (dispatch-table (getf (gethash disp-char syntax-table) + :dispatch-table)) + (sub-char (char-upcase sub-char))) + (multiple-value-bind (value present-p) (gethash sub-char dispatch-table) + (cond + ((digit-char-p sub-char 10) nil) + (present-p value) + (t + #'(lambda (stream sub-char number) + (declare (ignore stream number)) + (reader-error "No dispatch function defined for ~S." + sub-char))))))) + +(defun set-dispatch-macro-character (disp-char sub-char new-function + &optional (readtable *readtable*)) + "Install NEW-FUNCTION as the dispatch function for DISP-CHAR and SUB-CHAR." + (when (null readtable) (error "Standard readtable must not be changed.")) + (unless (eq (get-macro-character disp-char readtable) + 'dispatch-macro-character) + (error "~S is not a dispatch character." disp-char)) + (let* ((syntax-table (readtable-syntax readtable)) + (dispatch-table (getf (gethash disp-char syntax-table) + :dispatch-table)) + (sub-char (char-upcase sub-char))) + (setf (gethash sub-char dispatch-table) new-function) + t)) + +(defun make-dispatch-macro-character (char &optional non-terminating-p + (readtable *readtable*)) + "Make CHAR be a dispatching macro character in READTABLE." + (when (null readtable) (error "Standard readtable must not be changed.")) + (set-macro-character char 'dispatch-macro-character + non-terminating-p readtable) + + (setf (getf (gethash char (readtable-syntax readtable)) :dispatch-table) + (make-hash-table)) + t) + +(defun dispatch-macro-character (stream char) + (let ((n (when (digit-char-p (peek-char nil stream t nil t) 10) + (loop + with n = 0 + for digit = (read-char stream t nil t) + do (setq n (+ (* n 10) (digit-char-p digit 10))) + while (digit-char-p (peek-char nil stream t nil t) 10) + finally (return n)))) + (*dispatch-macro-char* char) + (sub-char (char-upcase (read-char stream t nil t)))) + (funcall (get-dispatch-macro-character char sub-char) stream sub-char n))) + +(defun set-syntax-from-char (to-char from-char + &optional (to-readtable *readtable*) + (from-readtable *standard-readtable*)) + "Make the syntax of TO-CHAR in TO-READTABLE be the same as that of FROM-CHAR." + (check-type to-char character) + (check-type from-char character) + (check-type to-readtable readtable) + (unless from-readtable (setq from-readtable *standard-readtable*)) + (check-type from-readtable readtable) + (let ((plist (copy-list (gethash from-char + (readtable-syntax from-readtable))))) + (when (getf plist :dispatch-table) + (let ((hash (make-hash-table))) + (maphash #'(lambda (k v) (setf (gethash k hash) v)) + (getf plist :dispatch-table)) + (setf (getf plist :dispatch-table) hash))) + (setf (gethash to-char (readtable-syntax to-readtable)) plist) + t)) + +(defun read-preserving-whitespace (&optional (input-stream *standard-input*) + (eof-error-p t) eof-value recursive-p) + "Read an object but preserves any whitespace character after it." + (let ((*preserve-whitespace-p* (if recursive-p *preserve-whitespace-p* t))) + (read-lisp-object input-stream eof-error-p eof-value recursive-p))) + +(defun read (&optional (input-stream *standard-input*) + (eof-error-p t) eof-value recursive-p) + "Parse a printed representation from INPUT-STREAM and return the object." + (let ((*preserve-whitespace-p* (when recursive-p *preserve-whitespace-p*))) + (read-lisp-object input-stream eof-error-p eof-value recursive-p))) + +(defun read-from-string (string &optional (eof-error-p t) eof-value + &key (start 0) end preserve-whitespace) + "Read an object from the subsequence of string bounded by START and END." + (let ((index nil)) + (values (with-input-from-string (stream string :index index + :start start :end end) + (funcall (if preserve-whitespace + #'read-preserving-whitespace + #'read) + stream eof-error-p eof-value)) + index))) + +(defun make-str (chars) + (make-array (length chars) :element-type 'character :initial-contents chars)) + +(defun sharp-equal (stream sub-char n) + (declare (ignore sub-char)) + (if *read-suppress* + (values) + (let* ((this (gensym)) + (object (progn + (setq *sharp-sharp-alist* (acons n this + *sharp-sharp-alist*)) + (read stream t nil t)))) + (when (null n) + (reader-error "Missing label number for #=.")) + (when (assoc this *sharp-equal-alist*) + (reader-error "#~D= is already defined." n)) + (when (eq object this) + (reader-error "need to tag something more than just #~D#." n)) + (setq *sharp-equal-alist* (acons this object *sharp-equal-alist*)) + object))) + +(defun sharp-sharp (stream sub-char n) + (declare (ignore sub-char stream)) + (unless *read-suppress* + (unless n (reader-error "Label is missing for ##.")) + (let ((assoc (assoc n *sharp-sharp-alist*))) + (unless assoc + (reader-error "No object labeled ~D is seen." n)) + (cdr assoc)))) + +(defun read-delimited-list (char &optional (stream *standard-input*) + recursive-p) + "Read objects until CHAR appears, then return a list of objects read." + (let ((list (read-list char stream :allow-consing-dot nil))) + (unless *read-suppress* list))) + +(defun read-list (char &optional (stream *standard-input*) + &key allow-consing-dot) + (let ((*consing-dot-allowed* allow-consing-dot) + c stack values list) + (loop + (setq c (peek-char t stream t nil t)) + (when (char= char c) ; found the closing parenthesis. + (when (eq (first stack) *consing-dot*) + (error "Nothing appears after . in list.")) + (read-char stream t nil t) + (setq list (if (eq (second stack) *consing-dot*) + (nreconc (cddr stack) (first stack)) + (nreverse stack))) + (return)) + (when (setq values (multiple-value-list (lisp-object? stream t nil t))) + (if (eq (second stack) *consing-dot*) + (error "More than one object follows . in list.") + (push (car values) stack)))) + list)) + +(defun lisp-object? (stream eof-error-p eof-value recursive-p) + (loop + (let* ((c (read-char stream eof-error-p eof-value recursive-p))) + (when (and (not eof-error-p) (eq c eof-value)) (return eof-value)) + (ecase (syntax-type c) + (:invalid (error 'invalid-character-error :character c)) + (:whitespace 'skip) + ((:single-escape :multiple-escape :constituent) + (return (read-number-or-symbol stream c))) + ((:terminating-macro-char :non-terminating-macro-char) + (return (funcall (get-macro-character c) stream c))))))) + +(defmethod general-nsublis ((alist list) (object t)) + object) + +(defmethod general-nsublis :around ((alist cons) (object t)) + (let ((assoc (assoc object alist :test #'eq))) + (if assoc + (cdr assoc) + (call-next-method alist object)))) + +(defmethod general-nsublis ((alist cons) (object cons)) + (setf (car object) (general-nsublis alist (car object))) + (setf (cdr object) (general-nsublis alist (cdr object))) + object) + +(defmethod general-nsublis ((alist cons) (object array)) + (do ((i 0 (1+ i))) + ((= i (array-total-size object)) object) + (setf (row-major-aref object i) + (general-nsublis alist (row-major-aref object i))))) + +(defun read-lisp-object (stream eof-error-p eof-value recursive-p) + (unless recursive-p + (setq *sharp-equal-alist* nil + *sharp-sharp-alist* nil)) + (let ((object (loop + (let ((values (multiple-value-list + (lisp-object? stream + eof-error-p eof-value + recursive-p)))) + (when values + (return (unless *read-suppress* (car values)))))))) + (if (and (not recursive-p) *sharp-equal-alist*) + (general-nsublis *sharp-equal-alist* object) + object))) + +(defun read-ch () (read-char *input-stream* nil nil t)) +(defun read-ch-or-die () (read-char *input-stream* t nil t)) +(defun unread-ch (c) (unread-char c *input-stream*)) + +(defun collect-escaped-lexemes (c) + (ecase (syntax-type c) + (:invalid (error 'invalid-character-error :character c)) + (:multiple-escape nil) + (:single-escape (cons (read-ch-or-die) + (collect-escaped-lexemes (read-ch-or-die)))) + ((:constituent + :whitespace :terminating-macro-char :non-terminating-macro-char) + (cons c (collect-escaped-lexemes (read-ch-or-die)))))) + +(defun collect-lexemes (c &optional (stream *input-stream*)) + (let ((*input-stream* stream)) + (when c + (ecase (syntax-type c) + (:invalid (error 'invalid-character-error :character c)) + (:whitespace (when *preserve-whitespace-p* (unread-ch c))) + (:terminating-macro-char (unread-ch c)) + (:multiple-escape (cons (collect-escaped-lexemes (read-ch-or-die)) + (collect-lexemes (read-ch)))) + (:single-escape (cons (list (read-ch-or-die)) + (collect-lexemes (read-ch)))) + ((:constituent :non-terminating-macro-char) + (cons c (collect-lexemes (read-ch)))))))) + +;; integer ::= [sign] decimal-digit+ decimal-point +;; | [sign] digit+ +;; ratio ::= [sign] {digit}+ slash {digit}+ +;; float ::= [sign] {decimal-digit}* decimal-point {decimal-digit}+ [exponent] +;; | [sign] {decimal-digit}+ [decimal-point {decimal-digit}*] exponent +;; exponent::= exponent-marker [sign] {digit}+ + +(defun construct-number (chars) + (labels ((sign () + (let ((c (and chars (car chars)))) + (cond + ((eql c #\-) (pop chars) -1) + ((eql c #\+) (pop chars) +1) + (t +1)))) + (digit* (&optional (base *read-base*)) + (let ((pos (or (position-if-not #'(lambda (d) + (digit-char-p d base)) + chars) + (length chars)))) + (prog1 (subseq chars 0 pos) + (setq chars (subseq chars pos))))) + (int? (sign digits &optional (base *read-base*)) + (when (and digits + (every #'(lambda (d) (digit-char-p d base)) digits)) + (* sign (reduce #'(lambda (a b) (+ (* base a) b)) + (mapcar #'(lambda (d) (digit-char-p d base)) + digits))))) + (float? (sign) + (let* ((int (digit* 10)) + (fraction (when (eql (car chars) #\.) + (pop chars) (digit* 10))) + (exp-marker (when (and chars + (find (char-upcase (car chars)) + '(#\D #\E #\F #\L #\S))) + (char-upcase (pop chars)))) + (exp-sign (and exp-marker (sign))) + (exp-digits (and exp-sign (digit*)))) + (when (and (null chars) + (or fraction (and int exp-marker exp-digits))) + (float (* (int? sign (append int fraction) 10) + (expt 10 (- (or (int? exp-sign exp-digits 10) 0) + (length fraction)))) + (ecase (or exp-marker *read-default-float-format*) + (#\E 1.0e0) + ((#\D double-float) 1.0d0) + ((#\F single-float) 1.0f0) + ((#\L long-float) 1.0l0) + ((#\S short-float) 1.0s0))))))) + (let ((sign (sign)) + pos numerator denominator) + (when chars + (or + ;; [sign] digit+ + (int? sign chars) + ;; [sign] decimal-digit+ decimal-point + (and (eql (car (last chars)) #\.) (int? sign (butlast chars) 10)) + ;; [sign] {digit}+ slash {digit}+ + (and (setq pos (position #\/ chars)) + (setq numerator (int? sign (subseq chars 0 pos))) + (setq denominator (int? 1 (subseq chars (1+ pos)))) + (not (zerop denominator)) + (/ numerator denominator)) + ;; [sign] {decimal-digit}* decimal-point {decimal-digit}+ [exponent] + ;; [sign] {decimal-digit}+ [decimal-point {decimal-digit}*] exponent + (float? sign)))))) + + + +(defun ensure-external-symbol (name package) + (multiple-value-bind (symbol status) (find-symbol name package) + (unless (eq status :external) + (cerror (if (null status) + "Intern and export symbol ~S in package ~S." + "Export symbol ~S in package ~S.") + "There is no external symbol by the name of ~S in package ~S." + name package) + (export (setq symbol (intern name package)) package)) + symbol)) + +(defun construct-symbol (lexemes &key uninterned-symbol-wanted) + (labels ((up (x) (if (listp x) (copy-list x) (list (char-upcase x)))) + (down (x) (if (listp x) (copy-list x) (list (char-downcase x)))) + (chars (lexemes) + (ecase (readtable-case *readtable*) + (:upcase (mapcan #'up lexemes)) + (:downcase (mapcan #'down lexemes)) + (:invert + (let ((unescaped (remove-if-not #'alpha-char-p + (remove-if #'listp lexemes)))) + (mapcan (cond + ((every #'upper-case-p unescaped) #'down) + ((every #'lower-case-p unescaped) #'up) + (t #'(lambda (x) + (if (listp x) (copy-list x) (list x))))) + lexemes))) + (:preserve (mapcan #'(lambda (x) + (if (listp x) (copy-list x) (list x))) + lexemes)))) + (name (lexemes) + (when (find #\: lexemes) (error "Too many package markers.")) + (make-str (chars lexemes)))) + (let* ((pos (position #\: lexemes)) + (external-p (and pos (not (eql (nth (1+ pos) lexemes) #\:)))) + (package (when pos (name (subseq lexemes 0 pos)))) + (name (name (subseq lexemes + (if pos (+ pos (if external-p 1 2)) 0))))) + (values (cond + (uninterned-symbol-wanted + (if package + (reader-error) + (make-symbol name))) + (external-p + (ensure-external-symbol name package)) + (t (intern name (or package *package*)))))))) + +(defun read-number-or-symbol (stream c) + (let ((lexemes (collect-lexemes c stream))) + (assert lexemes) + (unless *read-suppress* + (cond + ((and lexemes (every #'(lambda (x) (eql x #\.)) lexemes)) + (when (rest lexemes) + (reader-error "Tokens consisting of only dots are invalid.")) + (when (not *consing-dot-allowed*) + (reader-error "Consing dot is not allowed.")) + *consing-dot*) + (t + (or (and (every #'characterp lexemes) (construct-number lexemes)) + (construct-symbol lexemes))))))) + + +;; backquote + +(defconstant backquote (gensym)) +(defconstant backquote-comma (gensym)) +(defconstant backquote-comma-at (gensym)) +(defconstant backquote-comma-dot (gensym)) +(defun backquoted-expression-type (exp) + (if (atom exp) + :normal + (cond + ((eq (first exp) backquote-comma) :comma) + ((eq (first exp) backquote-comma-at) :comma-at) + ((eq (first exp) backquote-comma-dot) :comma-dot) + (t :normal)))) + +(defmacro backquote (object) + (if (atom object) + (if (simple-vector-p object) + (list 'apply #'vector (list backquote (concatenate 'list object))) + (list 'quote object)) + (let* ((list (copy-list object)) + (last (loop for x = list then (cdr x) + until (or (atom (cdr x)) + (find (cadr x) (list backquote + backquote-comma + backquote-comma-at + backquote-comma-dot))) + finally (return (prog1 (cdr x) (setf (cdr x) nil))))) + (types (mapcar #'backquoted-expression-type list))) + (append + (cons (if (notany #'(lambda (x) (eq x :comma-at)) types) 'nconc 'append) + (mapcar #'(lambda (x) + (ecase (backquoted-expression-type x) + (:normal (list 'list (list 'backquote x))) + (:comma (list 'list x)) + ((:comma-at :comma-dot) x))) + list)) + (list (ecase (backquoted-expression-type last) + (:normal (list 'quote last)) + (:comma last) + (:comma-at (error ",@ after dot")) + (:comma-dot (error ",. after dot")))))))) + +(defmacro backquote-comma (obj) obj) +(setf (macro-function backquote) (macro-function 'backquote)) +(setf (macro-function backquote-comma) (macro-function 'backquote-comma)) +(setf (macro-function backquote-comma-at) (macro-function 'backquote-comma)) +(setf (macro-function backquote-comma-dot) (macro-function 'backquote-comma)) + + +(defun read-comma-form (stream c) + (declare (ignore c)) + (unless (> *backquote-level* 0) + (error "Comma must be used in a backquoted expression.")) + (let ((*backquote-level* (1- *backquote-level*))) + (case (peek-char t stream t nil t) + (#\@ (read-char stream t nil t) + (list backquote-comma-at (read stream t nil t))) + (#\. (read-char stream t nil t) + (list backquote-comma-dot (read stream t nil t))) + (t (list backquote-comma (read stream t nil t)))))) + +(defun read-backquoted-expression (stream c) + (declare (ignore c)) + (let ((*backquote-level* (1+ *backquote-level*))) + (list backquote (read stream t nil t)))) + + +(defun sharp-backslash (stream sub-char n) + (declare (ignore n)) + (let* ((lexemes (collect-lexemes sub-char stream)) + (str (make-str (mapcan #'(lambda (x) + (if (listp x) (copy-list x) (list x))) + lexemes)))) + (unless *read-suppress* + (cond + ((= 1 (length str)) (char str 0)) + ((name-char str)) + (t (reader-error "Unrecognized character name: ~S" str)))))) + +(defun sharp-single-quote (stream sub-char n) + (declare (ignore sub-char n)) + `(function ,(read stream t nil t))) + +(defun sharp-left-parenthesis (stream sub-char n) + (declare (ignore sub-char)) + (let ((list (read-delimited-list #\) stream t))) + (unless *read-suppress* + (when (and n (> (length list) n)) + (reader-error "vector is longer than specified length #~A*~A." + n list)) + (apply #'vector + (if (and n (< (length list) n)) + (append list (make-list (- n (length list)) + :initial-element (car (last list)))) + list))))) + +(defun sharp-asterisk (stream sub-char n) + (declare (ignore sub-char)) + (let* ((*input-stream* stream) + (lexemes (collect-lexemes (read-ch))) + (bits (mapcar #'(lambda (d) + (unless (characterp d) + (error "Binary digit must be given")) + (digit-char-p d 2)) lexemes))) + (unless *read-suppress* + (unless (every #'(lambda (d) (digit-char-p d 2)) lexemes) + (reader-error "Illegal bit vector format.")) + (when (and n (> (length bits) n)) + (reader-error "Bit vector is longer than specified length #~A*~A." + n (make-str lexemes))) + (when (and n (> n 0) (zerop (length bits))) + (reader-error + "At least one bit must be given for non-zero #* bit-vectors.")) + (make-array (or n (length bits)) :element-type 'bit + :initial-contents + (if (and n (< (length bits) n)) + (append bits + (make-list (- n (length bits)) + :initial-element (car (last bits)))) + bits))))) + +(defun sharp-colon (stream sub-char n) + (declare (ignore sub-char n)) + (let* ((*input-stream* stream) + (lexemes (collect-lexemes (read-ch)))) + (unless *read-suppress* + (construct-symbol lexemes :uninterned-symbol-wanted t)))) + +(defun sharp-dot (stream sub-char n) + (declare (ignore sub-char n)) + (let ((object (read stream t nil t))) + (unless *read-suppress* + (unless *read-eval* + (reader-error "Attempt to read #. while *READ-EVAL* is bound to NIL.")) + (eval object)))) + +(defun sharp-b (stream sub-char n) + (declare (ignore n)) + (sharp-r stream sub-char 2)) + +(defun sharp-o (stream sub-char n) + (declare (ignore n)) + (sharp-r stream sub-char 8)) + +(defun sharp-x (stream sub-char n) + (declare (ignore n)) + (sharp-r stream sub-char 16)) + +(defun sharp-r (stream sub-char n) + (cond + (*read-suppress* (read stream t nil t)) + ((not n) (reader-error "Radix missing in #R.")) + ((not (<= 2 n 36)) (reader-error "Illegal radix for #R: ~D." n)) + (t (let ((rational (let ((*read-base* n)) (read stream t nil t)))) + (unless (typep rational 'rational) + (reader-error "#~A (base ~D) value is not a rational: ~S." + sub-char n rational)) + rational)))) + + +(defun sharp-c (stream sub-char n) + (declare (ignore sub-char n)) + (let ((pair (read stream t nil t))) + (unless *read-suppress* + (unless (and (listp pair) (= (length pair) 2)) + (reader-error "Illegal complex number format: #C~S" pair)) + (complex (first pair) (second pair))))) + +(defun sharp-a (stream sub-char rank) + (declare (ignore sub-char)) + (cond + (*read-suppress* (read stream t nil t)) + ((null rank) + (reader-error "Rank for #A notation is missing.")) + (t (let* ((contents (read stream t nil t)) + (dimensions (loop repeat rank + for x = contents then (first x) + collect (length x)))) + (make-array dimensions :initial-contents contents))))) + + +(defun find-default-constructor (name) + (declare (ignore name))) + +(defun sharp-s (stream sub-char n) + (declare (ignore sub-char n)) + (let ((structure-spec (read stream t nil t))) + (unless *read-suppress* + (unless (listp structure-spec) + (reader-error "Non list follows #S.")) + (unless (symbolp (first structure-spec)) + (reader-error "Structure type is not a symbol: ~S" + (car structure-spec))) + (let* ((name (first structure-spec)) + (plist (loop + for list on (rest structure-spec) by #'cddr + append (list (intern (string (first list)) "KEYWORD") + (second list)))) + (class (find-class name nil))) + (unless (typep class 'structure-class) + (reader-error "~S is not a defined structure type." name)) + (let ((constructor (find-default-constructor name))) + (apply constructor plist)))))) + +(defun sharp-p (stream sub-char n) + (declare (ignore sub-char n)) + (let ((namestring (read stream t nil t))) + (unless *read-suppress* (parse-namestring namestring)))) + + + +(defun featurep (x) + (if (atom x) + (member x *features*) + (ecase (first x) + (:not (not (featurep (second x)))) + (:and (every #'featurep (rest x))) + (:or (some #'featurep (rest x)))))) + +(defun read-feature-test (stream) + (let ((*package* (or (find-package "KEYWORD") + (error "KEYWORD package not found.")))) + (read stream t nil t))) + +(defun sharp-plus (stream sub-char n) + (declare (ignore sub-char n)) + (if (featurep (read-feature-test stream)) + (read stream t nil t) + (let ((*read-suppress* t)) (read stream t nil t) (values)))) + +(defun sharp-minus (stream sub-char n) + (declare (ignore sub-char n)) + (if (not (featurep (read-feature-test stream))) + (read stream t nil t) + (let ((*read-suppress* t)) (read stream t nil t) (values)))) + +(defun sharp-vertical-bar (stream sub-char n) + (declare (ignore sub-char n)) + (loop for c = (read-char stream t nil t) + if (and (char= c #\#) (char= (read-char stream t nil t) #\|)) + do (sharp-vertical-bar stream #\| nil) + until (and (char= c #\|) (char= (read-char stream t nil t) #\#))) + (values)) + + +(defvar *standard-syntax-table* + (let ((table (make-hash-table))) + (mapc #'(lambda (x) + (let ((syntax (first x)) + (chars (rest x))) + (dolist (c chars) + (setf (gethash c table) `(:syntax ,syntax))))) + '((:whitespace #\Tab #\Newline #\Linefeed #\Page #\Return #\Space) + (:single-escape #\\) + (:multiple-escape #\|))) + table)) + +(setq *standard-readtable* (make-readtable :syntax *standard-syntax-table*)) + +(set-macro-character #\` 'read-backquoted-expression nil *standard-readtable*) +(set-macro-character #\, 'read-comma-form nil *standard-readtable*) + +(set-macro-character #\( #'(lambda (stream char) + (declare (ignore char)) + (read-list #\) stream :allow-consing-dot t)) + nil *standard-readtable*) + +(set-macro-character #\) #'(lambda (stream char) + (declare (ignore stream char)) + (error "Unmatched close parenthesis.")) + nil *standard-readtable*) + +(set-macro-character #\' #'(lambda (stream char) + (declare (ignore char)) + `(quote ,(read stream t nil t))) + nil *standard-readtable*) + +(set-macro-character #\; #'(lambda (stream char) + (declare (ignore char)) + (loop + for c = (read-char stream nil nil t) + until (or (null c) (eql c #\Newline))) + (values)) + nil *standard-readtable*) + +(set-macro-character #\" #'(lambda (stream char) + (declare (ignore char)) + (loop + for c = (read-char stream t nil t) + until (char= c #\") + if (eq :single-escape (syntax-type c)) + collect (read-char stream t nil t) into chars + else + collect c into chars + finally + (return (make-array (length chars) + :element-type 'character + :initial-contents chars)))) + nil *standard-readtable*) + + +(make-dispatch-macro-character #\# t *standard-readtable*) +(mapc + #'(lambda (pair) + (set-dispatch-macro-character #\# (first pair) (second pair) + *standard-readtable*)) + '((#\\ sharp-backslash) (#\' sharp-single-quote) (#\( sharp-left-parenthesis) + (#\* sharp-asterisk) (#\: sharp-colon) (#\. sharp-dot) (#\b sharp-b) + (#\o sharp-o) (#\x sharp-x) (#\r sharp-r) (#\c sharp-c) (#\a sharp-a) + (#\s sharp-s) (#\p sharp-p) (#\= sharp-equal) (#\# sharp-sharp) + (#\+ sharp-plus) (#\- sharp-minus) (#\| sharp-vertical-bar))) + +(setq *readtable* (copy-readtable nil)) diff --git a/Sacla/sequence.lisp b/Sacla/sequence.lisp new file mode 100644 index 0000000..07b6684 --- /dev/null +++ b/Sacla/sequence.lisp @@ -0,0 +1,677 @@ +;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp> +;; ALL RIGHTS RESERVED. +;; +;; $Id: sequence.lisp,v 1.42 2004/02/20 07:23:42 yuji Exp $ +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; * Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; * Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + +(defun length (sequence) + "Return the number of elements in SEQUENCE." + (cond ;; can't use etypecase for setf + ((typep sequence 'list) + (let ((length (list-length sequence))) + (or length (error-circular-list sequence)))) + ((typep sequence 'vector) + (if (array-has-fill-pointer-p sequence) + (fill-pointer sequence) + (array-dimension sequence 0))) + (t + (error 'type-error :datum sequence :expected-type 'sequence)))) + +(defun check-sequence-access (sequence index) + (check-type sequence proper-sequence) + (check-type index (integer 0)) + (unless (< index (length sequence)) + (error-index-too-large sequence index))) + +(defun check-subsequence (sequence start end) + (check-type sequence proper-sequence) + (check-type start (integer 0)) + (check-type end (integer 0))) + +(defun elt (sequence index) + "Return the element of SEQUENCE specified by INDEX." + (check-sequence-access sequence index) + (if (consp sequence) + (nth index sequence) + (aref sequence index))) + +(defsetf elt (sequence index) (value) + "Set the element of SEQUENCE specified by INDEX." + (let ((seq (gensym)) + (idx (gensym))) + `(let ((,seq ,sequence) + (,idx ,index)) + (check-sequence-access ,seq ,idx) + (if (consp ,seq) + (progn (rplaca (nthcdr ,idx ,seq) ,value) ,value) + (setf (aref ,seq ,idx) ,value))))) + +(defun reverse (sequence) + "Return a new sequence containing the same elements but in reverse order." + (check-type sequence proper-sequence) + (cond + ((null sequence) nil) + ((consp sequence) (do ((x sequence (cdr x)) + (result nil (cons (car x) result))) + ((null x) result))) + (t (let* ((length (length sequence)) + (result (make-array length + :element-type (array-element-type sequence)))) + (do ((i 0 (1+ i)) + (j (1- length) (1- j))) + ((>= i length) result) + (setf (aref result i) (aref sequence j))))))) + +(defun nreverse (sequence) + "Modyfy SEQUENCE so that the elements are in reverse order." + (check-type sequence proper-sequence) + (cond + ((null sequence) nil) + ((consp sequence) (do ((1st (cdr sequence) (cdr 1st)) + (2nd sequence 1st) + (3rd '() 2nd)) + ((null 2nd) 3rd) + (rplacd 2nd 3rd))) + (t (let ((length (length sequence))) + (do ((i 0 (1+ i)) + (j (1- length) (1- j))) + ((>= i j) sequence) + (rotatef (aref sequence i) (aref sequence j))))))) + +(defun count-if (predicate sequence &key from-end (start 0) end key) + "Count the number of elements in SEQUENCE which satisfy PREDICATE." + (let ((count 0)) + (do-subsequence (element sequence start end from-end count) + (when (funcall predicate (apply-key key element)) + (incf count))))) + +(defun count-if-not (predicate sequence &key from-end (start 0) end key) + "Count the number of elements in SEQUENCE which do not satisfy PREDICATE." + (count-if (complement predicate) + sequence :from-end from-end :start start :end end :key key)) + +(defun count (item sequence + &key from-end (start 0) end key (test #'eql) test-not) + "Count the number of ITEM in SEQUENCE bounded by START and END." + (when test-not (setq test (complement test-not))) + (count-if #'(lambda (arg) (funcall test item arg)) + sequence :from-end from-end :start start :end end :key key)) + +(defun find-if (predicate sequence &key from-end (start 0) end key) + "Return the first element in SEQUENCE satisfying PREDICATE." + (do-subsequence (element sequence start end from-end nil) + (when (funcall predicate (apply-key key element)) + (return element)))) + +(defun find-if-not (predicate sequence &key from-end (start 0) end key) + "Return the first element in SEQUENCE not satisfying PREDICATE." + (find-if (complement predicate) sequence + :from-end from-end :start start :end end :key key)) + +(defun find (item sequence + &key from-end (test #'eql) test-not (start 0) end key) + "Return the first element in SEQUENCE satisfying TEST or TEST-NOT." + (when test-not (setq test (complement test-not))) + (find-if #'(lambda (arg) (funcall test item arg)) + sequence :from-end from-end :start start :end end :key key)) + +(defun position-if (predicate sequence &key from-end (start 0) end key) + "Return the position of an element in SEQUENCE satisfying PREDICATE." + (unless end (setq end (length sequence))) + (let ((i (if from-end (1- end) start)) + (step (if from-end -1 1))) + (do-subsequence (element sequence start end from-end nil) + (when (funcall predicate (apply-key key element)) + (return i)) + (incf i step)))) + +(defun position-if-not (predicate sequence &key from-end (start 0) end key) + "Return the position of an element in SEQUENCE not satisfying PREDICATE." + (position-if (complement predicate) sequence + :from-end from-end :start start :end end :key key)) + +(defun position (item sequence + &key from-end (test #'eql) test-not (start 0) end key) + "Return the position of an element in SEQUENCE equal to ITEM by TEST." + (when test-not (setq test (complement test-not))) + (position-if #'(lambda (arg) (funcall test item arg)) + sequence :from-end from-end :start start :end end :key key)) + +(defun make-iterator (sequence start end length from-end) + (check-subsequence sequence start end) + (if (listp sequence) + (let* ((head (if from-end + (nthcdr (- length end) (reverse sequence)) + (nthcdr start sequence))) + (x head)) + (values #'(lambda () (prog1 (car x) (setq x (cdr x)))) + #'(lambda () (setq x head)))) + (let* ((from (if from-end (1- end) start)) + (i from) + (step (if from-end -1 1))) + (values #'(lambda () (prog1 (aref sequence i) (setq i (+ i step)))) + #'(lambda () (setq i from)))))) + +(defun search (sequence1 sequence2 &key from-end (test #'eql) test-not key + (start1 0) (start2 0) end1 end2) + "Return the first position in SEQUENCE2 that matches SEQUENCE1." + (when test-not (setq test (complement test-not))) + (let* ((length1 (length sequence1)) + (end1 (or end1 length1)) + (end2 (or end2 (length sequence2))) + (width1 (- end1 start1)) + (last-match nil)) + (multiple-value-bind (get1 reset1) + (make-iterator sequence1 start1 end1 length1 nil) + (etypecase sequence2 + (null (when (zerop length1) 0)) + (cons (do ((x (nthcdr start2 sequence2) (cdr x)) + (i start2 (1+ i))) + ((> i (- end2 width1)) (when from-end last-match)) + (funcall reset1) + (do ((xx x (cdr xx)) + (j 0 (1+ j))) + ((>= j width1) (if from-end + (setq last-match i) + (return-from search i))) + (unless (funcall test (apply-key key (funcall get1)) + (apply-key key (car xx))) + (return))))) + (vector (do ((i start2 (1+ i))) + ((> i (- end2 width1)) (when from-end last-match)) + (funcall reset1) + (do ((ii i (1+ ii)) + (j 0 (1+ j))) + ((>= j width1) (if from-end + (setq last-match i) + (return-from search i))) + (unless (funcall test (apply-key key (funcall get1)) + (apply-key key (aref sequence2 ii))) + (return))))))))) + +(defun mismatch (sequence1 sequence2 &key from-end (test #'eql) test-not key + (start1 0) (start2 0) end1 end2) + "Return the first position where SEQUENCE1 and SEQUENCE2 differ." + (when test-not (setq test (complement test-not))) + (let* ((length1 (length sequence1)) + (length2 (length sequence2)) + (end1 (or end1 length1)) + (end2 (or end2 length2)) + (width1 (- end1 start1)) + (width2 (- end2 start2)) + (width (min width1 width2)) + (s1 (if from-end (- end1 width) start1)) + (e1 (if from-end end1 (+ start1 width)))) + (multiple-value-bind (get2 reset2) + (make-iterator sequence2 start2 end2 length2 from-end) + (declare (ignore reset2)) + (let ((i1 (if from-end (1- end1) start1)) + (step (if from-end -1 1))) + (do-subsequence (element1 sequence1 s1 e1 from-end + (cond ((= width1 width2) nil) + ((< width1 width2) (if from-end 0 end1)) + (t (if from-end + (- end1 width2) + (+ start1 width2))))) + (unless (funcall test (apply-key key element1) + (apply-key key (funcall get2))) + (return (if from-end (1+ i1) i1))) + (incf i1 step)))))) + +(defun replace (sequence1 sequence2 &key (start1 0) end1 (start2 0) end2) + "Modify SEQUENCE1 destructively by replacing elements with those of SUBSEQUENCE2." + (let* ((length2 (length sequence2)) + (end1 (or end1 (length sequence1))) + (end2 (or end2 length2)) + (width1 (- end1 start1)) + (width2 (- end2 start2)) + (width (min width1 width2)) + (from-end nil)) + (when (< start2 start1 (+ start2 width)) + (setq sequence2 (copy-seq sequence2))) + (multiple-value-bind (get2 reset2) + (make-iterator sequence2 start2 end2 length2 from-end) + (declare (ignore reset2)) + (do-subsequence (element1 sequence1 start1 (+ start1 width) from-end) + (setf element1 (funcall get2))) + sequence1))) + + +(defun subseq (sequence start &optional end) + "Return a copy of the subsequence of SEQUENCE bounded by START and END." + (unless end (setq end (length sequence))) + (check-subsequence sequence start end) + (etypecase sequence + (list (do* ((x (nthcdr start sequence) (cdr x)) + (i start (1+ i)) + (result (list nil)) + (splice result)) + ((>= i end) (cdr result)) + (setq splice (cdr (rplacd splice (list (car x))))))) + (vector (let* ((width (- end start)) + (result (make-array width + :element-type + (array-element-type sequence)))) + (do ((i 0 (1+ i)) + (j start (1+ j))) + ((>= i width) result) + (setf (aref result i) (aref sequence j))))))) + +(defsetf subseq (sequence start &optional (end nil)) (new-subsequence) + "Replace destructively the subsequence of SEQUENCE with NEW-SUBSEQUENCE." + `(progn + (check-type ,new-subsequence sequence) + (replace ,sequence ,new-subsequence :start1 ,start :end1 ,end) + ,new-subsequence)) + +(defun copy-seq (sequence) + "Create a copy of SEQUENCE." + (subseq sequence 0)) + +(defun nsubstitute-if (newitem predicate sequence &key from-end + (start 0) end count key) + "Modify SEQUENCE substituting NEWITEM for elements satisfying PREDICATE." + (when (or (null count) (plusp count)) + (do-subsequence (element sequence start end from-end) + (when (funcall predicate (apply-key key element)) + (setf element newitem) + (when (and count (zerop (setq count (1- count)))) + (return))))) + sequence) + +(defun nsubstitute (newitem olditem sequence &key from-end (test #'eql) test-not + (start 0) end count key) + "Modify SEQUENCE substituting NEWITEM for elements euqal to OLDITEM." + (when test-not (setq test (complement test-not))) + (nsubstitute-if newitem #'(lambda (item) (funcall test olditem item)) + sequence :from-end from-end :start start :end end + :count count :key key)) + +(defun nsubstitute-if-not (newitem predicate sequence &key from-end + (start 0) end count key) + "Modify SEQUENCE substituting NEWITEM for elements not satisfying PREDICATE." + (nsubstitute-if newitem (complement predicate) sequence :from-end from-end + :start start :end end :count count :key key)) + +(defun substitute (newitem olditem sequence &key from-end (test #'eql) test-not + (start 0) end count key) + "Return a copy of SEQUENCE with elements euqal to OLDITEM replaced with NEWITEM." + (nsubstitute newitem olditem (copy-seq sequence) :from-end from-end :test test + :test-not test-not :start start :end end :count count :key key)) + +(defun substitute-if (newitem predicate sequence &key from-end (start 0) end + count key) + "Return a copy of SEQUENCE with elements satisfying PREDICATE replaced with NEWITEM." + (nsubstitute-if newitem predicate (copy-seq sequence) :from-end from-end + :start start :end end :count count :key key)) + +(defun substitute-if-not (newitem predicate sequence &key from-end (start 0) end + count key) + "Return a copy of SEQUENCE with elements not satisfying PREDICATE replaced with NEWITEM." + (nsubstitute-if-not newitem predicate (copy-seq sequence) :from-end from-end + :start start :end end :count count :key key)) + +(defun fill (sequence item &key (start 0) end) + "Replace the elements of SEQUENCE bounded by START and END with ITEM." + (nsubstitute-if item (constantly t) sequence :start start :end end)) + +(defun concatenate (result-type &rest sequences) + "Return a sequence of RESULT-TYPE that have all the elements of SEQUENCES." + (cond + ((subtypep result-type 'list) + (let* ((list (list nil)) + (splice list)) + (dolist (seq sequences (cdr list)) + (do-subsequence (element seq 0) + (setq splice (cdr (rplacd splice (cons element nil)))))))) + ((subtypep result-type 'vector) + (let ((vector (make-sequence result-type + (apply #'+ (mapcar #'length sequences)))) + (i 0)) + (dolist (seq sequences vector) + (do-subsequence (element seq 0) + (setf (aref vector i) element) + (incf i))))) + (t + (error 'type-error + :datum result-type + :expected-type '(or null sequence))))) + +(defun merge-lists (list1 list2 predicate key) + (let* ((list (list nil)) + (splice list)) + (do ((x1 list1) + (x2 list2)) + ((or (endp x1) (endp x2)) (rplacd splice (or x1 x2)) (cdr list)) + (if (funcall predicate (apply-key key (car x2)) + (apply-key key (car x1))) + (setq splice (cdr (rplacd splice x2)) + x2 (cdr x2)) + (setq splice (cdr (rplacd splice x1)) + x1 (cdr x1)))))) + +(defun merge (result-type sequence1 sequence2 predicate &key key) + "Merge SEQUENCE1 with SEQUENCE2 destructively according to an order determined by the PREDICATE." + (let ((merged-list (merge-lists (coerce sequence1 'list) + (coerce sequence2 'list) predicate key))) + (cond ((subtypep result-type 'list) merged-list) + ((subtypep result-type 'vector) (coerce merged-list result-type)) + (t (error 'type-error + :datum result-type + :expected-type '(or null sequence)))))) + +(defun quicksort-vector (vector predicate key) + (labels ((quicksort (left right) + (if (<= right left) + vector + (let ((v (partition left right))) + (quicksort left (1- v)) + (quicksort (1+ v) right)))) + (partition (left right) + (let ((pivot (apply-key key (aref vector right))) + (l left) + (r (1- right))) + (loop (loop (unless (funcall predicate + (apply-key key (aref vector l)) + pivot) + (return)) + (incf l)) + (loop (when (or (>= l r) + (funcall predicate + (apply-key key (aref vector r)) + pivot)) + (return)) + (decf r)) + (when (>= l r) + (return)) + (rotatef (aref vector l) (aref vector r))) + (rotatef (aref vector l) (aref vector right)) + l))) + (quicksort 0 (1- (length vector))))) + +(defun sort (sequence predicate &key key) + "Sort SEQUENCE destructively according to the order determined by PREDICATE." + (if (vectorp sequence) + (quicksort-vector sequence predicate key) + (let ((vector (quicksort-vector (make-array (length sequence) + :initial-contents sequence) + predicate key))) + (do ((x sequence (cdr x)) + (i 0 (1+ i))) + ((endp x) sequence) + (rplaca x (aref vector i)))))) + +(defun mergesort-list (list predicate key) + (labels ((mergesort (list length) + (if (<= length 1) + list + (let* ((length1 (floor (/ length 2))) + (length2 (- length length1)) + (list1 list) + (last1 (nthcdr (1- length1) list)) + (list2 (cdr last1))) + (rplacd last1 nil) + (merge 'list + (mergesort list1 length1) (mergesort list2 length2) + predicate :key key))))) + (mergesort list (length list)))) + +(defun stable-sort (sequence predicate &key key) + "Sort SEQUENCE destructively guaranteeing the stability of equal elements' order." + (if (listp sequence) + (mergesort-list sequence predicate key) + (let ((list (mergesort-list (coerce sequence 'list) predicate key))) + (do ((x list (cdr x)) + (i 0 (1+ i))) + ((endp x) sequence) + (setf (aref sequence i) (car x)))))) + +(defun list-delete-if (test list start end count key) + (let* ((head (cons nil list)) + (splice head)) + (do ((i 0 (1+ i)) + (x list (cdr x))) + ((endp x) (rplacd splice nil) (cdr head)) + (when (and count (<= count 0)) + (rplacd splice x) + (return (cdr head))) + (if (and (<= start i) (or (null end) (< i end)) + (funcall test (apply-key key (car x)))) + (when count (decf count)) + (setq splice (cdr (rplacd splice x))))))) + +(defun vector-delete-if (test vector start end count key) + (let* ((length (length vector)) + (end (or end length)) + (count (or count length)) + (i 0)) + (do* ((j 0 (1+ j)) + element) + ((>= j length)) + (setq element (aref vector j)) + (if (and (<= start j) (< j end) + (plusp count) + (funcall test (apply-key key element))) + (when count (decf count)) + (progn + (setf (aref vector i) element) + (incf i)))) + (cond + ((array-has-fill-pointer-p vector) + (setf (fill-pointer vector) i) + vector) + ((adjustable-array-p vector) (adjust-array vector i)) + (t (subseq vector 0 i))))) + +(defun delete-if (predicate sequence &key from-end (start 0) end count key) + "Modify SEQUENCE by deleting elements satisfying PREDICATE." + (if from-end + (let ((length (length sequence))) + (nreverse (delete-if predicate (nreverse sequence) + :start (- length (or end length)) + :end (- length start) + :count count :key key))) + (etypecase sequence + (null nil) + (cons (list-delete-if predicate sequence start end count key)) + (vector (vector-delete-if predicate sequence start end count key))))) + +(defun delete (item sequence &key from-end (test #'eql) test-not (start 0) end + count key) + "Modify SEQUENCE by deleting elements equal to ITEM." + (when test-not (setq test (complement test-not))) + (delete-if #'(lambda (arg) (funcall test item arg)) sequence + :from-end from-end :start start :end end :count count :key key)) + +(defun delete-if-not (predicate sequence &key from-end (start 0) end count key) + "Modify SEQUENCE by deleting elements not satisfying PREDICATE." + (delete-if (complement predicate) sequence :from-end from-end + :start start :end end :count count :key key)) + +(defun remove-if (predicate sequence &key from-end (start 0) end count key) + "Return a copy of SEQUENCE with elements satisfying PREDICATE removed." + (delete-if predicate (copy-seq sequence) :from-end from-end :start start :end end + :count count :key key)) + +(defun remove (item sequence &key from-end (test #'eql) test-not (start 0) + end count key) + "Return a copy of SEQUENCE with elements equal to ITEM removed." + (when test-not (setq test (complement test-not))) + (remove-if #'(lambda (arg) (funcall test item arg)) sequence + :from-end from-end :start start :end end :count count :key key)) + +(defun remove-if-not (predicate sequence &key from-end (start 0) end count key) + "Return a copy of SEQUENCE with elements not satisfying PREDICATE removed." + (remove-if (complement predicate) sequence :from-end from-end + :start start :end end :count count :key key)) + + +(defun list-delete-duplicates (test list start end key) + (check-type list proper-list) + (let* ((head (cons nil list)) + (splice head) + (tail (when end (nthcdr end list)))) + (flet ((list-member (list) + (do ((x (cdr list) (cdr x)) + (item (car list))) + ((eq x tail) nil) + (when (funcall test (apply-key key item) (apply-key key (car x))) + (return t))))) + (do ((i 0 (1+ i)) + (x list (cdr x))) + ((endp x) (rplacd splice nil) (cdr head)) + (unless (and (<= start i) (or (null end) (< i end)) (list-member x)) + (setq splice (cdr (rplacd splice x)))))))) + +(defun vector-delete-duplicates (test vector start end key) + (let* ((length (length vector)) + (end (or end length)) + (i 0)) + (flet ((vector-member (item j) + (do ((k (1+ j) (1+ k))) + ((>= k end) nil) + (when (funcall test (apply-key key item) + (apply-key key (aref vector k))) + (return t))))) + (do* ((j 0 (1+ j)) + element) + ((>= j length)) + (setq element (aref vector j)) + (unless (and (<= start j) (< j end) (vector-member element j)) + (setf (aref vector i) element) + (incf i))) + (cond + ((array-has-fill-pointer-p vector) + (setf (fill-pointer vector) i) + vector) + ((adjustable-array-p vector) (adjust-array vector i)) + (t (subseq vector 0 i)))))) + +(defun delete-duplicates (sequence &key from-end (test #'eql) test-not + (start 0) end key) + "Modify SEQUENCE deleting redundant elements." + (when test-not (setq test (complement test-not))) + (if from-end + (let ((length (length sequence))) + (nreverse (delete-duplicates (nreverse sequence) :test test :key key + :start (- length (or end length)) + :end (- length start)))) + (etypecase sequence + (null nil) + (cons (list-delete-duplicates test sequence start end key)) + (vector (vector-delete-duplicates test sequence start end key))))) + +(defun remove-duplicates (sequence &key from-end (test #'eql) test-not + (start 0) end key) + "Return a copy of SEQUENCE with redundant elements removed." + (delete-duplicates (copy-seq sequence) :from-end from-end :key key + :test test :test-not test-not :start start :end end)) + +(defun reduce (function sequence &key key from-end (start 0) end + (initial-value nil initial-value-supplied)) + "Use a binary operation FUNCTION to combine the elements of SEQUENCE." + (unless end (setq end (length sequence))) + (check-subsequence sequence start end) + (if (= start end) + (if initial-value-supplied initial-value (funcall function)) + (let ((fun (if from-end #'(lambda (a b) (funcall function b a)) function)) + (value (if initial-value-supplied + initial-value + (apply-key key (if from-end + (elt sequence (decf end)) + (prog1 (elt sequence start) + (incf start))))))) + (do-subsequence (element sequence start end from-end value) + (setq value (funcall fun value (apply-key key element))))))) + +(defmacro do-sequences ((var sequences &optional (result nil)) &body body) + (let ((seq-list (gensym)) + (i (gensym)) + (min (gensym))) + `(let* ((,seq-list (copy-seq ,sequences)) + (,var (make-list (list-length ,seq-list) :initial-element nil)) + (,min (if ,seq-list (reduce #'min ,seq-list :key #'length) 0))) + (dotimes (,i ,min ,result) + (do* ((src ,seq-list (cdr src)) + (seq (car src) (car src)) + (dest ,var (cdr dest))) + ((null src)) + (rplaca dest (if (consp seq) + (progn + (rplaca src (cdr seq)) + (car seq)) + (aref seq ,i)))) + ,@body)))) + +(defun map-into (result-sequence function &rest sequences) + "Modify RESULT-SEQUENCE, applying FUNCTION to the elements of SEQUENCES." + (etypecase result-sequence + (null nil) + (cons (let ((x result-sequence)) + (do-sequences (args sequences result-sequence) + (when (endp x) (return result-sequence)) + (rplaca x (apply function args)) + (setq x (cdr x))))) + (vector (let ((i 0) + (length (array-dimension result-sequence 0))) + (do-sequences (args sequences) + (when (= i length) (return)) + (setf (aref result-sequence i) (apply function args)) + (setq i (1+ i))) + (when (array-has-fill-pointer-p result-sequence) + (setf (fill-pointer result-sequence) i)) + result-sequence)))) + +(defun map (result-type function sequence &rest more-sequences) + "Apply FUNCTION to the successive elements of SEQUENCE and MORE-SEQUENCES." + (if (null result-type) + (do-sequences (args (cons sequence more-sequences) nil) + (apply function args)) + (let* ((sequences (cons sequence more-sequences)) + (seq (make-sequence result-type + (reduce #'min sequences :key #'length)))) + (apply #'map-into seq function sequences)))) + + +(defun every (predicate sequence &rest more-sequences) + "Return true if and only if every invocation of PREDICATE on SEQUENCE returns true." + (do-sequences (args (cons sequence more-sequences) t) + (unless (apply predicate args) + (return nil)))) + +(defun some (predicate sequence &rest more-sequences) + "Return true if and only if some invocation of PREDICATE on SEQUENCE returns true." + (do-sequences (args (cons sequence more-sequences) nil) + (when (apply predicate args) + (return t)))) + +(defun notevery (predicate sequence &rest more-sequences) + "Return true if and only if some invocation of PREDICATE on SEQUENCE returns false." + (not (apply #'every predicate sequence more-sequences))) + +(defun notany (predicate sequence &rest more-sequences) + "Return true if and only if every invocation of PREDICATE on SEQUENCE returns false." + (not (apply #'some predicate sequence more-sequences))) diff --git a/Sacla/share.lisp b/Sacla/share.lisp new file mode 100644 index 0000000..8c9d3e1 --- /dev/null +++ b/Sacla/share.lisp @@ -0,0 +1,184 @@ +;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp> +;; ALL RIGHTS RESERVED. +;; +;; $Id: share.lisp,v 1.10 2004/09/02 06:59:43 yuji Exp $ +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; * Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; * Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(deftype proper-list () '(satisfies proper-list-p)) +(deftype proper-sequence () '(satisfies proper-sequence-p)) +(deftype string-designator () '(or character symbol string)) +(deftype package-designator () '(or string-designator package)) +(deftype function-designator () '(or symbol function)) +(deftype extended-function-designator () + '(or function (satisfies function-name-p))) +(deftype character-designator-simbol () + '(satisfies character-designator-symbol-p)) + +(defun character-designator-symbol-p (object) + (and (symbolp object) (= (length (symbol-name object)) 1))) + +(defun function-name-p (object) + (or (symbolp object) + (and (consp object) + (eq (car object) 'setf) + (symbolp (cadr object)) + (null (cddr object))))) + +(defun proper-list-p (object) + (when (listp object) + (do ((fast object (cddr fast)) + (slow object (cdr slow))) + (nil) + (when (atom fast) + (return (null fast))) + (when (atom (cdr fast)) + (return (null (cdr fast)))) + (when (and (eq fast slow) (not (eq fast object))) + (return nil))))) + +(defun proper-sequence-p (object) + (or (vectorp object) (proper-list-p object))) + +(defun error-circular-list (list) + (error 'type-error :datum list :expected-type 'proper-list)) + +(defun error-index-too-large (sequence index) + (error 'type-error + :datum index + :expected-type `(integer 0 ,(1- (length sequence))))) + +(defmacro apply-key (key element) + `(if ,key + (funcall ,key ,element) + ,element)) + + +(defmacro do-sublist ((var list start end from-end result) &body body) + (let ((rev (gensym)) + (i (gensym)) + (x (gensym))) + `(symbol-macrolet ((,var (car ,x))) + (if ,from-end + (let ((,rev nil)) + (do ((x (nthcdr ,start ,list) (cdr x)) + (i ,start (1+ i))) + ((>= i ,end)) + (setq ,rev (cons x ,rev))) + (do* ((,rev ,rev (cdr ,rev)) + (,x (car ,rev) (car ,rev))) + ((null ,rev) ,result) + ,@body)) + (do ((,x (nthcdr ,start ,list) (cdr ,x)) + (,i ,start (1+ ,i))) + ((>= ,i ,end) ,result) + ,@body))))) + +(defmacro do-subvector ((var vector start end from-end result) &body body) + (let ((i (gensym)) + (step (gensym)) + (limit (gensym))) + `(symbol-macrolet ((,var (aref ,vector ,i))) + (let ((,step (if ,from-end -1 1)) + (,limit (if ,from-end (1- ,start) ,end))) + (do ((,i (if ,from-end (1- ,end) ,start) (+ ,i ,step))) + ((= ,i ,limit) ,result) + ,@body))))) + +(defmacro do-subsequence ((var sequence-form start-form &optional end-form + from-end-form result-form) &body body) + (let ((sequence (gensym)) + (start (gensym)) + (end (gensym))) + `(let* ((,sequence ,sequence-form) + (,start ,start-form) + (,end (or ,end-form (length ,sequence)))) + (check-subsequence ,sequence ,start ,end) + (etypecase ,sequence + (list + (do-sublist (,var ,sequence ,start ,end ,from-end-form ,result-form) + ,@body)) + (vector + (do-subvector (,var ,sequence ,start ,end ,from-end-form ,result-form) + ,@body)))))) + +(defun declarationp (expr) + (and (consp expr) (eq (car expr) 'declare))) + +(defun declarations-and-forms (body) + (block nil + (let ((decls nil) + (forms body)) + (tagbody + top + (when (not (declarationp (car forms))) + (return (values (reverse decls) forms))) + (push (car forms) decls) (psetq forms (cdr forms)) + (go top))))) + + +(defun required-argument () + (error "required argument not specified.")) + + +(defun %symbol (designator) + (if (symbolp designator) + designator + (error 'type-error :datum designator :expected-type 'symbol))) +(defun %keyword (designator) + (intern (string designator) "KEYWORD")) +(defun %list (designator) + (if (listp designator) + designator + (list designator))) +(defun symbol-list (designator) (mapcar #'%symbol (%list designator))) +(defun string-list (designator) (mapcar #'string (%list designator))) + + + +(defun store-value-report (stream place) + (format stream "Supply a new value for ~S." place)) +(defun store-value-interactive () + (format *query-io* "~&Type a form to be evaluated:~%") + (list (eval (read *query-io*)))) + + + +(defun mapappend (function &rest lists) + (apply #'append (apply #'mapcar function lists))) + +(define-condition simple-program-error (simple-condition program-error) ()) + +(define-modify-macro appendf (&rest args) + append "Append onto list") + + +(defvar *message-prefix* "") +;; for debug +(defvar *error-function* #'error) +(defun error (datum &rest arguments) + (if (stringp datum) + (let ((format-control (concatenate 'string *message-prefix* datum))) + (apply *error-function* format-control arguments)) + (apply *error-function* datum arguments))) diff --git a/Sacla/stand-in.lisp b/Sacla/stand-in.lisp new file mode 100644 index 0000000..425ae9d --- /dev/null +++ b/Sacla/stand-in.lisp @@ -0,0 +1,44 @@ +;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp> +;; ALL RIGHTS RESERVED. +;; +;; $Id: stand-in.lisp,v 1.1 2004/07/22 07:47:14 yuji Exp $ +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; * Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; * Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;;; Commentary: +;; Supply a customized DEFUN which forces replacement of function definitions +;; even if the target symbol is in the COMMON-LISP package. + +(defpackage "STAND-IN" + (:shadow "DEFUN") + (:use "COMMON-LISP")) + +(in-package "STAND-IN") + +#+clisp +(defmacro defun (&rest args) + `(handler-bind ((system::simple-package-error (invoke-restart 'continue))) + (cl:defun ,@args))) +#+cmu +(error "stand-in::defun is not define for cmucl.") diff --git a/Sacla/stream.lisp b/Sacla/stream.lisp new file mode 100644 index 0000000..3d78263 --- /dev/null +++ b/Sacla/stream.lisp @@ -0,0 +1,106 @@ +;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp> +;; ALL RIGHTS RESERVED. +;; +;; $Id: stream.lisp,v 1.7 2004/05/26 07:57:52 yuji Exp $ +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; * Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; * Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(defun terpri (&optional output-stream) + (write-char #\Newline output-stream) + nil) + +(defun read-line (&optional input-stream eof-error-p eof-value recursive-p) + (let ((str (make-array 160 + :element-type 'character + :fill-pointer 0 + :adjustable t)) + char) + (loop + (setq char (read-char input-stream eof-error-p eof-value recursive-p)) + (when (eql char eof-value) + (return (values str t))) + (vector-push-extend char str) + (when (char= char #\Newline) + (return (values str nil)))))) + + +(defun write-string (string &optional output-stream &key (start 0) end) + (unless end (setq end (length string))) + (do ((i start (1+ i))) + ((= i end) string) + (write-char (char string i) output-stream))) + +(defun write-line (string &optional output-stream &key (start 0) end) + (write-string string output-stream :start start :end end) + (write-char #\Newline output-stream) + string) + +(defun read-sequence (sequence stream &key (start 0) end) + (let ((pos start) + (read-element (if (subtypep (stream-element-type stream) 'character) + #'read-char + #'read-byte)) + new) + (do-subsequence (element sequence start end nil pos) + (unless (setq new (funcall read-element stream)) + (return pos)) + (setf element new) + (incf pos)))) + + +(defun write-sequence (sequence stream &key (start 0) end) + (let ((write-element (if (subtypep (stream-element-type stream) 'character) + #'write-char + #'write-byte))) + (do-subsequence (element sequence start end) + (funcall write-element element stream)) + sequence)) + + +(defmacro with-open-file ((stream filespec &rest options) &body body) + (let ((abortp (gensym))) + (multiple-value-bind (decls forms) (declarations-and-forms body) + `(let ((,var (open filespec ,@options)) + (,abortp t)) + ,@decls + (unwind-protect + (multiple-value-prog1 + (progn ,@forms) + (setq ,abortp nil)) + (when ,var + (close ,var :abort ,abortp))))))) + +(defmacro with-open-stream ((var stream) &body body) + (let ((abortp (gensym))) + (multiple-value-bind (decls forms) (declarations-and-forms body) + `(let ((,var ,stream) + (,abortp t)) + ,@decls + (unwind-protect + (multiple-value-prog1 + (progn ,@forms) + (setq ,abortp nil)) + (when ,var + (close ,var :abort ,abortp))))))) + diff --git a/Sacla/string.lisp b/Sacla/string.lisp new file mode 100644 index 0000000..f671fb7 --- /dev/null +++ b/Sacla/string.lisp @@ -0,0 +1,323 @@ +;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp> +;; ALL RIGHTS RESERVED. +;; +;; $Id: string.lisp,v 1.5 2004/02/20 07:23:42 yuji Exp $ +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; * Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; * Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + +(defun stringp (object) + "Return true if OBJECT is of type string; otherwise, return false." + (and (vectorp object) + (subtypep (array-element-type object) 'character))) + +(defun simple-string-p (object) + "Return true if OBJECT is of type simple-string; otherwise, returns false." + (and (stringp object) + (typep object 'simple-array))) + + +(defun string (x) + "Return a string described by X; X can be a string, a symbol, or a character." + (etypecase x + (string x) + (symbol (symbol-name x)) + (character (make-array 1 :element-type 'character :initial-element x)))) + +(defun string-upcase (string &key (start 0) end) + "Return a copy of STRING upcasing all lowercase chars between START and END." + (unless (stringp string) + (setq string (string string))) + (unless end + (setq end (length string))) + (let ((str (make-array (length string) + :element-type 'character + :initial-contents string))) + (do ((i start (1+ i))) + ((>= i end) str) + (setf (schar str i) (char-upcase (schar str i)))))) + +(defun string-downcase (string &key (start 0) end) + "Return a copy of STRING downcasing all uppercase chars between START and END." + (unless (stringp string) + (setq string (string string))) + (unless end + (setq end (length string))) + (let ((str (make-array (length string) + :element-type 'character + :initial-contents string))) + (do ((i start (1+ i))) + ((>= i end) str) + (setf (schar str i) (char-downcase (schar str i)))))) + + +(defun string-capitalize (string &key (start 0) end) + "Return a copy of STRING capitalizing all words between START and END." + (unless (stringp string) + (setq string (string string))) + (unless end + (setq end (length string))) + (let ((str (make-array (length string) + :element-type 'character + :initial-contents string)) + (in-a-word nil)) + (do ((i start (1+ i)) + c) + ((>= i end) str) + (setq c (schar str i)) + (if (alphanumericp c) + (if in-a-word + (setq c (char-downcase c)) + (setq c (char-upcase c) + in-a-word t)) + (when in-a-word + (setq in-a-word nil))) + (setf (schar str i) c)))) + + +(defun nstring-upcase (string &key (start 0) end) + "Modify STRING to make all lowercase chars between START and END uppercase." + (unless end + (setq end (length string))) + (do ((i start (1+ i))) + ((>= i end) string) + (setf (char string i) (char-upcase (char string i))))) + + +(defun nstring-downcase (string &key (start 0) end) + "Modify STRING to make all uppercase chars between START and END lowercase." + (unless end + (setq end (length string))) + (do ((i start (1+ i))) + ((>= i end) string) + (setf (char string i) (char-downcase (char string i))))) + +(defun nstring-capitalize (string &key (start 0) end) + "Modify STRING capitalizing all words between START and END." + (unless end + (setq end (length string))) + (do ((i start (1+ i)) + (in-a-word nil) + c) + ((>= i end) string) + (setq c (char string i)) + (if (alphanumericp c) + (if in-a-word + (setq c (char-downcase c)) + (setq c (char-upcase c) + in-a-word t)) + (when in-a-word + (setq in-a-word nil))) + (setf (char string i) c))) + + +(defun string-left-trim (character-bag string) + "Return a copy of STRING stripping chars in CHARACTER-BAG off the beginning." + (unless (stringp string) + (setq string (string string))) + (dotimes (i (length string) (make-string 0 :element-type 'character)) + (unless (find (char string i) character-bag) + (return (subseq string i))))) + +(defun string-right-trim (character-bag string) + "Return a copy of STRING stripping chars in CHARACTER-BAG off the end." + (unless (stringp string) + (setq string (string string))) + (do ((i (1- (length string)) (1- i))) + ((minusp i) (make-string 0 :element-type 'character)) + (unless (find (char string i) character-bag) + (return (subseq string 0 (1+ i)))))) + +(defun string-trim (character-bag string) + "Return a copy of STRING stripping chars in CHARACTER-BAG off the both ends." + (string-left-trim character-bag (string-right-trim character-bag string))) + + + +(defun string= (string1 string2 &key (start1 0) end1 (start2 0) end2) + "Return true if the specified substrings are the same in terms of char=." + (unless (stringp string1) (setq string1 (string string1))) + (unless (stringp string2) (setq string2 (string string2))) + (unless end1 (setq end1 (length string1))) + (unless end2 (setq end2 (length string2))) + (when (= (- end1 start1) (- end2 start2)) + (do ((i1 start1 (1+ i1)) + (i2 start2 (1+ i2))) + ((= i1 end1) t) + (unless (char= (char string1 i1) (char string2 i2)) + (return nil))))) + +(defun string-equal (string1 string2 &key (start1 0) end1 (start2 0) end2) + "Return true if the specified substrings are the same in terms of char-equal." + (unless (stringp string1) (setq string1 (string string1))) + (unless (stringp string2) (setq string2 (string string2))) + (unless end1 (setq end1 (length string1))) + (unless end2 (setq end2 (length string2))) + (when (= (- end1 start1) (- end2 start2)) + (do ((i1 start1 (1+ i1)) + (i2 start2 (1+ i2))) + ((= i1 end1) t) + (unless (char-equal (char string1 i1) (char string2 i2)) + (return nil))))) + + +(defun string/= (string1 string2 &key (start1 0) end1 (start2 0) end2) + "Return true if the specified substrings are not the same in terms of char=." + (unless (stringp string1) (setq string1 (string string1))) + (unless (stringp string2) (setq string2 (string string2))) + (unless end1 (setq end1 (length string1))) + (unless end2 (setq end2 (length string2))) + (do ((i1 start1 (1+ i1)) + (i2 start2 (1+ i2))) + ((or (= i1 end1) (= i2 end2)) (if (and (= i1 end1) (= i2 end2)) nil i1)) + (unless (char= (char string1 i1) (char string2 i2)) + (return i1)))) + +(defun string-not-equal (string1 string2 &key (start1 0) end1 (start2 0) end2) + "Return true if the specified substrs aren't the same in terms of char-equal." + (unless (stringp string1) (setq string1 (string string1))) + (unless (stringp string2) (setq string2 (string string2))) + (unless end1 (setq end1 (length string1))) + (unless end2 (setq end2 (length string2))) + (do ((i1 start1 (1+ i1)) + (i2 start2 (1+ i2))) + ((or (= i1 end1) (= i2 end2)) (if (and (= i1 end1) (= i2 end2)) nil i1)) + (unless (char-equal (char string1 i1) (char string2 i2)) + (return i1)))) + + +(defun string< (string1 string2 &key (start1 0) end1 (start2 0) end2) + "Return true if substring1 is less than substring2 in terms of char<." + (unless (stringp string1) (setq string1 (string string1))) + (unless (stringp string2) (setq string2 (string string2))) + (unless end1 (setq end1 (length string1))) + (unless end2 (setq end2 (length string2))) + (do ((i1 start1 (1+ i1)) + (i2 start2 (1+ i2))) + ((or (= i1 end1) (= i2 end2)) (when (and (= i1 end1) (/= i2 end2)) end1)) + (unless (char= (char string1 i1) (char string2 i2)) + (return (if (char< (char string1 i1) (char string2 i2)) i1 nil))))) + +(defun string-lessp (string1 string2 &key (start1 0) end1 (start2 0) end2) + "Return true if substring1 is less than substring2 in terms of char-lessp." + (unless (stringp string1) (setq string1 (string string1))) + (unless (stringp string2) (setq string2 (string string2))) + (unless end1 (setq end1 (length string1))) + (unless end2 (setq end2 (length string2))) + (do ((i1 start1 (1+ i1)) + (i2 start2 (1+ i2))) + ((or (= i1 end1) (= i2 end2)) (when (and (= i1 end1) (/= i2 end2)) end1)) + (unless (char-equal (char string1 i1) (char string2 i2)) + (return (if (char-lessp (char string1 i1) (char string2 i2)) i1 nil))))) + + +(defun string> (string1 string2 &key (start1 0) end1 (start2 0) end2) + "Return true if substring1 is greater than substring2 in terms of char>." + (unless (stringp string1) (setq string1 (string string1))) + (unless (stringp string2) (setq string2 (string string2))) + (unless end1 (setq end1 (length string1))) + (unless end2 (setq end2 (length string2))) + (do ((i1 start1 (1+ i1)) + (i2 start2 (1+ i2))) + ((or (= i1 end1) (= i2 end2)) (when (and (/= i1 end1) (= i2 end2)) i1)) + (unless (char= (char string1 i1) (char string2 i2)) + (return (if (char> (char string1 i1) (char string2 i2)) i1 nil))))) + +(defun string-greaterp (string1 string2 &key (start1 0) end1 (start2 0) end2) + "Return true if substr1 is greater than substr2 in terms of char-greaterp." + (unless (stringp string1) (setq string1 (string string1))) + (unless (stringp string2) (setq string2 (string string2))) + (unless end1 (setq end1 (length string1))) + (unless end2 (setq end2 (length string2))) + (do ((i1 start1 (1+ i1)) + (i2 start2 (1+ i2))) + ((or (= i1 end1) (= i2 end2)) (when (and (/= i1 end1) (= i2 end2)) i1)) + (unless (char-equal (char string1 i1) (char string2 i2)) + (return (if (char-greaterp (char string1 i1) (char string2 i2)) + i1 + nil))))) + + +(defun string<= (string1 string2 &key (start1 0) end1 (start2 0) end2) + "Return true if substr1 is less than or equal to subst2 in terms of char<=." + (unless (stringp string1) (setq string1 (string string1))) + (unless (stringp string2) (setq string2 (string string2))) + (unless end1 (setq end1 (length string1))) + (unless end2 (setq end2 (length string2))) + (do ((i1 start1 (1+ i1)) + (i2 start2 (1+ i2))) + ((or (= i1 end1) (= i2 end2)) (when (= i1 end1) end1)) + (unless (char= (char string1 i1) (char string2 i2)) + (return (if (char<= (char string1 i1) (char string2 i2)) i1 nil))))) + +(defun string-not-greaterp (string1 string2 &key + (start1 0) end1 (start2 0) end2) + "Return true if substr1 is not greater than subst2 in terms of char-not-greaterp." + (unless (stringp string1) (setq string1 (string string1))) + (unless (stringp string2) (setq string2 (string string2))) + (unless end1 (setq end1 (length string1))) + (unless end2 (setq end2 (length string2))) + (do ((i1 start1 (1+ i1)) + (i2 start2 (1+ i2))) + ((or (= i1 end1) (= i2 end2)) (when (= i1 end1) end1)) + (unless (char-equal (char string1 i1) (char string2 i2)) + (return (if (char-not-greaterp (char string1 i1) (char string2 i2)) + i1 + nil))))) + + +(defun string>= (string1 string2 &key (start1 0) end1 (start2 0) end2) + "Return true if substr1 is greater than or equal to subst2 in terms of char>=." + (unless (stringp string1) (setq string1 (string string1))) + (unless (stringp string2) (setq string2 (string string2))) + (unless end1 (setq end1 (length string1))) + (unless end2 (setq end2 (length string2))) + (do ((i1 start1 (1+ i1)) + (i2 start2 (1+ i2))) + ((or (= i1 end1) (= i2 end2)) (unless (and (= i1 end1) (/= i2 end2)) i1)) + (unless (char= (char string1 i1) (char string2 i2)) + (return (if (char>= (char string1 i1) (char string2 i2)) i1 nil))))) + + +(defun string-not-lessp (string1 string2 &key (start1 0) end1 (start2 0) end2) + "Return true if substr1 is not less than subst2 in terms of char-not-lessp." + (unless (stringp string1) (setq string1 (string string1))) + (unless (stringp string2) (setq string2 (string string2))) + (unless end1 (setq end1 (length string1))) + (unless end2 (setq end2 (length string2))) + (do ((i1 start1 (1+ i1)) + (i2 start2 (1+ i2))) + ((or (= i1 end1) (= i2 end2)) (unless (and (= i1 end1) (/= i2 end2)) i1)) + (unless (char-equal (char string1 i1) (char string2 i2)) + (return (if (char-not-lessp (char string1 i1) (char string2 i2)) + i1 + nil))))) + + + +(defun make-string (size &key + (initial-element #\Space) + (element-type 'character)) + "Return a simple string of SIZE, ELEMENT-TYPE initialized to INITIAL-ELEMENT." + (make-array size :element-type element-type :initial-element initial-element)) diff --git a/Sacla/symbol.lisp b/Sacla/symbol.lisp new file mode 100644 index 0000000..f508704 --- /dev/null +++ b/Sacla/symbol.lisp @@ -0,0 +1,102 @@ +;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp> +;; ALL RIGHTS RESERVED. +;; +;; $Id: symbol.lisp,v 1.8 2004/02/20 07:23:42 yuji Exp $ +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; * Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; * Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(defun keywordp (object) + "Return true if OBJECT is a keyword; otherwise, return false." + (and (symbolp object) + (symbol-package object) + (eq (symbol-package object) + (find-package "KEYWORD")))) + +(defun copy-symbol (symbol &optional copy-properties) + "Returns a fresh, uninterned symbol whose name is string= to SYMBOL's." + (let ((copy (make-symbol (symbol-name symbol)))) + (when copy-properties + (when (boundp symbol) + (setf (symbol-value copy) (symbol-value symbol))) + (when (fboundp symbol) + (setf (symbol-function copy) (symbol-function symbol))) + (setf (symbol-plist copy) (copy-list (symbol-plist symbol)))) + copy)) + + +(defun counter-to-str (x) + (flet ((digit-to-str (digit) + (string (char "0123456789" digit)))) + (do* ((x x (floor x 10)) + (digits (list (digit-to-str (mod x 10))) + (cons (digit-to-str (mod x 10)) digits))) + ((zerop (floor x 10)) (apply #'concatenate + 'string + digits))))) + +;;(defvar *gensym-counter* 0 +;; "Counter for generating unique GENSYM symbols.") +;; +;;(defun gensym (&optional (x "G")) +;; "Return a fresh, uninterned symbol whose name is determined using X." +;; (multiple-value-bind (prefix index) +;; (etypecase x +;; ((integer 0) (values "G" x)) +;; ((string) (multiple-value-prog1 +;; (values x *gensym-counter*) +;; (setq *gensym-counter* (1+ *gensym-counter*))))) +;; (make-symbol (concatenate 'string prefix (counter-to-str index))))) + +(defvar *gentemp-counter* 0) + +(defun gentemp (&optional (prefix "T") (package *package*)) + "Return a fresh symbol, newly interned in PACKAGE." + (flet ((make-name (prefix) + (prog1 + (concatenate 'string + prefix + (counter-to-str *gentemp-counter*)) + (setq *gentemp-counter* (1+ *gentemp-counter*))))) + (do ((name (make-name prefix) (make-name prefix))) + (nil) + (multiple-value-bind (symbol status) + (find-symbol name package) + (declare (ignore symbol)) + (when (eq status nil) + (return (intern name package))))))) + +(defsetf symbol-value + set + "Change the contents of the value cell of symbol to the given value.") + +(defun get (symbol indicator &optional default) + (getf (symbol-plist symbol) indicator default)) + +(defsetf get (symbol indicator &optional default) (value) + `(setf (getf (symbol-plist ,symbol) ,indicator ,default) ,value)) + + +(defun remprop (symbol indicator) + (remf (symbol-plist symbol) indicator)) + diff --git a/Sacla/testbed.lisp b/Sacla/testbed.lisp new file mode 100644 index 0000000..6d5e54a --- /dev/null +++ b/Sacla/testbed.lisp @@ -0,0 +1,217 @@ +;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp> +;; ALL RIGHTS RESERVED. +;; +;; $Id: testbed.lisp,v 1.4 2004/09/02 06:59:43 yuji Exp $ +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; * Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; * Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(defpackage "TESTBED" + (:nicknames "TB") + (:shadow "DEFMACRO" "DEFINE-CONDITION") + (:use "COMMON-LISP")) + +(in-package "TESTBED") + +(defun shadow-cl-symbol (name &optional type) + (multiple-value-bind (cl-symbol status) (find-symbol name "CL") + (when (eq status :external) + (let ((symbol (progn (shadow name) (intern name "TB")))) + ;; type + (when (and (not (eq type :condition)) + (or (member cl-symbol + '(not and mod satisfies eql not values member or)) + (subtypep cl-symbol t)) + (not (member cl-symbol '(error)))) + (eval `(deftype ,symbol (&rest rest) + (if rest + (cons ',cl-symbol rest) + ',cl-symbol)))) + ;; function + (when (and (not (eq type :function)) (fboundp cl-symbol) + (not (fboundp symbol))) + (setf (symbol-function symbol) (symbol-function cl-symbol))) + ;; variable + (when (and (not (eq type :variable)) (boundp cl-symbol) + (not (boundp symbol))) + (setf (symbol-value symbol) (symbol-value cl-symbol))) + ;; (setf name) + (when (and (not (eq type :setf)) (fboundp `(setf ,cl-symbol)) + (not (fboundp `(setf ,symbol)))) + (setf (fdefinition `(setf ,symbol)) (fdefinition `(setf ,cl-symbol))))) + t))) + +(defvar *testbed-compile* nil) + +(cl:defmacro defmacro (symbol &rest rest) + "testbed::defmacro" + (let ((name (symbol-name symbol))) + (shadow-cl-symbol name :function) + (cond + ((string= name "DEFINE-CONDITION") + `(cl:defmacro new-define-condition ,@rest)) + (t `(progn + (cl:defmacro ,(intern name) ,@rest) + #-cmu + (when *testbed-compile* + (compile ',(intern name))) ;; cmucl 18e fails + ))))) + +(cl:defmacro define-condition (symbol parent-types &rest rest) + (let ((name (symbol-name symbol))) + (shadow-cl-symbol name :condition) + (if (fboundp 'new-define-condition) + `(new-define-condition ,(intern name) ,parent-types ,@rest) + (progn + (setq parent-types (cond + ((null parent-types) (list (intern "CONDITION"))) + (t parent-types))) + `(cl:define-condition ,(intern name) ,parent-types ,@rest))))) + +(defmacro defvar (symbol &rest rest) + "testbed::defvar" + (let ((name (symbol-name symbol))) + (shadow-cl-symbol name :variable) + `(cl:defvar ,(intern name) ,@rest))) + +(defmacro defun (function-name &rest rest) + "testbed::defun" + (if (symbolp function-name) + (let ((name (symbol-name function-name))) + (shadow-cl-symbol name :function) + `(progn + (cl:defun ,(intern name) ,@rest) + (when *testbed-compile* + (compile ',(intern name))))) + `(cl:defun (setf ,(cadr function-name)) ,@rest))) + +(defmacro defsetf (symbol &rest rest) + "testbed::defsetf" + (let ((name (symbol-name symbol))) + (shadow-cl-symbol name :setf) + (fmakunbound `(setf ,(intern name))) + `(cl:defsetf ,(intern name) ,@rest))) + +(defmacro define-setf-expander (symbol &rest rest) + "testbed::define-setf-expander" + (let ((name (symbol-name symbol))) + (shadow-cl-symbol name :setf) + (fmakunbound `(setf ,(intern name))) + `(cl:define-setf-expander ,(intern name) ,@rest))) + +(defun clone-package-system () + (error "clone-package-system is not defined in testbed.lisp.")) + +(defun ld (name) + (cond + ((string= name "cons") + ;;(shadow '("CONS" "CONSP" "CAR" "CDR")) + ) + ((string= name "hash-table") + (shadow '("HASH-TABLE" "HASH-TABLE-P" "HASH-TABLE-COUNT" + "HASH-TABLE-REHASH-SIZE" "HASH-TABLE-REHASH-THRESHOLD" + "HASH-TABLE-SIZE" "HASH-TABLE-TEST") "TB")) + ((string= name "package") ; needs hash-table + (shadow '("PACKAGE" "PACKAGEP" "MAKE-PACKAGE" "FIND-PACKAGE" + "SHADOWING-IMPORT" "IMPORT" "USE-PACKAGE" "*PACKAGE*" + "DELETE-PACKAGE" "EXPORT") "TB") + (defun symbol-package (symbol) + (get symbol 'symbol-package)) + + (defsetf symbol-package (symbol) (new-package) + `(setf (get ,symbol 'symbol-package) ,new-package)) + ) + ((string= name "loop") ; needs hash-table and package + ) + ((string= name "condition") + (shadow '("CONDITION" + "BREAK" "ASSERT" + "CERROR" "ERROR" "SIGNAL" "WARN" + + "TYPE-ERROR-DATUM" "TYPE-ERROR-EXPECTED-TYPE" + "PACKAGE-ERROR-PACKAGE" "PRINT-NOT-READABLE-OBJECT" + "FILE-ERROR-PATHNAME" "STREAM-ERROR-STREAM" + "CELL-ERROR-NAME" "UNBOUND-SLOT-INSTANCE" + "ARITHMETIC-ERROR-OPERATION" "ARITHMETIC-ERROR-OPERANDS" + "SIMPLE-CONDITION-FORMAT-CONTROL" + "SIMPLE-CONDITION-FORMAT-ARGUMENTS" + + "CHECK-TYPE" "HANDLER-BIND" "HANDLER-CASE" + "INVOKE-RESTART" "RESTART" "MAKE-RESTART" + "RESTART-NAME" "RESTART-FUNCTION" "RESTART-REPORT-FUNCTION" + "RESTART-INTERACTIVE-FUNCTION" "RESTART-TEST-FUNCTION" + "RESTART-CASE" "RESTART-BIND" + "ABORT" "MUFFLE-WARNING" "CONTINUE" "STORE-VALUE" "USE-VALUE" + ) + "TB") + + (eval `(cl:define-condition ,(intern "CONDITION") (cl:condition) ())) + + ) + ((string= name "reader") + (shadow '("READTABLE" "READTABLEP" "READTABLE-CASE" "*READTABLE*" + "READER-ERROR") "TB")) + ((string= name "printer") ; needs reader + (shadow '("PRINT-OBJECT"))) + ((string= name "sequence") + (shadow '("SEARCH"))) + ((string= name "clos") + ) + ) + (let ((*package* (find-package "TESTBED"))) + (funcall #'load (concatenate 'string cl-user::*sacla-lisp-dir* "/" name)) + + (cond + ((string= name "package") + (format t "~%Cloning the package system!~%") + (clone-package-system)) + ((string= name "loop") + ))) + ) + +(defun test (name) + (let ((tests (with-open-file (in (concatenate 'string + cl-user::*sacla-lisp-tests-dir* + "/" name ".lisp")) + (loop for sexp = (read in nil) + while sexp + collect sexp)))) + (format t "Testing ~d tests in ~S~%" (length tests) name) + (do* ((count 1 (1+ count)) + (failed 0) + (skipped 0) + (err nil nil) + (tests tests (cdr tests))) + ((null tests) + (format t "~%All = ~d~%OK = ~d~%Skipped = ~d~%Failed = ~d~%" + (1- count) (- count 1 skipped failed) skipped failed) + (return (zerop failed))) + (format t "~d " count) + (case (handler-case (eval (first tests)) (error (e) (setq err e) nil)) + ((nil) + (format t "Failed : ~S~%" (first tests)) + (when err (print err)) + (incf failed)) + (skipped + (format t "Skipped ") + (incf skipped)))))) diff --git a/Sacla/tests/ansi-tests.lisp b/Sacla/tests/ansi-tests.lisp new file mode 100644 index 0000000..5245a61 --- /dev/null +++ b/Sacla/tests/ansi-tests.lisp @@ -0,0 +1,89 @@ +;; Copyright (C) 2004 Yuji Minejima <ggb01164@nifty.ne.jp> +;; ALL RIGHTS RESERVED. +;; +;; $Id: ansi-tests.lisp,v 1.3 2004/09/28 01:53:23 yuji Exp $ +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; * Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; * Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;;; Commentary: + +;; Support routines for Paul Dietz's ANSI testsuite. +;; +;; When testing loop.lisp, do the following. +;; (load "loop.lisp") +;; (load "tests/ansi-tests.lisp") +;; (in-package "CL-TEST") +;; (shadowing-import '(sacla-loop:loop sacla-loop:loop-finish)) + + +(defpackage "CL-TEST" + (:use "COMMON-LISP")) + +(in-package "CL-TEST") + +(defmacro deftest (name form &rest values) + `(equal (multiple-value-list ,form) ',values)) + + + +;;;; from ansi-aux.lsp of GCL's ANSI-TESTS +;;;; Author: Paul Dietz +;;;; Created: Sat Mar 28 17:10:18 1998 +;;;; License: GPL +(defmacro classify-error* (form) +"Evaluate form in safe mode, returning its value if there is no error. +If an error does occur, return a symbol classify the error, or allow +the condition to go uncaught if it cannot be classified." +`(locally (declare (optimize (safety 3))) + (handler-case ,form + (undefined-function () 'undefined-function) + (program-error () 'program-error) + (package-error () 'package-error) + (type-error () 'type-error) + (control-error () 'control-error) + (stream-error () 'stream-error) + (reader-error () 'reader-error) + (file-error () 'file-error) + (control-error () 'control-error) + (cell-error () 'cell-error) + (error () 'error) + ))) + +(defun classify-error** (form) + (handler-bind ((warning #'(lambda (c) (declare (ignore c)) + (muffle-warning)))) + (classify-error* (eval form)))) + +(defmacro classify-error (form) + `(classify-error** ',form)) + +(defun notnot (x) (not (not x))) +(defun eqlt (x y) + "Like EQL, but guaranteed to return T for true." + (apply #'values (mapcar #'notnot (multiple-value-list (eql x y))))) +(defun equalt (x y) + "Like EQUAL, but guaranteed to return T for true." + (apply #'values (mapcar #'notnot (multiple-value-list (equal x y))))) +(defun symbol< (x &rest args) + (apply #'string< (symbol-name x) (mapcar #'symbol-name args))) diff --git a/Sacla/tests/desirable-printer.lisp b/Sacla/tests/desirable-printer.lisp new file mode 100644 index 0000000..7ccee09 --- /dev/null +++ b/Sacla/tests/desirable-printer.lisp @@ -0,0 +1,223 @@ +;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp> +;; ALL RIGHTS RESERVED. +;; +;; $Id: desirable-printer.lisp,v 1.4 2004/02/20 07:23:42 yuji Exp $ +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; * Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; * Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :upcase) + (string= (write-to-string '|ZEBRA| :pretty nil :readably t :case :upcase) + "ZEBRA")) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :upcase) + (string= (write-to-string '|Zebra| :pretty nil :readably t :case :upcase) + "|Zebra|")) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :upcase) + (string= (write-to-string '|zebra| :pretty nil :readably t :case :upcase) + "|zebra|")) + + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :upcase) + (string= (write-to-string '|ZEBRA| :pretty nil :readably t :case :downcase) + "zebra")) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :upcase) + (string= (write-to-string '|Zebra| :pretty nil :readably t :case :downcase) + "|Zebra|")) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :upcase) + (string= (write-to-string '|zebra| :pretty nil :readably t :case :downcase) + "|zebra|")) + + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :upcase) + (string= (write-to-string '|ZEBRA| :pretty nil :readably t :case :capitalize) + "Zebra")) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :upcase) + (string= (write-to-string '|Zebra| :pretty nil :readably t :case :capitalize) + "|Zebra|")) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :upcase) + (string= (write-to-string '|zebra| :pretty nil :readably t :case :capitalize) + "|zebra|")) + +;; + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :downcase) + (string= (write-to-string '|ZEBRA| :pretty nil :readably t :case :upcase) + "|ZEBRA|")) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :downcase) + (string= (write-to-string '|Zebra| :pretty nil :readably t :case :upcase) + "|Zebra|")) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :downcase) + (string= (write-to-string '|zebra| :pretty nil :readably t :case :upcase) + "ZEBRA")) + + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :downcase) + (string= (write-to-string '|ZEBRA| :pretty nil :readably t :case :downcase) + "|ZEBRA|")) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :downcase) + (string= (write-to-string '|Zebra| :pretty nil :readably t :case :downcase) + "|Zebra|")) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :downcase) + (string= (write-to-string '|zebra| :pretty nil :readably t :case :downcase) + "zebra")) + + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :downcase) + (string= (write-to-string '|ZEBRA| :pretty nil :readably t :case :capitalize) + "|ZEBRA|")) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :downcase) + (string= (write-to-string '|Zebra| :pretty nil :readably t :case :capitalize) + "|Zebra|")) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :downcase) + (string= (write-to-string '|zebra| :pretty nil :readably t :case :capitalize) + "Zebra")) + + +;; +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :preserve) + (string= (write-to-string '|ZEBRA| :pretty nil :readably t :case :upcase) + "ZEBRA")) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :preserve) + (string= (write-to-string '|Zebra| :pretty nil :readably t :case :upcase) + "Zebra")) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :preserve) + (string= (write-to-string '|zebra| :pretty nil :readably t :case :upcase) + "zebra")) + + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :preserve) + (string= (write-to-string '|ZEBRA| :pretty nil :readably t :case :downcase) + "ZEBRA")) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :preserve) + (string= (write-to-string '|Zebra| :pretty nil :readably t :case :downcase) + "Zebra")) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :preserve) + (string= (write-to-string '|zebra| :pretty nil :readably t :case :downcase) + "zebra")) + + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :preserve) + (string= (write-to-string '|ZEBRA| :pretty nil :readably t :case :capitalize) + "ZEBRA")) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :preserve) + (string= (write-to-string '|Zebra| :pretty nil :readably t :case :capitalize) + "Zebra")) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :preserve) + (string= (write-to-string '|zebra| :pretty nil :readably t :case :capitalize) + "zebra")) + + +;; +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :invert) + (string= (write-to-string '|ZEBRA| :pretty nil :readably t :case :upcase) + "zebra")) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :invert) + (string= (write-to-string '|Zebra| :pretty nil :readably t :case :upcase) + "Zebra")) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :invert) + (string= (write-to-string '|zebra| :pretty nil :readably t :case :upcase) + "ZEBRA")) + + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :invert) + (string= (write-to-string '|ZEBRA| :pretty nil :readably t :case :downcase) + "zebra")) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :invert) + (string= (write-to-string '|Zebra| :pretty nil :readably t :case :downcase) + "Zebra")) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :invert) + (string= (write-to-string '|zebra| :pretty nil :readably t :case :downcase) + "ZEBRA")) + + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :invert) + (string= (write-to-string '|ZEBRA| :pretty nil :readably t :case :capitalize) + "zebra")) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :invert) + (string= (write-to-string '|Zebra| :pretty nil :readably t :case :capitalize) + "Zebra")) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :invert) + (string= (write-to-string '|zebra| :pretty nil :readably t :case :capitalize) + "ZEBRA")) + + diff --git a/Sacla/tests/must-array.lisp b/Sacla/tests/must-array.lisp new file mode 100644 index 0000000..205f577 --- /dev/null +++ b/Sacla/tests/must-array.lisp @@ -0,0 +1,2297 @@ +;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp> +;; ALL RIGHTS RESERVED. +;; +;; $Id: must-array.lisp,v 1.9 2004/08/09 02:49:54 yuji Exp $ +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; * Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; * Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(arrayp (make-array nil)) +(arrayp (make-array 10)) +(vectorp (make-array 10)) +(arrayp (make-array '(1 2))) +(arrayp (make-array '(1 2 3))) +(arrayp (make-array '(1 2 3 4))) +(arrayp (make-array '(1 2 3 4 5))) +(arrayp (make-array '(3 3 3))) +(arrayp (make-array '(3 0 3))) +(arrayp (make-array '5 :element-type 'character :displaced-to "array")) +(arrayp "") +(arrayp "array") +(arrayp (make-array '(2 3 4) :adjustable t)) +(arrayp (make-array 6)) +(arrayp #*1011) +(arrayp "hi") +(not (arrayp 'hi)) +(not (arrayp 12)) + + + +(let ((array (make-array '(2 3) :initial-contents '((0 1 2) (3 4 5))))) + (and (eql (aref array 0 0) 0) + (eql (aref array 0 1) 1) + (eql (aref array 0 2) 2) + (eql (aref array 1 0) 3) + (eql (aref array 1 1) 4) + (eql (aref array 1 2) 5))) + +(let ((array (make-array '(3 2 1) + :initial-contents '(((0) (1)) ((2) (3)) ((4) (5)))))) + (and (eql (aref array 0 0 0) 0) + (eql (aref array 0 1 0) 1) + (eql (aref array 1 0 0) 2) + (eql (aref array 1 1 0) 3) + (eql (aref array 2 0 0) 4) + (eql (aref array 2 1 0) 5))) + +(let ((array (make-array '(2 2 2 2) + :initial-contents + '((((0 1) (2 3)) ((4 5) (6 7))) + (((8 9) (10 11)) ((12 13) (14 15))))))) + (and (eql (aref array 0 0 0 0) 0) + (eql (aref array 0 0 0 1) 1) + (eql (aref array 0 0 1 0) 2) + (eql (aref array 0 0 1 1) 3) + (eql (aref array 0 1 0 0) 4) + (eql (aref array 0 1 0 1) 5) + (eql (aref array 0 1 1 0) 6) + (eql (aref array 0 1 1 1) 7) + (eql (aref array 1 0 0 0) 8) + (eql (aref array 1 0 0 1) 9) + (eql (aref array 1 0 1 0) 10) + (eql (aref array 1 0 1 1) 11) + (eql (aref array 1 1 0 0) 12) + (eql (aref array 1 1 0 1) 13) + (eql (aref array 1 1 1 0) 14) + (eql (aref array 1 1 1 1) 15))) + +(let ((array (make-array '(3 3 3 3 3 3) :initial-element nil))) + (dotimes (i 729) + (setf (row-major-aref array i) i)) + (dotimes (i 729 t) + (unless (= (aref array + (floor i (* 3 3 3 3 3)) + (floor (mod i (* 3 3 3 3 3)) (* 3 3 3 3)) + (floor (mod i (* 3 3 3 3)) (* 3 3 3)) + (floor (mod i (* 3 3 3)) (* 3 3)) + (floor (mod i (* 3 3)) (* 3)) + (mod i 3)) + i) + (return nil)))) + + +(zerop (aref (make-array '() :initial-contents 0))) +(let ((array (make-array 10 :initial-contents '(0 1 2 3 4 5 6 7 8 9))) + (ok t)) + (dotimes (i 10) + (unless (eql (aref array i) i) + (setq ok nil) + (return))) + ok) + +(let ((array (vector 0 1 2 3 4 5 6 7 8 9)) + (ok t)) + (dotimes (i 10) + (unless (eql (aref array i) i) + (setq ok nil) + (return))) + ok) + +(let ((array "0123456789") + (ok t)) + (dotimes (i 10) + (unless (char= (aref array i) (char "0123456789" i)) + (setq ok nil) + (return))) + ok) + + +(let ((array (make-array '(2 3) :initial-contents '((0 1 2) (3 4 5))))) + (equal (array-dimensions array) '(2 3))) + +(equal (array-dimensions (make-array 4)) '(4)) +(equal (array-dimensions (make-array '(2 3))) '(2 3)) +(equal (array-dimensions (make-array 4 :fill-pointer 2)) '(4)) +(equal (array-dimensions (make-array '(2 3 4 5 6))) '(2 3 4 5 6)) + +(eql (array-dimension (make-array 4) 0) 4) +(eql (array-dimension (make-array '(2 3)) 1) 3) +(eql (array-dimension (make-array '(2 3 4)) 2) 4) + +(eq (array-element-type (make-array 4)) t) +(equal (array-element-type (make-array 12 :element-type '(unsigned-byte 8))) + (upgraded-array-element-type '(unsigned-byte 8))) + + +(let ((array (make-array '()))) + (multiple-value-bind (displaced-to displaced-index-offset) + (array-displacement array) + (and (not displaced-to) + (zerop displaced-index-offset)))) + +(let ((array (make-array '10))) + (multiple-value-bind (displaced-to displaced-index-offset) + (array-displacement array) + (and (not displaced-to) + (zerop displaced-index-offset)))) + +(let ((array (make-array '(2 3) :initial-contents '((0 1 2) (3 4 5))))) + (multiple-value-bind (displaced-to displaced-index-offset) + (array-displacement array) + (and (not displaced-to) + (zerop displaced-index-offset)))) + +(let* ((source (make-array '(2 5) + :initial-contents '((1 2 3 4 5) (11 12 13 14 15)))) + (array (make-array 10 :displaced-to source))) + (multiple-value-bind (displaced-to displaced-index-offset) + (array-displacement array) + (and (eq displaced-to source) + (zerop displaced-index-offset)))) + +(let* ((source (make-array '10 :initial-element 0)) + (array (make-array '(5 2) :displaced-to source))) + (multiple-value-bind (displaced-to displaced-index-offset) + (array-displacement array) + (and (eq displaced-to source) + (zerop displaced-index-offset)))) + +(let* ((e0-0 (list 0 0)) + (e0-1 (list 0 1)) + (e1-0 (list 1 0)) + (e1-1 (list 1 1)) + (source (make-array '(2 2) + :initial-contents (list (list e0-0 e0-1) + (list e1-0 e1-1)))) + (array (make-array 4 :displaced-to source))) + (multiple-value-bind (displaced-to displaced-index-offset) + (array-displacement array) + (and (eq displaced-to source) + (zerop displaced-index-offset) + (eq (aref array 0) e0-0) + (eq (aref array 1) e0-1) + (eq (aref array 2) e1-0) + (eq (aref array 3) e1-1)))) + + +(let* ((e0-0 (list 0 0)) + (e0-1 (list 0 1)) + (e1-0 (list 1 0)) + (e1-1 (list 1 1)) + (source (make-array '(2 2) + :initial-contents (list (list e0-0 e0-1) + (list e1-0 e1-1)))) + (array (make-array 2 :displaced-to source :displaced-index-offset 1))) + (multiple-value-bind (displaced-to displaced-index-offset) + (array-displacement array) + (and (eq displaced-to source) + (eql displaced-index-offset 1) + (eq (aref array 0) e0-1) + (eq (aref array 1) e1-0)))) + +(let ((array (make-array 4 + :element-type 'character + :displaced-to "0123456789" + :displaced-index-offset 6))) + (multiple-value-bind (displaced-to displaced-index-offset) + (array-displacement array) + (and (string= displaced-to "0123456789") + (eql displaced-index-offset 6) + (eql (aref array 0) #\6) + (eql (aref array 1) #\7) + (eql (aref array 2) #\8) + (eql (aref array 3) #\9)))) + +(let ((array (make-array '(1 2 5) + :element-type 'character + :displaced-to "0123456789"))) + (multiple-value-bind (displaced-to displaced-index-offset) + (array-displacement array) + (and (string= displaced-to "0123456789") + (eql displaced-index-offset 0) + (eql (aref array 0 0 0) #\0) + (eql (aref array 0 0 1) #\1) + (eql (aref array 0 0 2) #\2) + (eql (aref array 0 0 3) #\3) + (eql (aref array 0 0 4) #\4) + (eql (aref array 0 1 0) #\5) + (eql (aref array 0 1 1) #\6) + (eql (aref array 0 1 2) #\7) + (eql (aref array 0 1 3) #\8) + (eql (aref array 0 1 4) #\9)))) + +(let* ((source (make-array '(2 5) + :initial-contents '("love&" "peace") + :element-type 'character)) + (array (make-array 10 :displaced-to source :element-type 'character))) + (multiple-value-bind (displaced-to displaced-index-offset) + (array-displacement array) + (and (eq displaced-to source) + (eql displaced-index-offset 0) + (string= array "love&peace")))) + +(array-in-bounds-p (make-array 5) 4) +(not (array-in-bounds-p (make-array 5) -1)) +(let ((a (make-array '(7 11) :element-type 'string-char))) + (and (array-in-bounds-p a 0 0) + (array-in-bounds-p a 6 10) + (not (array-in-bounds-p a 0 -1)) + (not (array-in-bounds-p a 0 11)) + (not (array-in-bounds-p a 7 0)))) + + + + +(let ((array (make-array '(2 3) :initial-contents '((0 1 2) (3 4 5))))) + (eql (array-rank array) 2)) + +(zerop (array-rank (make-array '()))) +(eql (array-rank (make-array 10)) 1) +(eql (array-rank (make-array '(2 10))) 2) +(eql (array-rank (make-array '(2 10 1))) 3) +(eql (array-rank (make-array '(2 10 1 3))) 4) +(eql (array-rank "") 1) +(eql (array-rank "a") 1) + +(zerop (array-row-major-index (make-array '()))) +(zerop (array-row-major-index (make-array '5) 0)) +(eql (array-row-major-index (make-array '5) 4) 4) +(eql (array-row-major-index (make-array '10) 3) 3) +(zerop (array-row-major-index (make-array '(3 4)) 0 0)) +(eql (array-row-major-index (make-array '(3 4)) 2 3) 11) +(zerop (array-row-major-index (make-array '(3 4 5)) 0 0 0)) +(eql (array-row-major-index (make-array '(3 4 5)) 2 3 4) 59) + + +(let ((array (make-array '(2 3) :initial-contents '((0 1 2) (3 4 5))))) + (eql (array-total-size array) 6)) + +(eql (array-total-size (make-array 4)) 4) +(eql (array-total-size (make-array 4 :fill-pointer 2)) 4) +(eql (array-total-size (make-array 0)) 0) +(eql (array-total-size (make-array '(4 2))) 8) +(eql (array-total-size (make-array '(4 0))) 0) +(eql (array-total-size (make-array '())) 1) +(eql (array-total-size (make-array '(2 3 4 5))) (* 2 3 4 5)) + + +(let ((array (make-array 10 + :initial-contents '(0 1 2 3 4 5 6 7 8 9) + :fill-pointer 0))) + (dotimes (i 10 t) + (unless (eql (aref array i) i) + (return nil)))) + +(let ((array (make-array '(10 10) :element-type 'number :initial-element 0))) + (dotimes (i 10) + (dotimes (j 10) + (unless (zerop (aref array i j)) + (return nil)) + (setf (aref array i j) (+ (* i 10) j)))) + (dotimes (i 100 t) + (unless (eql (row-major-aref array i) i) + (return nil)))) + +(let ((array (make-array '()))) + (setf (aref array) 100) + (eql (aref array) 100)) + +(let ((array (make-array 10 :initial-contents '(a b c d e f g h i j)))) + (setf (aref array 0) #\a) + (setf (aref array 2) #\c) + (setf (aref array 4) #\e) + (setf (aref array 6) #\g) + (setf (aref array 8) #\i) + (and (eql (aref array 0) #\a) (eql (aref array 1) 'b) + (eql (aref array 2) #\c) (eql (aref array 3) 'd) + (eql (aref array 4) #\e) (eql (aref array 5) 'f) + (eql (aref array 6) #\g) (eql (aref array 7) 'h) + (eql (aref array 8) #\i) (eql (aref array 9) 'j))) + +(let ((array (vector 'a 'b 'c 'd 'e 'f 'g 'h 'i 'j))) + (setf (aref array 0) #\a) + (setf (aref array 2) #\c) + (setf (aref array 4) #\e) + (setf (aref array 6) #\g) + (setf (aref array 8) #\i) + (and (eql (aref array 0) #\a) (eql (aref array 1) 'b) + (eql (aref array 2) #\c) (eql (aref array 3) 'd) + (eql (aref array 4) #\e) (eql (aref array 5) 'f) + (eql (aref array 6) #\g) (eql (aref array 7) 'h) + (eql (aref array 8) #\i) (eql (aref array 9) 'j))) + +(let ((array (make-array '(3 4 5) :initial-element 0 :element-type 'number))) + (setf (aref array 0 0 0) 0) + (setf (aref array 1 1 1) 1) + (setf (aref array 2 2 2) 2) + (dotimes (i 3 t) + (unless (eql (aref array i i i) i) + (return nil)))) + +(let* ((array (make-array '(3 4 5 6 7) + :initial-element 0 :element-type 'number)) + (array2 (make-array (* 3 4 5 6 7) :displaced-to array))) + (setf (aref array 2 3 4 5 6) 100) + (setf (aref array 0 0 0 0 0) 200) + (eql (reduce #'+ array2) 300)) + +(adjustable-array-p (make-array 5 + :element-type 'character + :adjustable t + :fill-pointer 3)) + +(let ((array (adjust-array (make-array '(2 3) + :initial-contents '((0 1 2) (3 4 5)) + :adjustable t) + '(3 2) :initial-element 'undefined))) + (and (eql (aref array 0 0) 0) + (eql (aref array 0 1) 1) + (eql (aref array 1 0) 3) + (eql (aref array 1 1) 4) + (eql (aref array 2 0) 'undefined) + (eql (aref array 2 1) 'undefined))) + +(let ((array (adjust-array (make-array '(2 3) + :initial-contents '((0 1 2) (3 4 5)) + :adjustable t) + '(3 2) :initial-element 'undefined))) + (equal (array-dimensions array) '(3 2))) + +(let ((array (adjust-array (make-array '(2 3) + :initial-contents '((0 1 2) (3 4 5)) + :adjustable t) + '(3 2) :initial-element 'undefined))) + (not (array-has-fill-pointer-p array))) + +(let ((array (make-array '(2 3) :initial-contents '((0 1 2) (3 4 5))))) + (not (array-has-fill-pointer-p array))) + +(array-has-fill-pointer-p (make-array 10 :fill-pointer 0)) +(array-has-fill-pointer-p (make-array 8 :fill-pointer 0 :initial-element 8)) +(not (array-has-fill-pointer-p (make-array '(2 3 4)))) + + + +(let ((array (adjust-array (make-array '(2 3) + :initial-contents '((0 1 2) (3 4 5)) + :adjustable t) + '(3 2) :initial-element 'undefined))) + (multiple-value-bind (displaced-to displaced-index-offset) + (array-displacement array) + (and (not displaced-to) + (zerop displaced-index-offset)))) + +(let ((array (adjust-array (make-array '(2 3) + :initial-contents '((0 1 2) (3 4 5)) + :adjustable t) + '(3 2) :initial-element 'undefined))) + (eql (array-rank array) 2)) + +(let ((array (adjust-array (make-array '(2 3) + :initial-contents '((0 1 2) (3 4 5)) + :adjustable t) + '(3 2) :initial-element 'undefined))) + (eql (array-total-size array) 6)) + + +(eql (fill-pointer (make-array 8 :fill-pointer 4)) 4) +(let ((array (make-array 8 :fill-pointer 4 :initial-element nil))) + (and (eql (length array) 4) + (setf (fill-pointer array) 3) + (eql (fill-pointer array) 3) + (eql (length array) 3))) + +(let ((vector (make-array 10 + :fill-pointer 0 + :initial-element #\Space + :element-type 'character))) + (and (eql (vector-push #\a vector) 0) + (eql (vector-push #\b vector) 1) + (eql (vector-push #\c vector) 2) + (string= vector "abc"))) + +(let ((vector (make-array 3 :fill-pointer t :initial-contents '(a b c)))) + (and (eql (array-dimension vector 0) (fill-pointer vector)) + (equal (concatenate 'list vector) '(a b c)) + (zerop (setf (fill-pointer vector) 0)) + (null (concatenate 'list vector)) + (eql (vector-push 'x vector) 0) + (equal (concatenate 'list vector) '(x)) + (eq (vector-pop vector) 'x) + (zerop (length vector)))) + +(let ((vector (make-array 10 :fill-pointer 0 :initial-element nil))) + (and (eql (length vector) 0) + (setf (fill-pointer vector) 10) + (eql (length vector) 10) + (setf (fill-pointer vector) 5) + (eql (length vector) 5))) + + +(let ((array (make-array '(3 2 1) + :initial-contents '(((0) (1)) ((2) (3)) ((4) (5)))))) + (and (eql (aref array 0 0 0) (row-major-aref array 0)) + (eql (aref array 0 1 0) (row-major-aref array 1)) + (eql (aref array 1 0 0) (row-major-aref array 2)) + (eql (aref array 1 1 0) (row-major-aref array 3)) + (eql (aref array 2 0 0) (row-major-aref array 4)) + (eql (aref array 2 1 0) (row-major-aref array 5)))) + +(let ((array (make-array '(3 2 1) + :initial-contents '(((0) (1)) ((2) (3)) ((4) (5)))))) + (and (eql 0 (row-major-aref array 0)) + (eql 1 (row-major-aref array 1)) + (eql 2 (row-major-aref array 2)) + (eql 3 (row-major-aref array 3)) + (eql 4 (row-major-aref array 4)) + (eql 5 (row-major-aref array 5)))) + + +(let* ((array0 (make-array '(3 2 1) + :initial-contents '(((0) (1)) ((2) (3)) ((4) (5))))) + (array1 (make-array 6 :displaced-to array0))) + (and (eql (aref array1 0) (row-major-aref array0 0)) + (eql (aref array1 1) (row-major-aref array0 1)) + (eql (aref array1 2) (row-major-aref array0 2)) + (eql (aref array1 3) (row-major-aref array0 3)) + (eql (aref array1 4) (row-major-aref array0 4)) + (eql (aref array1 5) (row-major-aref array0 5)))) + +(let* ((array0 (make-array 6 + :element-type 'character + :initial-contents "abcdef")) + (array1 (make-array '(3 2 1) + :displaced-to array0 + :element-type 'character))) + (and (eql (aref array0 0) (row-major-aref array1 0)) + (eql (aref array0 1) (row-major-aref array1 1)) + (eql (aref array0 2) (row-major-aref array1 2)) + (eql (aref array0 3) (row-major-aref array1 3)) + (eql (aref array0 4) (row-major-aref array1 4)) + (eql (aref array0 5) (row-major-aref array1 5)))) + +(let* ((array0 (make-array 6 + :element-type 'character + :initial-contents "abcdef")) + (array1 (make-array '(3 2 1) + :displaced-to array0 + :element-type 'character))) + (and (eql #\a (row-major-aref array1 0)) + (eql #\b (row-major-aref array1 1)) + (eql #\c (row-major-aref array1 2)) + (eql #\d (row-major-aref array1 3)) + (eql #\e (row-major-aref array1 4)) + (eql #\f (row-major-aref array1 5)))) + +(let ((array (make-array '(3 2 1) :initial-element nil))) + (setf (row-major-aref array 0) 'a) + (setf (row-major-aref array 1) 'b) + (setf (row-major-aref array 2) 'c) + (setf (row-major-aref array 3) 'd) + (setf (row-major-aref array 4) 'e) + (and (eql (aref array 0 0 0) 'a) + (eql (aref array 0 1 0) 'b) + (eql (aref array 1 0 0) 'c) + (eql (aref array 1 1 0) 'd) + (eql (aref array 2 0 0) 'e) + (eql (aref array 2 1 0) 'nil))) + +(let ((str "abcdefg")) + (dotimes (i 7 t) + (unless (eql (char str 0) (row-major-aref str 0)) + (return nil)))) + +(let ((str (make-array 5 :initial-contents "abcde"))) + (dotimes (i 3) + (setf (row-major-aref str i) (row-major-aref str (- 4 i)))) + (and (char= (row-major-aref str 0) #\e) + (char= (row-major-aref str 1) #\d) + (char= (row-major-aref str 2) #\c) + (char= (row-major-aref str 3) #\d) + (char= (row-major-aref str 4) #\e))) + + +(eq (upgraded-array-element-type t) t) +(and (subtypep (upgraded-array-element-type 'bit) 'bit) + (subtypep 'bit (upgraded-array-element-type 'bit))) +(and (subtypep (upgraded-array-element-type 'base-char) 'base-char) + (subtypep 'base-char (upgraded-array-element-type 'base-char))) +(and (subtypep (upgraded-array-element-type 'character) 'character) + (subtypep 'character (upgraded-array-element-type 'character))) + + +(simple-vector-p (make-array 6)) +(not (simple-vector-p "aaaaaa")) + +(let ((sv (make-array 10))) + (dotimes (i 10) + (setf (svref sv i) (* i i))) + (dotimes (i 10 t) + (unless (eql (svref sv i) (* i i)) + (return nil)))) + +(let ((sv (vector 'a 'b 'c 'd 'e 'f))) + (and (eq (svref sv 0) 'a) + (eq (svref sv 1) 'b) + (eq (svref sv 2) 'c) + (eq (svref sv 3) 'd) + (eq (svref sv 4) 'e) + (eq (svref sv 5) 'f))) + +(let ((sv (make-array 3 :initial-contents '(1 2 last)))) + (and (simple-vector-p sv) + (eq (svref sv 2) 'last) + (eql (svref sv 1) 2) + (eql (svref sv 0) 1) + (eql (setf (svref sv 1) 'last-but-one) 'last-but-one) + (eq (svref sv 1) 'last-but-one))) + + +(let ((vec (vector 1 2 'last))) + (and (arrayp vec) + (vectorp vec) + (simple-vector-p vec) + (eql (length vec) 3) + (equal (concatenate 'list vec) '(1 2 last)))) + +(eq (vector-pop (make-array 3 :initial-contents '(a b c) :fill-pointer t)) 'c) +(eq (vector-pop (make-array 3 :initial-contents '(a b c) :fill-pointer 3)) 'c) +(eq (vector-pop (make-array 3 :initial-contents '(a b c) :fill-pointer 2)) 'b) +(eq (vector-pop (make-array 3 :initial-contents '(a b c) :fill-pointer 1)) 'a) + +(let ((vec (make-array 3 :fill-pointer 0))) + (and (eql (vector-push 'a vec) 0) + (eql (vector-push 'b vec) 1) + (eql (vector-push 'c vec) 2) + (eq (vector-pop vec) 'c) + (eq (vector-pop vec) 'b) + (eq (vector-pop vec) 'a))) + +(let ((vec (make-array 3 :fill-pointer t :initial-contents '(a b c)))) + (and (setf (fill-pointer vec) 1) + (eql (vector-push 'y vec) 1) + (eql (vector-push 'z vec) 2) + (eq (vector-pop vec) 'z) + (eq (vector-pop vec) 'y) + (eq (vector-pop vec) 'a) + (eql (fill-pointer vec) 0))) + +(let ((vec (make-array 3 :fill-pointer t :initial-contents '(a b c)))) + (and (not (vector-push 'x vec)) + (not (vector-push 'y vec)) + (eql (setf (fill-pointer vec) 0) 0) + (eql (vector-push 'x vec) 0) + (eql (vector-push 'y vec) 1) + (eql (vector-push 'z vec) 2) + (not (vector-push 'l vec)))) + + + +(let ((vec (make-array 3 + :fill-pointer 2 + :initial-contents '(a b l) + :adjustable t))) + (and (eql (length vec) 2) + (eql (vector-push-extend 'c vec) 2) + (eql (length vec) 3) + (eq (vector-pop vec) 'c) + (eql (vector-push-extend 'c vec) 2) + (eql (vector-push-extend 'x vec) 3) + (eql (vector-push-extend 'y vec) 4) + (eql (vector-push-extend 'z vec) 5) + (eql (length vec) 6))) + + +(let ((vec (make-array 0 + :fill-pointer t + :adjustable t))) + (dotimes (i 50) + (vector-push-extend (* i i) vec)) + (dotimes (i 50 t) + (unless (eql (vector-pop vec) (* (- 49 i) (- 49 i))) + (return nil)))) + +(let ((vec (make-array 10 + :element-type 'character + :initial-contents "abcdefghij" + :adjustable t + :fill-pointer t))) + (and (eql (vector-push-extend #\x vec) 10) + (eql (vector-push-extend #\y vec) 11) + (eql (vector-push-extend #\z vec) 12) + (string= vec "abcdefghijxyz"))) + +(vectorp "aaaaaa") +(vectorp (make-array 6 :fill-pointer t)) +(not (vectorp (make-array '(2 3 4)))) +(vectorp #*11) +(not (vectorp #b11)) +(vectorp (make-array 3 :displaced-to "abc" :element-type 'character)) + +(eql (bit (make-array 8 :element-type 'bit :initial-element 1) 3) + 1) +(eql (sbit (make-array 8 :element-type 'bit :initial-element 1) 3) + 1) + +(let ((ba (make-array 8 + :element-type 'bit + :initial-contents '(0 1 0 1 0 1 0 1)))) + (dotimes (i 8 t) + (unless (or (and (evenp i) (zerop (bit ba i))) + (and (oddp i) (eql (bit ba i) 1))) + (return nil)))) + +(let ((ba (make-array 8 + :element-type 'bit + :initial-contents '(0 1 0 1 0 1 0 1)))) + (dotimes (i 8 t) + (unless (or (and (evenp i) (zerop (sbit ba i))) + (and (oddp i) (eql (sbit ba i) 1))) + (return nil)))) + +(let ((ba (make-array '(3 3) + :element-type 'bit + :initial-contents '((0 1 0) (1 0 1) (0 1 0))))) + (and (zerop (bit ba 0 0)) + (eql (bit ba 0 1) 1) + (zerop (bit ba 0 2)) + (eql (bit ba 1 0) 1) + (zerop (bit ba 1 1)) + (eql (bit ba 1 2) 1) + (zerop (bit ba 2 0)) + (eql (bit ba 2 1) 1) + (zerop (bit ba 2 2)))) + +(let ((ba (make-array '(3 3) + :element-type 'bit + :initial-contents '((0 1 0) (1 0 1) (0 1 0))))) + (and (zerop (sbit ba 0 0)) + (eql (sbit ba 0 1) 1) + (zerop (sbit ba 0 2)) + (eql (sbit ba 1 0) 1) + (zerop (sbit ba 1 1)) + (eql (sbit ba 1 2) 1) + (zerop (sbit ba 2 0)) + (eql (sbit ba 2 1) 1) + (zerop (sbit ba 2 2)))) + +(let ((ba (make-array '(3 3 3) :element-type 'bit))) + (dotimes (i (* 3 3 3)) + (setf (bit ba + (floor i 9) + (floor (mod i 9) 3) + (mod i 3)) + (if (evenp i) 0 1))) + (dotimes (i (* 3 3 3) t) + (unless (eql (row-major-aref ba i) (if (evenp i) 0 1)) + (return nil)))) + +(let ((ba (make-array '(3 3 3) :element-type 'bit))) + (dotimes (i (* 3 3 3)) + (setf (sbit ba + (floor i 9) + (floor (mod i 9) 3) + (mod i 3)) + (if (evenp i) 0 1))) + (dotimes (i (* 3 3 3) t) + (unless (eql (row-major-aref ba i) (if (evenp i) 0 1)) + (return nil)))) + +(let ((ba (make-array '(1 2 3 4 5) :element-type 'bit))) + (dotimes (i (* 1 2 3 4 5)) + (setf (bit ba + (floor i (* 1 2 3 4 5)) + (floor (mod i (* 2 3 4 5)) (* 3 4 5)) + (floor (mod i (* 3 4 5)) (* 4 5)) + (floor (mod i (* 4 5)) 5) + (mod i 5)) + (if (evenp i) 0 1))) + (dotimes (i (* 1 2 3 4 5) t) + (unless (eql (row-major-aref ba i) (if (evenp i) 0 1)) + (return nil)))) + +(let ((ba (make-array '(1 2 3 4 5) :element-type 'bit))) + (dotimes (i (* 1 2 3 4 5)) + (setf (sbit ba + (floor i (* 1 2 3 4 5)) + (floor (mod i (* 2 3 4 5)) (* 3 4 5)) + (floor (mod i (* 3 4 5)) (* 4 5)) + (floor (mod i (* 4 5)) 5) + (mod i 5)) + (if (evenp i) 0 1))) + (dotimes (i (* 1 2 3 4 5) t) + (unless (eql (row-major-aref ba i) (if (evenp i) 0 1)) + (return nil)))) + +(let ((ba (make-array 8 :element-type 'bit :initial-element 1))) + (and (eql (setf (bit ba 3) 0) 0) + (eql (bit ba 3) 0) + (eql (sbit ba 5) 1) + (eql (setf (sbit ba 5) 0) 0) + (eql (sbit ba 5) 0))) + + +(let ((ba (make-array 10 :element-type 'bit :fill-pointer 0))) + (dotimes (i 10) + (vector-push (if (oddp i) 0 1) ba)) + (dotimes (i 10 t) + (unless (and (eql (bit ba i) (if (oddp i) 0 1)) + (or (not (simple-vector-p ba)) + (eql (sbit ba i) (if (oddp i) 0 1))) + (eql (aref ba i) (if (oddp i) 0 1))) + (return nil)))) + +(let ((ba (make-array 10 :element-type 'bit :fill-pointer 0))) + (dotimes (i 10) + (vector-push (if (oddp i) 0 1) ba)) + (dotimes (j 10 t) + (let ((i (- 9 j))) + (unless (and (eql (bit ba i) (if (oddp i) 0 1)) + (or (not (simple-vector-p ba)) + (eql (sbit ba i) (if (oddp i) 0 1))) + (eql (aref ba i) (if (oddp i) 0 1)) + (eql (vector-pop ba) (if (oddp i) 0 1))) + (return nil))))) + + +(equal (bit-and #*11101010 #*01101011) #*01101010) +(equal (bit-and #*11101010 #*01101011 nil) #*01101010) +(equal (bit-and (make-array 8 :element-type 'bit :initial-contents #*11101010) + #*01101011 t) + #*01101010) +(equal (bit-and #*11101010 + #*01101011 + (make-array 8 :element-type 'bit)) + #*01101010) + +(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*11101010)) + (ba2 (make-array 8 :element-type 'bit :initial-contents #*01101011)) + (ba (bit-and ba1 ba2))) + (and (not (eq ba1 ba)) + (not (eq ba2 ba)) + (not (eq ba1 ba2)) + (equal ba #*01101010))) + +(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01010101)) + (ba (bit-and ba1 #*10101010 t))) + (and (eq ba1 ba) + (equal ba1 #*00000000))) + +(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01110001)) + (ba (bit-and ba1 #*00111110 t))) + (and (eq ba1 ba) + (equal ba1 #*00110000))) + +(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01110001)) + (ba2 (make-array 8 :element-type 'bit :initial-contents #*00111110)) + (ba3 (make-array 8 :element-type 'bit)) + (ba4 (bit-and ba1 ba2 ba3))) + (and (eq ba3 ba4) + (equal ba3 #*00110000) + (not (eq ba1 ba3)) + (not (eq ba1 ba4)) + (not (eq ba2 ba3)) + (not (eq ba2 ba4)))) + +(equalp (bit-and (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101)) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010))) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*000 #*000))) + +(equalp (bit-and (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101)) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010)) + nil) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*000 #*000))) + + +(equalp (bit-and (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101)) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010)) + t) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*000 #*000))) + +(equalp (bit-and (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101)) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010)) + (make-array '(2 3) + :element-type 'bit)) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*000 #*000))) + +(let* ((ba1 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101))) + (ba2 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010))) + (ba (bit-and ba1 ba2))) + (and (not (eq ba1 ba)) + (not (eq ba2 ba)) + (not (eq ba1 ba2)) + (equalp ba (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*000 #*000))))) + + +(let* ((ba1 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101))) + (ba2 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010))) + (ba (bit-and ba1 ba2 t))) + (and (eq ba1 ba) + (equalp ba1 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*000 #*000))))) + + +(let* ((ba1 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101))) + (ba2 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010))) + (ba3 (make-array '(2 3) + :element-type 'bit)) + (ba4 (bit-and ba1 ba2 ba3))) + (and (eq ba3 ba4) + (equalp ba3 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*000 #*000))) + (not (eq ba1 ba3)) + (not (eq ba1 ba4)) + (not (eq ba2 ba3)) + (not (eq ba2 ba4)))) + + +(equal (bit-andc1 #*11101010 #*01101011) #*00000001) +(equal (bit-andc1 #*11101010 #*01101011 nil) #*00000001) +(equal (bit-andc1 (make-array 8 :element-type 'bit :initial-contents #*11101010) + #*01101011 t) + #*00000001) +(equal (bit-andc1 #*11101010 + #*01101011 + (make-array 8 :element-type 'bit)) + #*00000001) + +(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*11101010)) + (ba2 (make-array 8 :element-type 'bit :initial-contents #*01101011)) + (ba (bit-andc1 ba1 ba2))) + (and (not (eq ba1 ba)) + (not (eq ba2 ba)) + (not (eq ba1 ba2)) + (equal ba #*00000001))) + +(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01010101)) + (ba (bit-andc1 ba1 #*10101010 t))) + (and (eq ba1 ba) + (equal ba1 #*10101010))) + +(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01110001)) + (ba (bit-andc1 ba1 #*00111110 t))) + (and (eq ba1 ba) + (equal ba1 #*00001110))) + +(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01110001)) + (ba2 (make-array 8 :element-type 'bit :initial-contents #*00111110)) + (ba3 (make-array 8 :element-type 'bit)) + (ba4 (bit-andc1 ba1 ba2 ba3))) + (and (eq ba3 ba4) + (equal ba3 #*00001110) + (not (eq ba1 ba3)) + (not (eq ba1 ba4)) + (not (eq ba2 ba3)) + (not (eq ba2 ba4)))) + +(equalp (bit-andc1 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101)) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010))) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010))) + +(equalp (bit-andc1 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101)) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010)) + nil) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010))) + +(equalp (bit-andc1 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101)) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010)) + t) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010))) + +(equalp (bit-andc1 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101)) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010)) + (make-array '(2 3) + :element-type 'bit)) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010))) + +(let* ((ba1 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101))) + (ba2 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010))) + (ba (bit-andc1 ba1 ba2))) + (and (not (eq ba1 ba)) + (not (eq ba2 ba)) + (not (eq ba1 ba2)) + (equalp ba (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010))))) + +(let* ((ba1 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101))) + (ba2 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010))) + (ba (bit-andc1 ba1 ba2 t))) + (and (eq ba1 ba) + (equalp ba1 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010))))) + +(let* ((ba1 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101))) + (ba2 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010))) + (ba3 (make-array '(2 3) + :element-type 'bit)) + (ba4 (bit-andc1 ba1 ba2 ba3))) + (and (eq ba3 ba4) + (equalp ba3 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010))) + (not (eq ba1 ba3)) + (not (eq ba1 ba4)) + (not (eq ba2 ba3)) + (not (eq ba2 ba4)))) + + +(equal (bit-andc2 #*11101010 #*01101011) #*10000000) +(equal (bit-andc2 #*11101010 #*01101011 nil) #*10000000) +(equal (bit-andc2 (make-array 8 :element-type 'bit :initial-contents #*11101010) + #*01101011 t) + #*10000000) +(equal (bit-andc2 #*11101010 + #*01101011 + (make-array 8 :element-type 'bit)) + #*10000000) +(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*11101010)) + (ba2 (make-array 8 :element-type 'bit :initial-contents #*01101011)) + (ba (bit-andc2 ba1 ba2))) + (and (not (eq ba1 ba)) + (not (eq ba2 ba)) + (not (eq ba1 ba2)) + (equal ba #*10000000))) + +(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01010101)) + (ba (bit-andc2 ba1 #*10101010 t))) + (and (eq ba1 ba) + (equal ba1 #*01010101))) + +(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01110001)) + (ba (bit-andc2 ba1 #*00111110 t))) + (and (eq ba1 ba) + (equal ba1 #*01000001))) + +(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01110001)) + (ba2 (make-array 8 :element-type 'bit :initial-contents #*00111110)) + (ba3 (make-array 8 :element-type 'bit)) + (ba4 (bit-andc2 ba1 ba2 ba3))) + (and (eq ba3 ba4) + (equal ba3 #*01000001) + (not (eq ba1 ba3)) + (not (eq ba1 ba4)) + (not (eq ba2 ba3)) + (not (eq ba2 ba4)))) + +(equalp (bit-andc2 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101)) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010))) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101))) + +(equalp (bit-andc2 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101)) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010)) + nil) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101))) + +(equalp (bit-andc2 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101)) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010)) + t) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101))) + +(equalp (bit-andc2 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101)) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010)) + (make-array '(2 3) + :element-type 'bit)) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101))) + +(let* ((ba1 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101))) + (ba2 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010))) + (ba (bit-andc2 ba1 ba2))) + (and (not (eq ba1 ba)) + (not (eq ba2 ba)) + (not (eq ba1 ba2)) + (equalp ba (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101))))) + +(let* ((ba1 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101))) + (ba2 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010))) + (ba (bit-andc2 ba1 ba2 t))) + (and (eq ba1 ba) + (equalp ba1 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101))))) + +(let* ((ba1 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101))) + (ba2 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010))) + (ba3 (make-array '(2 3) + :element-type 'bit)) + (ba4 (bit-andc2 ba1 ba2 ba3))) + (and (eq ba3 ba4) + (equalp ba3 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101))) + (not (eq ba1 ba3)) + (not (eq ba1 ba4)) + (not (eq ba2 ba3)) + (not (eq ba2 ba4)))) + + +(equal (bit-eqv #*11101010 #*01101011) #*01111110) +(equal (bit-eqv #*11101010 #*01101011 nil) #*01111110) +(equal (bit-eqv (make-array 8 :element-type 'bit :initial-contents #*11101010) + #*01101011 t) + #*01111110) +(equal (bit-eqv #*11101010 + #*01101011 + (make-array 8 :element-type 'bit)) + #*01111110) +(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*11101010)) + (ba2 (make-array 8 :element-type 'bit :initial-contents #*01101011)) + (ba (bit-eqv ba1 ba2))) + (and (not (eq ba1 ba)) + (not (eq ba2 ba)) + (not (eq ba1 ba2)) + (equal ba #*01111110))) + +(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01010101)) + (ba (bit-eqv ba1 #*10101010 t))) + (and (eq ba1 ba) + (equal ba1 #*00000000))) + +(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01110001)) + (ba (bit-eqv ba1 #*00111110 t))) + (and (eq ba1 ba) + (equal ba1 #*10110000))) + +(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01110001)) + (ba2 (make-array 8 :element-type 'bit :initial-contents #*00111110)) + (ba3 (make-array 8 :element-type 'bit)) + (ba4 (bit-eqv ba1 ba2 ba3))) + (and (eq ba3 ba4) + (equal ba3 #*10110000) + (not (eq ba1 ba3)) + (not (eq ba1 ba4)) + (not (eq ba2 ba3)) + (not (eq ba2 ba4)))) + +(equalp (bit-eqv (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101)) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010))) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*000 #*000))) + +(equalp (bit-eqv (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101)) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010)) + nil) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*000 #*000))) + + +(equalp (bit-eqv (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101)) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010)) + t) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*000 #*000))) + +(equalp (bit-eqv (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101)) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010)) + (make-array '(2 3) + :element-type 'bit)) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*000 #*000))) + +(let* ((ba1 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101))) + (ba2 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010))) + (ba (bit-eqv ba1 ba2))) + (and (not (eq ba1 ba)) + (not (eq ba2 ba)) + (not (eq ba1 ba2)) + (equalp ba (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*000 #*000))))) + + +(let* ((ba1 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101))) + (ba2 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010))) + (ba (bit-eqv ba1 ba2 t))) + (and (eq ba1 ba) + (equalp ba1 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*000 #*000))))) + +(let* ((ba1 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101))) + (ba2 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010))) + (ba3 (make-array '(2 3) + :element-type 'bit)) + (ba4 (bit-eqv ba1 ba2 ba3))) + (and (eq ba3 ba4) + (equalp ba3 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*000 #*000))) + (not (eq ba1 ba3)) + (not (eq ba1 ba4)) + (not (eq ba2 ba3)) + (not (eq ba2 ba4)))) + + + + +(equal (bit-ior #*11101010 #*01101011) #*11101011) +(equal (bit-ior #*11101010 #*01101011 nil) #*11101011) +(equal (bit-ior (make-array 8 :element-type 'bit :initial-contents #*11101010) + #*01101011 t) + #*11101011) +(equal (bit-ior #*11101010 + #*01101011 + (make-array 8 :element-type 'bit)) + #*11101011) +(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*11101010)) + (ba2 (make-array 8 :element-type 'bit :initial-contents #*01101011)) + (ba (bit-ior ba1 ba2))) + (and (not (eq ba1 ba)) + (not (eq ba2 ba)) + (not (eq ba1 ba2)) + (equal ba #*11101011))) + +(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01010101)) + (ba (bit-ior ba1 #*10101010 t))) + (and (eq ba1 ba) + (equal ba1 #*11111111))) + +(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01110001)) + (ba (bit-ior ba1 #*00111110 t))) + (and (eq ba1 ba) + (equal ba1 #*01111111))) +(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01110001)) + (ba2 (make-array 8 :element-type 'bit :initial-contents #*00111110)) + (ba3 (make-array 8 :element-type 'bit)) + (ba4 (bit-ior ba1 ba2 ba3))) + (and (eq ba3 ba4) + (equal ba3 #*01111111) + (not (eq ba1 ba3)) + (not (eq ba1 ba4)) + (not (eq ba2 ba3)) + (not (eq ba2 ba4)))) + +(equalp (bit-ior (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101)) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010))) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*111 #*111))) + +(equalp (bit-ior (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101)) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010)) + nil) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*111 #*111))) + +(equalp (bit-ior (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101)) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010)) + t) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*111 #*111))) +(equalp (bit-ior (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101)) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010)) + (make-array '(2 3) + :element-type 'bit)) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*111 #*111))) +(let* ((ba1 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101))) + (ba2 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010))) + (ba (bit-ior ba1 ba2))) + (and (not (eq ba1 ba)) + (not (eq ba2 ba)) + (not (eq ba1 ba2)) + (equalp ba (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*111 #*111))))) + + +(let* ((ba1 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101))) + (ba2 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010))) + (ba (bit-ior ba1 ba2 t))) + (and (eq ba1 ba) + (equalp ba1 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*111 #*111))))) +(let* ((ba1 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101))) + (ba2 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010))) + (ba3 (make-array '(2 3) + :element-type 'bit)) + (ba4 (bit-ior ba1 ba2 ba3))) + (and (eq ba3 ba4) + (equalp ba3 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*111 #*111))) + (not (eq ba1 ba3)) + (not (eq ba1 ba4)) + (not (eq ba2 ba3)) + (not (eq ba2 ba4)))) + + + + +(equal (bit-nand #*11101010 #*01101011) #*10010101) +(equal (bit-nand #*11101010 #*01101011 nil) #*10010101) +(equal (bit-nand (make-array 8 :element-type 'bit :initial-contents #*11101010) + #*01101011 t) + #*10010101) +(equal (bit-nand #*11101010 + #*01101011 + (make-array 8 :element-type 'bit)) + #*10010101) +(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*11101010)) + (ba2 (make-array 8 :element-type 'bit :initial-contents #*01101011)) + (ba (bit-nand ba1 ba2))) + (and (not (eq ba1 ba)) + (not (eq ba2 ba)) + (not (eq ba1 ba2)) + (equal ba #*10010101))) + +(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01010101)) + (ba (bit-nand ba1 #*10101010 t))) + (and (eq ba1 ba) + (equal ba1 #*11111111))) + +(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01110001)) + (ba (bit-nand ba1 #*00111110 t))) + (and (eq ba1 ba) + (equal ba1 #*11001111))) +(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01110001)) + (ba2 (make-array 8 :element-type 'bit :initial-contents #*00111110)) + (ba3 (make-array 8 :element-type 'bit)) + (ba4 (bit-nand ba1 ba2 ba3))) + (and (eq ba3 ba4) + (equal ba3 #*11001111) + (not (eq ba1 ba3)) + (not (eq ba1 ba4)) + (not (eq ba2 ba3)) + (not (eq ba2 ba4)))) +(equalp (bit-nand (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101)) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010))) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*111 #*111))) + +(equalp (bit-nand (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101)) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010)) + nil) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*111 #*111))) + +(equalp (bit-nand (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101)) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010)) + t) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*111 #*111))) +(equalp (bit-nand (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101)) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010)) + (make-array '(2 3) + :element-type 'bit)) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*111 #*111))) +(let* ((ba1 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101))) + (ba2 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010))) + (ba (bit-nand ba1 ba2))) + (and (not (eq ba1 ba)) + (not (eq ba2 ba)) + (not (eq ba1 ba2)) + (equalp ba (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*111 #*111))))) + +(let* ((ba1 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101))) + (ba2 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010))) + (ba (bit-nand ba1 ba2 t))) + (and (eq ba1 ba) + (equalp ba1 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*111 #*111))))) +(let* ((ba1 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101))) + (ba2 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010))) + (ba3 (make-array '(2 3) + :element-type 'bit)) + (ba4 (bit-nand ba1 ba2 ba3))) + (and (eq ba3 ba4) + (equalp ba3 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*111 #*111))) + (not (eq ba1 ba3)) + (not (eq ba1 ba4)) + (not (eq ba2 ba3)) + (not (eq ba2 ba4)))) + + + + +(equal (bit-nor #*11101010 #*01101011) #*00010100) +(equal (bit-nor #*11101010 #*01101011 nil) #*00010100) +(equal (bit-nor (make-array 8 :element-type 'bit :initial-contents #*11101010) + #*01101011 t) + #*00010100) +(equal (bit-nor #*11101010 + #*01101011 + (make-array 8 :element-type 'bit)) + #*00010100) +(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*11101010)) + (ba2 (make-array 8 :element-type 'bit :initial-contents #*01101011)) + (ba (bit-nor ba1 ba2))) + (and (not (eq ba1 ba)) + (not (eq ba2 ba)) + (not (eq ba1 ba2)) + (equal ba #*00010100))) +(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01010101)) + (ba (bit-nor ba1 #*10101010 t))) + (and (eq ba1 ba) + (equal ba1 #*00000000))) +(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01110001)) + (ba (bit-nor ba1 #*00111110 t))) + (and (eq ba1 ba) + (equal ba1 #*10000000))) +(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01110001)) + (ba2 (make-array 8 :element-type 'bit :initial-contents #*00111110)) + (ba3 (make-array 8 :element-type 'bit)) + (ba4 (bit-nor ba1 ba2 ba3))) + (and (eq ba3 ba4) + (equal ba3 #*10000000) + (not (eq ba1 ba3)) + (not (eq ba1 ba4)) + (not (eq ba2 ba3)) + (not (eq ba2 ba4)))) +(equalp (bit-nor (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101)) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010))) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*000 #*000))) + +(equalp (bit-nor (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101)) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010)) + nil) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*000 #*000))) + +(equalp (bit-nor (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101)) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010)) + t) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*000 #*000))) +(equalp (bit-nor (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101)) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010)) + (make-array '(2 3) + :element-type 'bit)) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*000 #*000))) +(let* ((ba1 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101))) + (ba2 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010))) + (ba (bit-nor ba1 ba2))) + (and (not (eq ba1 ba)) + (not (eq ba2 ba)) + (not (eq ba1 ba2)) + (equalp ba (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*000 #*000))))) + +(let* ((ba1 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101))) + (ba2 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010))) + (ba (bit-nor ba1 ba2 t))) + (and (eq ba1 ba) + (equalp ba1 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*000 #*000))))) +(let* ((ba1 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101))) + (ba2 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010))) + (ba3 (make-array '(2 3) + :element-type 'bit)) + (ba4 (bit-nor ba1 ba2 ba3))) + (and (eq ba3 ba4) + (equalp ba3 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*000 #*000))) + (not (eq ba1 ba3)) + (not (eq ba1 ba4)) + (not (eq ba2 ba3)) + (not (eq ba2 ba4)))) + + + + +(equal (bit-orc1 #*11101010 #*01101011) #*01111111) +(equal (bit-orc1 #*11101010 #*01101011 nil) #*01111111) +(equal (bit-orc1 (make-array 8 :element-type 'bit :initial-contents #*11101010) + #*01101011 t) + #*01111111) +(equal (bit-orc1 #*11101010 + #*01101011 + (make-array 8 :element-type 'bit)) + #*01111111) +(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*11101010)) + (ba2 (make-array 8 :element-type 'bit :initial-contents #*01101011)) + (ba (bit-orc1 ba1 ba2))) + (and (not (eq ba1 ba)) + (not (eq ba2 ba)) + (not (eq ba1 ba2)) + (equal ba #*01111111))) +(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01010101)) + (ba (bit-orc1 ba1 #*10101010 t))) + (and (eq ba1 ba) + (equal ba1 #*10101010))) +(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01110001)) + (ba (bit-orc1 ba1 #*00111110 t))) + (and (eq ba1 ba) + (equal ba1 #*10111110))) +(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01110001)) + (ba2 (make-array 8 :element-type 'bit :initial-contents #*00111110)) + (ba3 (make-array 8 :element-type 'bit)) + (ba4 (bit-orc1 ba1 ba2 ba3))) + (and (eq ba3 ba4) + (equal ba3 #*10111110) + (not (eq ba1 ba3)) + (not (eq ba1 ba4)) + (not (eq ba2 ba3)) + (not (eq ba2 ba4)))) +(equalp (bit-orc1 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101)) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010))) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010))) + +(equalp (bit-orc1 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101)) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010)) + nil) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010))) + +(equalp (bit-orc1 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101)) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010)) + t) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010))) +(equalp (bit-orc1 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101)) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010)) + (make-array '(2 3) + :element-type 'bit)) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010))) +(let* ((ba1 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101))) + (ba2 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010))) + (ba (bit-orc1 ba1 ba2))) + (and (not (eq ba1 ba)) + (not (eq ba2 ba)) + (not (eq ba1 ba2)) + (equalp ba (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010))))) + +(let* ((ba1 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101))) + (ba2 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010))) + (ba (bit-orc1 ba1 ba2 t))) + (and (eq ba1 ba) + (equalp ba1 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010))))) +(let* ((ba1 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101))) + (ba2 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010))) + (ba3 (make-array '(2 3) + :element-type 'bit)) + (ba4 (bit-orc1 ba1 ba2 ba3))) + (and (eq ba3 ba4) + (equalp ba3 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010))) + (not (eq ba1 ba3)) + (not (eq ba1 ba4)) + (not (eq ba2 ba3)) + (not (eq ba2 ba4)))) + + + +(equal (bit-orc2 #*11101010 #*01101011) #*11111110) +(equal (bit-orc2 #*11101010 #*01101011 nil) #*11111110) +(equal (bit-orc2 (make-array 8 :element-type 'bit :initial-contents #*11101010) + #*01101011 t) + #*11111110) +(equal (bit-orc2 #*11101010 + #*01101011 + (make-array 8 :element-type 'bit)) + #*11111110) +(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*11101010)) + (ba2 (make-array 8 :element-type 'bit :initial-contents #*01101011)) + (ba (bit-orc2 ba1 ba2))) + (and (not (eq ba1 ba)) + (not (eq ba2 ba)) + (not (eq ba1 ba2)) + (equal ba #*11111110))) +(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01010101)) + (ba (bit-orc2 ba1 #*10101010 t))) + (and (eq ba1 ba) + (equal ba1 #*01010101))) +(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01110001)) + (ba (bit-orc2 ba1 #*00111110 t))) + (and (eq ba1 ba) + (equal ba1 #*11110001))) +(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01110001)) + (ba2 (make-array 8 :element-type 'bit :initial-contents #*00111110)) + (ba3 (make-array 8 :element-type 'bit)) + (ba4 (bit-orc2 ba1 ba2 ba3))) + (and (eq ba3 ba4) + (equal ba3 #*11110001) + (not (eq ba1 ba3)) + (not (eq ba1 ba4)) + (not (eq ba2 ba3)) + (not (eq ba2 ba4)))) +(equalp (bit-orc2 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101)) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010))) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101))) + +(equalp (bit-orc2 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101)) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010)) + nil) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101))) + +(equalp (bit-orc2 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101)) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010)) + t) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101))) + +(equalp (bit-orc2 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101)) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010)) + (make-array '(2 3) + :element-type 'bit)) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101))) + +(let* ((ba1 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101))) + (ba2 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010))) + (ba (bit-orc2 ba1 ba2))) + (and (not (eq ba1 ba)) + (not (eq ba2 ba)) + (not (eq ba1 ba2)) + (equalp ba (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101))))) + +(let* ((ba1 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101))) + (ba2 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010))) + (ba (bit-orc2 ba1 ba2 t))) + (and (eq ba1 ba) + (equalp ba1 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101))))) + +(let* ((ba1 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101))) + (ba2 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010))) + (ba3 (make-array '(2 3) + :element-type 'bit)) + (ba4 (bit-orc2 ba1 ba2 ba3))) + (and (eq ba3 ba4) + (equalp ba3 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101))) + (not (eq ba1 ba3)) + (not (eq ba1 ba4)) + (not (eq ba2 ba3)) + (not (eq ba2 ba4)))) + + + + +(equal (bit-xor #*11101010 #*01101011) #*10000001) +(equal (bit-xor #*11101010 #*01101011 nil) #*10000001) +(equal (bit-xor (make-array 8 :element-type 'bit :initial-contents #*11101010) + #*01101011 t) + #*10000001) +(equal (bit-xor #*11101010 + #*01101011 + (make-array 8 :element-type 'bit)) + #*10000001) +(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*11101010)) + (ba2 (make-array 8 :element-type 'bit :initial-contents #*01101011)) + (ba (bit-xor ba1 ba2))) + (and (not (eq ba1 ba)) + (not (eq ba2 ba)) + (not (eq ba1 ba2)) + (equal ba #*10000001))) +(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01010101)) + (ba (bit-xor ba1 #*10101010 t))) + (and (eq ba1 ba) + (equal ba1 #*11111111))) +(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01110001)) + (ba (bit-xor ba1 #*00111110 t))) + (and (eq ba1 ba) + (equal ba1 #*01001111))) +(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01110001)) + (ba2 (make-array 8 :element-type 'bit :initial-contents #*00111110)) + (ba3 (make-array 8 :element-type 'bit)) + (ba4 (bit-xor ba1 ba2 ba3))) + (and (eq ba3 ba4) + (equal ba3 #*01001111) + (not (eq ba1 ba3)) + (not (eq ba1 ba4)) + (not (eq ba2 ba3)) + (not (eq ba2 ba4)))) +(equalp (bit-xor (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101)) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010))) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*111 #*111))) + +(equalp (bit-xor (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101)) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010)) + nil) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*111 #*111))) + +(equalp (bit-xor (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101)) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010)) + t) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*111 #*111))) +(equalp (bit-xor (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101)) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010)) + (make-array '(2 3) + :element-type 'bit)) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*111 #*111))) +(let* ((ba1 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101))) + (ba2 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010))) + (ba (bit-xor ba1 ba2))) + (and (not (eq ba1 ba)) + (not (eq ba2 ba)) + (not (eq ba1 ba2)) + (equalp ba (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*111 #*111))))) + +(let* ((ba1 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101))) + (ba2 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010))) + (ba (bit-xor ba1 ba2 t))) + (and (eq ba1 ba) + (equalp ba1 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*111 #*111))))) +(let* ((ba1 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101))) + (ba2 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010))) + (ba3 (make-array '(2 3) + :element-type 'bit)) + (ba4 (bit-xor ba1 ba2 ba3))) + (and (eq ba3 ba4) + (equalp ba3 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*111 #*111))) + (not (eq ba1 ba3)) + (not (eq ba1 ba4)) + (not (eq ba2 ba3)) + (not (eq ba2 ba4)))) + + + +(equal (bit-not #*11101010) #*00010101) +(equal (bit-not #*11101010 nil) #*00010101) +(equal (bit-not (make-array 8 :element-type 'bit :initial-contents #*11101010) + t) + #*00010101) +(equal (bit-not #*11101010 (make-array 8 :element-type 'bit)) + #*00010101) +(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*11101010)) + (ba (bit-not ba1))) + (and (not (eq ba1 ba)) + (equal ba #*00010101))) +(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01010101)) + (ba (bit-not ba1 t))) + (and (eq ba1 ba) + (equal ba1 #*10101010))) +(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01110001)) + (ba (bit-not ba1 t))) + (and (eq ba1 ba) + (equal ba1 #*10001110))) +(let* ((ba1 (make-array 8 :element-type 'bit :initial-contents #*01110001)) + (ba2 (make-array 8 :element-type 'bit)) + (ba3 (bit-not ba1 ba2))) + (and (eq ba2 ba3) + (equal ba2 #*10001110) + (not (eq ba1 ba2)) + (not (eq ba1 ba3)))) + +(equalp (bit-not (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101))) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010))) + +(equalp (bit-not (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101)) + nil) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010))) + +(equalp (bit-not (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101)) + t) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010))) +(equalp (bit-not (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101)) + (make-array '(2 3) + :element-type 'bit)) + (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010))) +(let* ((ba1 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101))) + (ba (bit-not ba1))) + (and (not (eq ba1 ba)) + (equalp ba (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010))))) + + + +(let* ((ba1 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101))) + (ba (bit-not ba1 t))) + (and (eq ba1 ba) + (equalp ba1 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010))))) +(let* ((ba1 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*010 #*101))) + (ba3 (make-array '(2 3) + :element-type 'bit)) + (ba4 (bit-not ba1 ba3))) + (and (eq ba3 ba4) + (equalp ba3 (make-array '(2 3) + :element-type 'bit + :initial-contents '(#*101 #*010))) + (not (eq ba1 ba3)) + (not (eq ba1 ba4)))) + + + +(bit-vector-p (make-array 6 :element-type 'bit :fill-pointer t)) +(bit-vector-p #*) +(not (bit-vector-p (make-array 6))) + +(not (simple-bit-vector-p (make-array 6))) +(simple-bit-vector-p #*) +(simple-bit-vector-p #*0101) +(simple-bit-vector-p #*0) +(simple-bit-vector-p #*1) +(simple-bit-vector-p (make-array 6 :element-type 'bit)) + +(equal (concatenate 'list + (adjust-array (make-array 5 :initial-contents '(0 1 2 3 4)) + 10 + :initial-element -1)) + '(0 1 2 3 4 -1 -1 -1 -1 -1)) + + +(let* ((array0 (make-array '(3 2) + :initial-contents + '((e0-0 e0-1) (e1-0 e1-1) (e2-0 e2-1)))) + (array (adjust-array array0 + '(4 3) + :initial-element 0))) + (and (eq (aref array 0 0) 'e0-0) + (eq (aref array 0 1) 'e0-1) + (eql (aref array 0 2) '0) + (eq (aref array 1 0) 'e1-0) + (eq (aref array 1 1) 'e1-1) + (eql (aref array 1 2) 0) + (eq (aref array 2 0) 'e2-0) + (eq (aref array 2 1) 'e2-1) + (eql (aref array 2 2) 0))) + + +(let* ((array0 (make-array '(3 2) + :initial-contents + '((e0-0 e0-1) (e1-0 e1-1) (e2-0 e2-1)))) + (array (adjust-array array0 + '(1 1) + :initial-element 0))) + (eq (aref array 0 0) 'e0-0)) + + +(let* ((array0 (make-array '(3 2) :initial-element 0)) + (array1 (make-array 6 :initial-element 1)) + (array (adjust-array array1 3 :displaced-to array0))) + (and (equal (array-dimensions array) '(3)) + (every #'zerop array))) + + + +(let* ((array0 (make-array '(3 2) :initial-contents '((0 1) (2 3) (4 5)))) + (array1 (make-array 6 :initial-element 1)) + (array (adjust-array array1 3 + :displaced-to array0 + :displaced-index-offset 3))) + (and (equal (array-dimensions array) '(3)) + (eql (aref array 0) 3) + (eql (aref array 1) 4) + (eql (aref array 2) 5))) + + +(let* ((array0 (make-array '(3 2) :initial-contents '((0 1) (2 3) (4 5)))) + (array1 (make-array 6 :displaced-to array0)) + (array (adjust-array array1 9 :initial-element '-1))) + (and (equal (array-dimensions array) '(9)) + (multiple-value-bind (displaced-to displaced-index-offset) + (array-displacement array) + (and (null displaced-to) (zerop displaced-index-offset))) + (eql (aref array 0) 0) + (eql (aref array 1) 1) + (eql (aref array 2) 2) + (eql (aref array 3) 3) + (eql (aref array 4) 4) + (eql (aref array 5) 5) + (eql (aref array 6) -1) + (eql (aref array 7) -1) + (eql (aref array 8) -1))) + + +(let* ((array0 (make-array '(4 4) + :adjustable t + :initial-contents + '(( alpha beta gamma delta ) + ( epsilon zeta eta theta ) + ( iota kappa lambda mu ) + ( nu xi omicron pi )))) + (array (adjust-array array0 '(3 5) :initial-element 'baz))) + (equalp array + #2A(( alpha beta gamma delta baz ) + ( epsilon zeta eta theta baz ) + ( iota kappa lambda mu baz )))) + + +(let* ((array0 (make-array 3 :initial-element 0)) + (array1 (make-array 3 :adjustable t :displaced-to array0)) + (array2 (make-array 3 :displaced-to array1))) + (and (adjustable-array-p array1) + (eq array1 (adjust-array array1 6 :initial-contents '(a b c d e f))) + (multiple-value-bind (displaced-to displaced-index-offset) + (array-displacement array1) + (and (null displaced-to) (zerop displaced-index-offset))) + (eq (aref array1 0) 'a) + (eq (aref array1 1) 'b) + (eq (aref array1 2) 'c) + (eq (aref array1 3) 'd) + (eq (aref array1 4) 'e) + (eq (aref array1 5) 'f) + (eq (aref array2 0) 'a) + (eq (aref array2 1) 'b) + (eq (aref array2 2) 'c))) + +(let* ((str0 (make-array 10 + :element-type 'character + :initial-contents "abcdefghij")) + (str1 (make-array 7 + :adjustable t + :element-type 'character + :displaced-to str0 + :displaced-index-offset 3)) + (str2 (make-array 3 + :element-type 'character + :displaced-to str1 + :displaced-index-offset 4))) + (and (string= str0 "abcdefghij") + (string= str1 "defghij") + (string= str2 "hij") + (adjustable-array-p str1) + (eq str1 (adjust-array str1 10 :initial-contents "QRSTUVWXYZ")) + (string= str2 "UVW"))) + + +(let* ((bv (make-array 10 + :element-type 'bit + :initial-contents #*1010101010 + :fill-pointer t))) + (and (dotimes (i 10 t) + (unless (eql (vector-pop bv) (if (evenp i) 0 1)) + (return nil))) + (zerop (length bv)))) + +(let* ((bv (make-array 10 + :adjustable t + :element-type 'bit + :fill-pointer 0))) + (dotimes (i 100) + (vector-push-extend (if (oddp i) 0 1) bv)) + (dotimes (i 100 t) + (unless (eql (vector-pop bv) (if (oddp i) 1 0)) + (return nil)))) + + + +(let* ((str (make-array 10 + :element-type 'character + :initial-contents "abcdefghjk" + :fill-pointer t))) + (and (dotimes (i 10 t) + (unless (char= (vector-pop str) (aref "kjhgfedcba" i)) + (return nil))) + (zerop (length str)))) + +(let* ((str (make-array 10 + :adjustable t + :element-type 'character + :fill-pointer 0))) + (dotimes (i 100) + (vector-push-extend (if (oddp i) #\a #\z) str)) + (dotimes (i 100 t) + (unless (char= (vector-pop str) (if (oddp i) #\z #\a)) + (return nil)))) + + diff --git a/Sacla/tests/must-character.lisp b/Sacla/tests/must-character.lisp new file mode 100644 index 0000000..3cd9aa6 --- /dev/null +++ b/Sacla/tests/must-character.lisp @@ -0,0 +1,537 @@ +;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp> +;; ALL RIGHTS RESERVED. +;; +;; $Id: must-character.lisp,v 1.6 2004/02/20 07:23:42 yuji Exp $ +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; * Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; * Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(char= #\d #\d) +(not (char= #\A #\a)) +(not (char= #\d #\x)) +(not (char= #\d #\D)) +(not (char/= #\d #\d)) +(char/= #\d #\x) +(char/= #\d #\D) +(char= #\d #\d #\d #\d) +(not (char/= #\d #\d #\d #\d)) +(not (char= #\d #\d #\x #\d)) +(not (char/= #\d #\d #\x #\d)) +(not (char= #\d #\y #\x #\c)) +(char/= #\d #\y #\x #\c) +(not (char= #\d #\c #\d)) +(not (char/= #\d #\c #\d)) +(char< #\d #\x) +(char<= #\d #\x) +(not (char< #\d #\d)) +(char<= #\d #\d) +(char< #\a #\e #\y #\z) +(char<= #\a #\e #\y #\z) +(not (char< #\a #\e #\e #\y)) +(char<= #\a #\e #\e #\y) +(char> #\e #\d) +(char>= #\e #\d) +(char> #\d #\c #\b #\a) +(char>= #\d #\c #\b #\a) +(not (char> #\d #\d #\c #\a)) +(char>= #\d #\d #\c #\a) +(not (char> #\e #\d #\b #\c #\a)) +(not (char>= #\e #\d #\b #\c #\a)) +(char-equal #\A #\a) +(equal (stable-sort (list #\b #\A #\B #\a #\c #\C) #'char-lessp) + '(#\A #\a #\b #\B #\c #\C)) + +(char= #\a) +(char= #\a #\a) +(char= #\a #\a #\a) +(char= #\a #\a #\a #\a) +(char= #\a #\a #\a #\a #\a) +(char= #\a #\a #\a #\a #\a #\a) +(let ((c #\z)) + (and (eq c c) + (char= c c))) +(not (char= #\Z #\z)) +(not (char= #\z #\z #\z #\a)) +(not (char= #\a #\z #\z #\z #\a)) +(not (char= #\z #\i #\z #\z)) +(not (char= #\z #\z #\Z #\z)) + +(char/= #\a) +(char/= #\a #\b) +(char/= #\a #\b #\c) +(char/= #\a #\b #\c #\d) +(char/= #\a #\b #\c #\d #\e) +(char/= #\a #\b #\c #\d #\e #\f) +(let ((c #\z)) + (and (eq c c) + (not (char/= c c)))) +(char/= #\Z #\z) +(not (char/= #\z #\z #\z #\a)) +(not (char= #\a #\z #\z #\z #\a)) +(not (char= #\z #\i #\z #\z)) +(not (char= #\z #\z #\Z #\z)) +(not (char/= #\a #\a #\b #\c)) +(not (char/= #\a #\b #\a #\c)) +(not (char/= #\a #\b #\c #\a)) + +(char< #\a) +(char< #\a #\z) +(char< #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m + #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z) +(not (char< #\z #\y #\x #\w #\v #\u #\t #\s #\r #\q #\p #\o #\n + #\m #\l #\k #\j #\i #\h #\g #\f #\e #\d #\c #\b #\a)) +(char< #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M + #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z) +(not (char< #\Z #\Y #\X #\W #\V #\U #\T #\S #\R #\Q #\P #\O #\N + #\M #\L #\K #\J #\I #\H #\G #\F #\E #\D #\C #\B #\A)) +(char< #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) +(not (char< #\9 #\8 #\7 #\6 #\5 #\4 #\3 #\2 #\1 #\0)) +(or (char< #\9 #\A) + (char< #\Z #\0)) +(or (char< #\9 #\a) + (char< #\z #\0)) +(not (char< #\a #\a #\b #\c)) +(not (char< #\a #\b #\a #\c)) +(not (char< #\a #\b #\c #\a)) +(not (char< #\9 #\0)) + +(char> #\a) +(not (char> #\a #\z)) +(char> #\z #\a) +(not (char> #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m + #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z)) +(char> #\z #\y #\x #\w #\v #\u #\t #\s #\r #\q #\p #\o #\n + #\m #\l #\k #\j #\i #\h #\g #\f #\e #\d #\c #\b #\a) +(not (char> #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M + #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z)) +(char> #\Z #\Y #\X #\W #\V #\U #\T #\S #\R #\Q #\P #\O #\N + #\M #\L #\K #\J #\I #\H #\G #\F #\E #\D #\C #\B #\A) +(not (char> #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) +(char> #\9 #\8 #\7 #\6 #\5 #\4 #\3 #\2 #\1 #\0) +(or (char> #\A #\9) + (char> #\0 #\Z)) +(or (char> #\a #\9) + (char> #\0 #\z)) +(not (char> #\a #\a #\b #\c)) +(not (char> #\a #\b #\a #\c)) +(not (char> #\a #\b #\c #\a)) +(char> #\9 #\0) + +(char<= #\a) +(char<= #\a #\z) +(char<= #\a #\a) +(char<= #\Z #\Z) +(char<= #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m + #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z) +(char<= #\a #\a #\b #\b #\c #\c #\d #\d #\e #\e #\f #\f #\g #\g + #\h #\h #\i #\i #\j #\j #\k #\k #\l #\l #\m #\m + #\n #\n #\o #\o #\p #\p #\q #\q #\r #\r #\s #\s + #\t #\t #\u #\u #\v #\v #\w #\w #\x #\x #\y #\y #\z #\z) +(not (char<= #\z #\y #\x #\w #\v #\u #\t #\s #\r #\q #\p #\o #\n + #\m #\l #\k #\j #\i #\h #\g #\f #\e #\d #\c #\b #\a)) +(char<= #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M + #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z) +(char<= #\A #\B #\B #\C #\D #\E #\E #\F #\G #\H #\I #\I #\J #\K #\L #\M + #\N #\N #\O #\P #\Q #\R #\S #\T #\T #\U #\V #\W #\X #\Y #\Z) +(not (char<= #\Z #\Y #\X #\W #\V #\U #\T #\S #\R #\Q #\P #\O #\N + #\M #\L #\K #\J #\I #\H #\G #\F #\E #\D #\C #\B #\A)) +(char<= #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) +(char<= #\0 #\1 #\2 #\2 #\3 #\3 #\3 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\9) +(not (char<= #\9 #\8 #\7 #\6 #\5 #\4 #\3 #\2 #\1 #\0)) +(or (char<= #\9 #\A) + (char<= #\Z #\0)) +(or (char<= #\9 #\a) + (char<= #\z #\0)) +(char<= #\a #\a #\b #\c) +(not (char<= #\a #\b #\a #\c)) +(not (char<= #\a #\b #\c #\a)) +(not (char<= #\9 #\0)) + +(char>= #\a) +(not (char>= #\a #\z)) +(char>= #\z #\a) +(char>= #\a #\a) +(char>= #\Z #\Z) +(not (char>= #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m + #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z)) +(char>= #\z #\y #\x #\w #\v #\u #\t #\s #\r #\q #\p #\o #\n + #\m #\l #\k #\j #\i #\h #\g #\f #\e #\d #\c #\b #\a) +(char>= #\z #\z #\y #\x #\w #\v #\u #\t #\s #\r #\q #\p #\o #\n #\n + #\m #\m #\l #\k #\j #\i #\h #\g #\f #\e #\d #\c #\b #\a #\a) +(not (char>= #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M + #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z)) +(char>= #\Z #\Y #\X #\W #\V #\U #\T #\S #\R #\Q #\P #\O #\N + #\M #\L #\K #\J #\I #\H #\G #\F #\E #\D #\C #\B #\A) +(char>= #\Z #\Y #\X #\W #\V #\U #\U #\T #\T #\S #\S #\R #\Q #\P #\O #\N + #\M #\L #\K #\J #\I #\H #\H #\G #\G #\F #\F #\E #\D #\C #\B #\A) +(not (char>= #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) +(char>= #\9 #\8 #\7 #\6 #\5 #\4 #\3 #\2 #\1 #\0) +(char>= #\9 #\8 #\8 #\8 #\7 #\6 #\5 #\4 #\3 #\3 #\3 #\2 #\1 #\0) +(or (char>= #\A #\9) + (char>= #\0 #\Z)) +(or (char>= #\a #\9) + (char>= #\0 #\z)) +(char>= #\c #\b #\a #\a) +(not (char>= #\c #\b #\a #\a #\b #\c)) +(not (char>= #\c #\b #\a #\c)) +(not (char>= #\c #\b #\c #\a)) +(char>= #\9 #\0) +(not (char>= #\0 #\9)) + + +(char-equal #\a) +(char-equal #\a #\a) +(char-equal #\a #\a #\a) +(char-equal #\a #\a #\a #\a) +(char-equal #\a #\a #\a #\a #\a) +(char-equal #\a #\a #\a #\a #\a #\a) +(char-equal #\a #\A) +(char-equal #\a #\A #\a) +(char-equal #\a #\a #\A #\a) +(char-equal #\a #\a #\a #\A #\a) +(char-equal #\a #\a #\a #\a #\A #\a) +(let ((c #\z)) + (and (eq c c) + (char-equal c c))) +(char-equal #\Z #\z) +(not (char-equal #\z #\z #\z #\a)) +(not (char-equal #\a #\z #\z #\z #\a)) +(not (char-equal #\z #\i #\z #\z)) +(char-equal #\z #\z #\Z #\z) +(char-equal #\a #\A #\a #\A #\a #\A #\a #\A #\a #\A) + + +(char-not-equal #\a) +(char-not-equal #\a #\b) +(char-not-equal #\a #\b #\c) +(char-not-equal #\a #\b #\c #\d) +(char-not-equal #\a #\b #\c #\d #\e) +(char-not-equal #\a #\b #\c #\d #\e #\f) +(let ((c #\z)) + (and (eq c c) + (not (char-not-equal c c)))) +(not (char-not-equal #\Z #\z)) +(not (char-not-equal #\z #\z #\z #\a)) +(not (char= #\a #\z #\z #\z #\a)) +(not (char= #\z #\i #\z #\z)) +(not (char= #\z #\z #\Z #\z)) +(not (char-not-equal #\a #\a #\b #\c)) +(not (char-not-equal #\a #\b #\a #\c)) +(not (char-not-equal #\a #\b #\c #\a)) +(not (char-not-equal #\a #\A #\a #\A)) + + +(char-lessp #\a) +(char-lessp #\a #\z) +(char-lessp #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m + #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z) +(not (char-lessp #\z #\y #\x #\w #\v #\u #\t #\s #\r #\q #\p #\o #\n + #\m #\l #\k #\j #\i #\h #\g #\f #\e #\d #\c #\b #\a)) +(char-lessp #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M + #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z) +(not (char-lessp #\Z #\Y #\X #\W #\V #\U #\T #\S #\R #\Q #\P #\O #\N + #\M #\L #\K #\J #\I #\H #\G #\F #\E #\D #\C #\B #\A)) +(char-lessp #\a #\B #\c #\D #\e #\F #\g #\H #\i #\J #\k #\L #\m + #\N #\o #\P #\q #\R #\s #\T #\u #\V #\w #\X #\y #\Z) +(char-lessp #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) +(not (char-lessp #\9 #\8 #\7 #\6 #\5 #\4 #\3 #\2 #\1 #\0)) +(or (char-lessp #\9 #\A) + (char-lessp #\Z #\0)) +(or (char-lessp #\9 #\a) + (char-lessp #\z #\0)) +(not (char-lessp #\a #\a #\b #\c)) +(not (char-lessp #\a #\b #\a #\c)) +(not (char-lessp #\a #\b #\c #\a)) +(not (char-lessp #\9 #\0)) +(and (char-lessp #\a #\Z) + (char-lessp #\A #\z)) + + +(char-greaterp #\a) +(not (char-greaterp #\a #\z)) +(char-greaterp #\z #\a) +(not (char-greaterp #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m + #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z)) +(char-greaterp #\z #\y #\x #\w #\v #\u #\t #\s #\r #\q #\p #\o #\n + #\m #\l #\k #\j #\i #\h #\g #\f #\e #\d #\c #\b #\a) +(not (char-greaterp #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M + #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z)) +(char-greaterp #\Z #\Y #\X #\W #\V #\U #\T #\S #\R #\Q #\P #\O #\N + #\M #\L #\K #\J #\I #\H #\G #\F #\E #\D #\C #\B #\A) +(char-greaterp #\z #\Y #\x #\W #\v #\U #\t #\S #\r #\Q #\p #\O #\n + #\M #\l #\K #\j #\I #\h #\G #\f #\E #\d #\C #\b #\A) +(not (char-greaterp #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) +(char-greaterp #\9 #\8 #\7 #\6 #\5 #\4 #\3 #\2 #\1 #\0) +(or (char-greaterp #\A #\9) + (char-greaterp #\0 #\Z)) +(or (char-greaterp #\a #\9) + (char-greaterp #\0 #\z)) +(not (char-greaterp #\a #\a #\b #\c)) +(not (char-greaterp #\a #\b #\a #\c)) +(not (char-greaterp #\a #\b #\c #\a)) +(char-greaterp #\9 #\0) +(and (char-greaterp #\z #\A) + (char-greaterp #\Z #\a)) + + + +(char-not-greaterp #\a) +(char-not-greaterp #\a #\z) +(char-not-greaterp #\a #\a) +(char-not-greaterp #\Z #\Z) +(char-not-greaterp + #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m + #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z) +(char-not-greaterp + #\a #\a #\b #\b #\c #\c #\d #\d #\e #\e #\f #\f #\g #\g + #\h #\h #\i #\i #\j #\j #\k #\k #\l #\l #\m #\m + #\n #\n #\o #\o #\p #\p #\q #\q #\r #\r #\s #\s + #\t #\t #\u #\u #\v #\v #\w #\w #\x #\x #\y #\y #\z #\z) +(char-not-greaterp + #\a #\A #\b #\B #\c #\C #\d #\D #\e #\E #\f #\F #\g #\G + #\h #\H #\i #\I #\j #\J #\k #\K #\l #\L #\m #\M + #\n #\N #\o #\O #\p #\P #\q #\Q #\r #\R #\s #\S + #\t #\T #\u #\U #\v #\V #\w #\W #\x #\X #\y #\Y #\z #\z) +(not (char-not-greaterp + #\z #\y #\x #\w #\v #\u #\t #\s #\r #\q #\p #\o #\n + #\m #\l #\k #\j #\i #\h #\g #\f #\e #\d #\c #\b #\a)) +(char-not-greaterp + #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M + #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z) +(char-not-greaterp + #\A #\B #\B #\C #\D #\E #\E #\F #\G #\H #\I #\I #\J #\K #\L #\M + #\N #\N #\O #\P #\Q #\R #\S #\T #\T #\U #\V #\W #\X #\Y #\Z) +(not (char-not-greaterp + #\Z #\Y #\X #\W #\V #\U #\T #\S #\R #\Q #\P #\O #\N + #\M #\L #\K #\J #\I #\H #\G #\F #\E #\D #\C #\B #\A)) +(char-not-greaterp #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) +(char-not-greaterp #\0 #\1 #\2 #\2 #\3 #\3 #\3 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\9) +(not (char-not-greaterp #\9 #\8 #\7 #\6 #\5 #\4 #\3 #\2 #\1 #\0)) +(or (char-not-greaterp #\9 #\A) + (char-not-greaterp #\Z #\0)) +(or (char-not-greaterp #\9 #\a) + (char-not-greaterp #\z #\0)) +(char-not-greaterp #\a #\a #\b #\c) +(not (char-not-greaterp #\a #\b #\a #\c)) +(not (char-not-greaterp #\a #\b #\c #\a)) +(not (char-not-greaterp #\9 #\0)) +(and (char-not-greaterp #\A #\z) + (char-not-greaterp #\a #\Z)) + + +(char-not-lessp #\a) +(not (char-not-lessp #\a #\z)) +(char-not-lessp #\z #\a) +(char-not-lessp #\a #\a) +(char-not-lessp #\Z #\Z) +(not (char-not-lessp #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m + #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z)) +(char-not-lessp #\z #\y #\x #\w #\v #\u #\t #\s #\r #\q #\p #\o #\n + #\m #\l #\k #\j #\i #\h #\g #\f #\e #\d #\c #\b #\a) +(char-not-lessp #\z #\z #\y #\x #\w #\v #\u #\t #\s #\r #\q #\p #\o #\n #\n + #\m #\m #\l #\k #\j #\i #\h #\g #\f #\e #\d #\c #\b #\a #\a) +(not (char-not-lessp #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M + #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z)) +(char-not-lessp #\Z #\Y #\X #\W #\V #\U #\T #\S #\R #\Q #\P #\O #\N + #\M #\L #\K #\J #\I #\H #\G #\F #\E #\D #\C #\B #\A) +(char-not-lessp #\Z #\Y #\X #\W #\V #\U #\U #\T #\T #\S #\S #\R #\Q #\P #\O #\N + #\M #\L #\K #\J #\I #\H #\H #\G #\G #\F #\F #\E #\D #\C #\B #\A) +(char-not-lessp #\z #\Z #\y #\x #\w #\V #\v #\u #\t #\s #\r #\q #\p #\o #\n #\n + #\m #\M #\l #\k #\K #\j #\i #\h #\g #\f #\e #\d #\c #\b #\A #\a) +(not (char-not-lessp #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) +(char-not-lessp #\9 #\8 #\7 #\6 #\5 #\4 #\3 #\2 #\1 #\0) +(char-not-lessp #\9 #\8 #\8 #\8 #\7 #\6 #\5 #\4 #\3 #\3 #\3 #\2 #\1 #\0) +(or (char-not-lessp #\A #\9) + (char-not-lessp #\0 #\Z)) +(or (char-not-lessp #\a #\9) + (char-not-lessp #\0 #\z)) +(char-not-lessp #\c #\b #\a #\a) +(not (char-not-lessp #\c #\b #\a #\a #\b #\c)) +(not (char-not-lessp #\c #\b #\a #\c)) +(not (char-not-lessp #\c #\b #\c #\a)) +(char-not-lessp #\9 #\0) +(not (char-not-lessp #\0 #\9)) +(and (char-not-lessp #\z #\A) + (char-not-lessp #\Z #\a)) + +(char= (character #\a) #\a) +(char= (character #\b) #\b) +(char= (character #\Space) #\Space) +(char= (character "a") #\a) +(char= (character "X") #\X) +(char= (character "z") #\z) +(char= (character 'a) #\A) +(char= (character '\a) #\a) + +(alpha-char-p #\a) +(every #'alpha-char-p '(#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m + #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z)) +(every #'alpha-char-p '(#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M + #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z)) +(notany #'alpha-char-p '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) +(not (alpha-char-p #\Newline)) + +(alphanumericp #\Z) +(alphanumericp #\9) +(every #'alphanumericp '(#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m + #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z)) +(every #'alphanumericp '(#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M + #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z)) +(every #'alphanumericp '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) +(not (alphanumericp #\Newline)) +(not (alphanumericp #\#)) + +(char= (digit-char 0) #\0) +(char= (digit-char 10 11) #\A) +(null (digit-char 10 10)) +(char= (digit-char 7) #\7) +(null (digit-char 12)) +(char= (digit-char 12 16) #\C) +(null (digit-char 6 2)) +(char= (digit-char 1 2) #\1) +(char= (digit-char 35 36) #\Z) + +(do ((radix 2 (1+ radix))) + ((= radix 37) t) + (unless (dotimes (i radix t) + (unless (char= (digit-char i radix) + (svref #(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 + #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J + #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T + #\U #\V #\W #\X #\Y #\Z) i)) + (return nil))) + (return nil))) + + +(= (digit-char-p #\0) 0) +(= (digit-char-p #\5) 5) +(not (digit-char-p #\5 2)) +(not (digit-char-p #\A)) +(not (digit-char-p #\a)) +(= (digit-char-p #\A 11) 10) +(= (digit-char-p #\a 11) 10) +(equal (mapcar #'(lambda (radix) + (map 'list #'(lambda (x) (digit-char-p x radix)) + "059AaFGZ")) + '(2 8 10 16 36)) + '((0 NIL NIL NIL NIL NIL NIL NIL) + (0 5 NIL NIL NIL NIL NIL NIL) + (0 5 9 NIL NIL NIL NIL NIL) + (0 5 9 10 10 15 NIL NIL) + (0 5 9 10 10 15 16 35))) + +(do ((radix 2 (1+ radix))) + ((= radix 37) t) + (unless (dotimes (i radix t) + (unless (= (digit-char-p (schar + "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" i) + radix) + i) + (return nil))) + (return nil))) + +(do ((radix 2 (1+ radix))) + ((= radix 37) t) + (unless (dotimes (i radix t) + (unless (= (digit-char-p (schar + "0123456789abcdefghijklmnopqrstuvwxyz" i) + radix) + i) + (return nil))) + (return nil))) + + +(graphic-char-p #\G) +(graphic-char-p #\#) +(graphic-char-p #\Space) +(not (graphic-char-p #\Newline)) + +(standard-char-p #\a) +(standard-char-p #\z) +(standard-char-p #\Newline) +(every #'standard-char-p " !\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_'abcdefghijklmnopqrstuvwxyz{|}~ +") + + +(char= (char-upcase #\a) #\A) +(char= (char-upcase #\A) #\A) +(char= (char-upcase #\-) #\-) +(char= (char-downcase #\A) #\a) +(char= (char-downcase #\a) #\a) +(char= (char-downcase #\-) #\-) +(not (upper-case-p #\a)) +(upper-case-p #\A) +(not (upper-case-p #\-)) +(not (lower-case-p #\A)) +(lower-case-p #\a) +(not (lower-case-p #\-)) +(both-case-p #\a) +(both-case-p #\A) +(not (both-case-p #\-)) + +(let ((chars " !\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_'abcdefghijklmnopqrstuvwxyz{|}~ +") + c) + (dotimes (i (length chars) t) + (setq c (schar chars i)) + (cond + ((upper-case-p c) + (unless (and (both-case-p c) + (not (lower-case-p c)) + (char= (char-upcase c) c) + (not (char= (char-downcase c) c))) + (return nil))) + ((lower-case-p c) + (unless (and (both-case-p c) + (char= (char-downcase c) c) + (not (char= (char-upcase c) c))) + (return nil))) + (t + (unless (and (not (upper-case-p c)) + (not (lower-case-p c)) + (not (both-case-p c)) + (char= (char-upcase c) c) + (char= (char-downcase c) c)) + (return nil)))))) + +(every (complement #'minusp) + (map 'list #'char-code " !\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_'abcdefghijklmnopqrstuvwxyz{|}~ +")) + +(every (complement #'minusp) + (map 'list #'char-int " !\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_'abcdefghijklmnopqrstuvwxyz{|}~ +")) + + +(every #'characterp + (map 'list #'code-char + (map 'list #'char-code " !\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_'abcdefghijklmnopqrstuvwxyz{|}~ +"))) + +(dotimes (i char-code-limit t) + (unless (or (null (code-char i)) (characterp (code-char i))) + (return nil))) + +(char= #\ (name-char (char-name #\ ))) +(char= #\Space (name-char (char-name #\Space))) +(char= #\Newline (name-char (char-name #\Newline))) diff --git a/Sacla/tests/must-condition.lisp b/Sacla/tests/must-condition.lisp new file mode 100644 index 0000000..08e7080 --- /dev/null +++ b/Sacla/tests/must-condition.lisp @@ -0,0 +1,898 @@ +;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp> +;; ALL RIGHTS RESERVED. +;; +;; $Id: must-condition.lisp,v 1.7 2004/02/20 07:23:42 yuji Exp $ +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; * Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; * Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;; signal +(eq (signal "test signal") nil) +(eq (signal 'simple-error :format-control "simple-error" :format-arguments nil) + nil) +(eq (signal 'simple-warning + :format-control "simple-warning" :format-arguments nil) + nil) +(handler-case (signal "test simple-condition") + (simple-condition () t) + (condition () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)) +(handler-case (signal 'simple-warning :format-control "simple warning" + :format-arguments nil) + (simple-warning () t) + (warning () nil) + (condition () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)) +(handler-case (signal 'type-error :datum nil :expected-type 'vector) + (type-error () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)) +(let ((*break-on-signals* 'arithmetic-error)) + (handler-case (signal 'type-error :datum nil :expected-type 'vector) + (type-error () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil))) + + +;; error +(handler-case (error "simple-error test") + (simple-error () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)) +(handler-case (error 'type-error :datum nil :expected-type 'vector) + (type-error () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)) +(handler-case (error 'no-such-error!!) + (type-error () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)) +(handler-case (error 'simple-condition :format-control "simple-condition test") + (simple-condition () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)) +(handler-case (error 'simple-warning :format-control "simple-warning test") + (simple-warning () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)) + + + +;; cerror +(handler-case (cerror "Continue." "error test") + (simple-error () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)) +(handler-case (cerror "Continue." 'type-error :datum nil :expected-type 'vector) + (type-error () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)) +(handler-bind ((simple-error #'(lambda (condition) + (declare (ignore condition)) + (invoke-restart 'continue)))) + (eq (cerror "Continue." "error test") nil)) +(handler-bind ((type-error #'(lambda (condition) + (declare (ignore condition)) + (invoke-restart 'continue)))) + (eq (cerror "Continue." 'type-error :datum nil :expected-type 'vector) nil)) + + + +;; warn +(let ((*error-output* (make-string-output-stream))) + (and (eq (warn "I warn you!") nil) + (get-output-stream-string *error-output*))) +(handler-bind ((warning #'(lambda (condition) + (declare (ignore condition)) + (invoke-restart 'muffle-warning)))) + (eq (warn "I warn you!") nil)) +(let ((*error-output* (make-string-output-stream))) + (handler-bind ((warning #'(lambda (condition) + (declare (ignore condition)) + (invoke-restart 'muffle-warning)))) + (and (eq (warn "I warn you!") nil) + (string= (get-output-stream-string *error-output*) "")))) +(block tag + (handler-case (warn 'simple-error + :format-control "boom!" :format-arguments nil) + (type-error () t) + (simple-error () nil) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil))) +(block tag + (handler-case (warn 'simple-condition + :format-control "boom!" :format-arguments nil) + (type-error () t) + (simple-condition () nil) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil))) +(block tag + (let ((condition (make-condition 'simple-condition + :format-control "boom!" + :format-arguments nil))) + (handler-case (warn condition) + (type-error () t) + (simple-condition () nil) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)))) +(block tag + (let ((condition (make-condition 'simple-error + :format-control "boom!" + :format-arguments nil))) + (handler-case (warn condition) + (type-error () t) + (simple-error () nil) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)))) +(block tag + (let ((condition (make-condition 'simple-warning + :format-control "boom!" + :format-arguments nil))) + (handler-case (warn condition) + (type-error () nil) + (simple-warning () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)))) +(block tag + (let ((condition (make-condition 'simple-warning + :format-control "boom!" + :format-arguments nil))) + (handler-case (warn condition :format-control "boom!" :format-arguments nil) + (type-error () t) + (simple-warning () nil) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)))) + + + +;; handler-bind +(null (handler-bind ())) +(handler-bind () t) +(equal (multiple-value-list (handler-bind () 1 2 3 (values 4 5 6))) '(4 5 6)) +(eq 'handled + (block tag (handler-bind ((type-error #'(lambda (c) + (declare (ignore c)) + (return-from tag 'handled)))) + (error 'type-error :datum nil :expected-type 'vector)))) +(eq 'handled + (block tag (handler-bind ((error #'(lambda (c) + (declare (ignore c)) + (return-from tag 'handled)))) + (error 'type-error :datum nil :expected-type 'vector)))) +(eq 'handled + (block tag (handler-bind ((condition #'(lambda (c) + (declare (ignore c)) + (return-from tag 'handled)))) + (error 'type-error :datum nil :expected-type 'vector)))) +(eq 'outer-handler + (block tag + (handler-bind ((type-error #'(lambda (c) + (declare (ignore c)) + (return-from tag 'outer-handler)))) + (handler-bind ((type-error #'(lambda (c) (error c))) + (type-error #'(lambda (c) + (declare (ignore c)) + (return-from tag 'inner-handler)))) + (error 'type-error :datum nil :expected-type 'vector))))) +(eq 'outer-handler + (block tag + (handler-bind ((error #'(lambda (c) + (declare (ignore c)) + (return-from tag 'outer-handler)))) + (handler-bind ((type-error #'(lambda (c) (error c))) + (type-error #'(lambda (c) + (declare (ignore c)) + (return-from tag 'inner-handler)))) + (error 'type-error :datum nil :expected-type 'vector))))) +(eq 'left-handler + (block tag + (handler-bind ((type-error #'(lambda (c) + (declare (ignore c)) + (return-from tag 'left-handler))) + (type-error #'(lambda (c) + (declare (ignore c)) + (return-from tag 'right-handler)))) + (error 'type-error :datum nil :expected-type 'vector)))) +(eq 'left-handler + (block tag + (handler-bind ((error #'(lambda (c) + (declare (ignore c)) + (return-from tag 'left-handler))) + (type-error #'(lambda (c) + (declare (ignore c)) + (return-from tag 'right-handler)))) + (error 'type-error :datum nil :expected-type 'vector)))) +(eq 'left-handler + (block tag + (handler-bind ((type-error #'(lambda (c) + (declare (ignore c)) + (return-from tag 'left-handler))) + (error #'(lambda (c) + (declare (ignore c)) + (return-from tag 'right-handler)))) + (error 'type-error :datum nil :expected-type 'vector)))) +(let ((handler-declined nil)) + (and (eq (handler-bind ((type-error #'(lambda (c) + (declare (ignore c)) + (setq handler-declined t)))) + (signal 'type-error :datum nil :expected-type 'vector)) + nil) + handler-declined)) +(let ((handler-declined nil)) + (and (eq (handler-bind ((type-error #'(lambda (c) + (declare (ignore c)) + (push 'outer handler-declined)))) + (handler-bind ((type-error #'(lambda (c) + (declare (ignore c)) + (push 'inner handler-declined)))) + (signal 'type-error :datum nil :expected-type 'vector))) + nil) + (equal handler-declined '(outer inner)))) +(let ((handler-declined nil)) + (and (eq (handler-bind + ((type-error #'(lambda (c) + (declare (ignore c)) + (push 'outer-left-handler handler-declined))) + (type-error #'(lambda (c) + (declare (ignore c)) + (push 'outer-right-handler handler-declined)))) + (handler-bind + ((type-error #'(lambda (c) + (declare (ignore c)) + (push 'inner-left-handler handler-declined))) + (type-error #'(lambda (c) + (declare (ignore c)) + (push 'inner-right-handler handler-declined)))) + (signal 'type-error :datum nil :expected-type 'vector))) + nil) + (equal handler-declined '(outer-right-handler outer-left-handler + inner-right-handler inner-left-handler)))) +(let ((handler-declined nil)) + (and (eq (handler-bind + ((type-error #'(lambda (c) + (declare (ignore c)) + (push 'outer-left-handler handler-declined))) + (type-error #'(lambda (c) + (declare (ignore c)) + (push 'outer-right-handler handler-declined)))) + (handler-bind + ((type-error #'(lambda (c) + (declare (ignore c)) + (push 'inner-left-handler handler-declined))) + (type-error #'(lambda (c) + (signal c) + (push 'inner-right-handler handler-declined)))) + (signal 'type-error :datum nil :expected-type 'vector))) + nil) + (equal handler-declined '(outer-right-handler + outer-left-handler + inner-right-handler + + outer-right-handler + outer-left-handler + + inner-left-handler)))) +(let ((*dynamic-var* nil)) + (declare (special *dynamic-var*)) + (block tag + (handler-bind ((type-error #'(lambda (c) + (declare (ignore c)) + (return-from tag *dynamic-var*)))) + (let ((*dynamic-var* t)) + (declare (special *dynamic-var*)) + (signal 'type-error :datum nil :expected-type 'vector))))) +(let ((declined nil)) + (and (eq nil + (handler-bind ((simple-condition #'(lambda (c) + (declare (ignore c)) + (push 'specific declined)))) + (handler-bind ((condition #'(lambda (c) + (declare (ignore c)) + (push 'general declined)))) + (signal "error")))) + (equal declined '(specific general)))) +(block tag + (handler-bind ((error #'(lambda (c) (return-from tag (typep c 'error))))) + (error "error"))) +(eq 'ok + (block tag + (handler-bind ((error #'(lambda (c) + (declare (ignore c)) + (return-from tag 'ok)))) + (handler-bind ((error #'(lambda (c) + (declare (ignore c)) + (error "error3")))) + (handler-bind ((error #'(lambda (c) + (declare (ignore c)) + (error "error2")))) + (error "error")))))) +(eq 'ok + (block tag + (handler-bind + ((error + #'(lambda (c) + (declare (ignore c)) + (handler-bind + ((error #'(lambda (c) + (declare (ignore c)) + (handler-bind + ((error #'(lambda (c) + (declare (ignore c)) + (return-from tag 'ok)))) + (error "error2"))))) + (error "error1"))))) + (error "error0")))) + + +;; handler-case +(handler-case t) +(handler-case nil + (:no-error (&rest rest) (declare (ignore rest)) t)) +(equal (multiple-value-list (handler-case (values 0 1 2 3 4))) + '(0 1 2 3 4)) +(equal (handler-case (values 0 1 2 3 4) + (:no-error (&rest rest) rest)) + '(0 1 2 3 4)) +(equal (multiple-value-list (handler-case (values 0 1 2 3 4) + (:no-error (&rest rest) (values rest 5 6 7 8)))) + '((0 1 2 3 4) 5 6 7 8)) +(eq t (handler-case t + (type-error () 'type-error) + (error () 'error))) +(eq 'simple-error + (handler-case (error "error!") + (simple-error () 'simple-error) + (error () 'error))) +(eq 'error + (handler-case (error "error!") + (error () 'error) + (simple-error () 'simple-error))) +(eq 'error + (handler-case (error "error!") + (error () 'error) + (condition () 'condition) + (simple-error () 'simple-error))) +(eq 'condition + (handler-case (error "error!") + (condition () 'condition) + (error () 'error) + (simple-error () 'simple-error))) +(eq 'simple-error + (handler-case (signal 'simple-error + :format-control "error!" :format-arguments nil) + (simple-error () 'simple-error) + (error () 'error))) +(eq 'simple-error-left + (handler-case (signal 'simple-error + :format-control "error!" :format-arguments nil) + (simple-error () 'simple-error-left) + (simple-error () 'simple-error-right))) +(eq 'no-one-handled + (handler-case (progn + (signal 'simple-warning + :format-control "warning!" :format-arguments nil) + 'no-one-handled) + (simple-error () 'simple-error) + (error () 'error))) +(equal (handler-case (progn + (signal 'simple-warning + :format-control "warning!" :format-arguments nil) + 'no-one-handled) + (:no-error (&rest rest) (cons 'no-error rest)) + (simple-error () 'simple-error) + (error () 'error)) + '(no-error no-one-handled)) +(let ((where 'out)) + (eq (handler-case (let ((where 'in)) + (declare (ignorable where)) + (error "error!")) + (error () where)) + 'out)) +(let ((where 'out)) + (declare (special where)) + (eq (handler-case (let ((where 'in)) + (declare (special where)) + (error "~S" where)) + (error () where)) + 'out)) +(typep (handler-case (error "error!") + (error (c) c)) + 'simple-error) +(typep (handler-case (error "error!") + (condition (c) c)) + 'simple-error) +(typep (handler-case (signal "condition") + (condition (c) c)) + 'simple-condition) +(typep (handler-case (warn "warning") + (condition (c) c)) + 'simple-warning) + + + +;; restart-bind +(null (restart-bind ())) +(restart-bind () t) +(= (restart-bind () 0 1 2) 2) +(equal (multiple-value-list (restart-bind () 0 1 2 (values 3 4 5))) '(3 4 5)) +(block tag + (restart-bind ((continue #'(lambda (&rest rest) + (declare (ignore rest)) + (return-from tag t)))) + (handler-case (signal "testing simple-signal") + (simple-condition () (invoke-restart 'continue))))) +(block tag + (handler-bind ((simple-condition #'(lambda (condition) + (declare (ignore condition)) + (invoke-restart 'continue)))) + (restart-bind ((continue #'(lambda (&rest rest) + (declare (ignore rest)) + (return-from tag t)))) + (signal "testing simple-condition")))) +(block tag + (restart-bind ((continue #'(lambda (&rest rest) + (declare (ignore rest)) + (return-from tag nil)))) + (handler-bind ((simple-condition #'(lambda (condition) + (declare (ignore condition)) + (invoke-restart 'continue)))) + (restart-bind ((continue #'(lambda (&rest rest) + (declare (ignore rest)) + (return-from tag t)))) + (signal "testing simple-condition"))))) +(block tag + (restart-bind ((continue #'(lambda (&rest rest) + (declare (ignore rest)) + (return-from tag t))) + (continue #'(lambda (&rest rest) + (declare (ignore rest)) + (return-from tag nil)))) + (handler-case (signal "testing simple-signal") + (simple-condition () (invoke-restart 'continue))))) +(block tag + (restart-bind ((continue #'(lambda (&rest rest) + (declare (ignore rest)) + (return-from tag t)) + :report-function #'(lambda (stream) + (format stream "Continue")))) + (handler-case (signal "testing simple-signal") + (simple-condition () (invoke-restart 'continue))))) +(block tag + (restart-bind ((continue #'(lambda (x) (return-from tag x)) + :report-function + #'(lambda (stream) (format stream "Continue")) + :interactive-function #'(lambda () (list t)))) + (handler-case (signal "testing simple-signal") + (simple-condition () (invoke-restart-interactively 'continue))))) +(eq 'ok + (block tag + (restart-bind ((continue #'(lambda (x) (return-from tag x)))) + (handler-case (signal "testing simple-signal") + (simple-condition () (invoke-restart 'continue 'ok)))))) +(block tag + (restart-bind ((continue #'(lambda (x) (return-from tag x)) + :report-function + #'(lambda (stream) (format stream "Continue")) + :interactive-function #'(lambda () (list t)) + :test-function (constantly t))) + (handler-case (signal "testing simple-signal") + (simple-condition () (invoke-restart-interactively 'continue))))) +(block tag + (restart-bind ((continue #'(lambda (x) (return-from tag x)) + :report-function + #'(lambda (stream) (format stream "Continue")) + :interactive-function #'(lambda () (list t)) + :test-function + #'(lambda (c) (or (null c) (typep c 'simple-condition))))) + (handler-case (signal "testing simple-signal") + (simple-condition () (invoke-restart-interactively 'continue))))) +(block tag + (restart-bind ((tb-continue #'(lambda (x) (return-from tag x)) + :interactive-function #'(lambda () (list t)) + :test-function (constantly nil) + :report-function + #'(lambda (stream) (format stream "Continue")))) + (not (find-restart 'tb-continue)))) +(block tag + (restart-bind ((tb-continue #'(lambda (x) (return-from tag x)) + :interactive-function #'(lambda () (list t)) + :test-function (constantly t) + :report-function #'(lambda (stream) (format stream "cont.")))) + (handler-case (signal "testing simple-signal") + (simple-condition () (invoke-restart-interactively 'tb-continue))))) +(null (let ((*dynamic-var* nil)) + (declare (special *dynamic-var*)) + (block tag + (restart-bind ((continue #'(lambda (x) + (declare (ignore x)) + (return-from tag *dynamic-var*)) + :interactive-function #'(lambda () (list t)) + :test-function (constantly t) + :report-function + #'(lambda (stream) (format stream "cont.")))) + (handler-case (let ((*dynamic-var* t)) + (declare (special *dynamic-var*)) + (signal "testing simple-signal")) + (simple-condition () (invoke-restart-interactively 'continue))))))) +(let ((*dynamic-var* nil)) + (declare (special *dynamic-var*)) + (block tag + (restart-bind ((continue #'(lambda (x) + (declare (ignore x)) + (return-from tag *dynamic-var*)) + :interactive-function #'(lambda () (list t)) + :test-function (constantly t) + :report-function + #'(lambda (stream) (format stream "cont.")))) + (handler-bind ((simple-condition + #'(lambda (c) + (declare (ignore c)) + (invoke-restart-interactively 'continue)))) + (let ((*dynamic-var* t)) + (declare (special *dynamic-var*)) + (signal "testing simple-signal")))))) +(block tag + (restart-bind ((nil #'(lambda (&rest rest) + (declare (ignore rest)) + (return-from tag t)))) + (handler-case (signal "testing simple-signal") + (simple-condition () (invoke-restart 'nil))))) + + + +;; restart-case +(restart-case t) +(restart-case t + (continue (&rest rest) (declare (ignore rest)) nil)) +(equal (multiple-value-list (restart-case (values 0 1 2 3 4))) '(0 1 2 3 4)) +(eq 'continued + (restart-case (continue) + (continue (&rest rest) (declare (ignore rest)) 'continued))) +(eq nil + (restart-case (continue) + (continue (&rest rest) (declare (ignore rest))))) +(eq 'continue-left + (restart-case (continue) + (continue (&rest rest) (declare (ignore rest)) 'continue-left) + (continue (&rest rest) (declare (ignore rest)) 'continue-right))) +(null (restart-case (invoke-restart 'continue) + (continue (&rest rest) + :interactive (lambda () (list 0 1 2 3)) + rest))) +(equal (restart-case (invoke-restart-interactively 'continue) + (continue (&rest rest) + :interactive (lambda () (list 0 1 2 3)) + rest)) + '(0 1 2 3)) +(equal (restart-case (invoke-restart-interactively 'continue) + (continue (&rest rest) + :interactive (lambda () (list 0 1 2 3)) + :report "continue" + rest)) + '(0 1 2 3)) +(equal (restart-case (invoke-restart-interactively 'continue) + (continue (&rest rest) + :interactive (lambda () (list 0 1 2 3)) + :report "continue" + :test (lambda (c) (declare (ignore c)) t) + rest)) + '(0 1 2 3)) +(= (restart-case + (handler-bind ((error #'(lambda (c) + (declare (ignore c)) + (invoke-restart 'my-restart 7)))) + (error "Foo.")) + (my-restart (&optional v) v)) + 7) +(eq (handler-bind ((error #'(lambda (c) + (declare (ignore c)) + (invoke-restart 'my-restart 'restarted)))) + (restart-case (error "Boo.") + (my-restart (&optional v) v))) + 'restarted) +(eq (handler-bind ((error #'(lambda (c) + (invoke-restart (find-restart 'my-restart c) + 'restarted)))) + (restart-case (error "Boo.") + (my-restart (&optional v) v))) + 'restarted) + +(> (length + (block tag + (handler-bind ((error #'(lambda (c) + (return-from tag (compute-restarts c))))) + (restart-case (error "Boo.") + (my-restart (&optional v) v) + (my-restart (&optional v) v))))) + 1) +(eq 'ok + (restart-case (invoke-restart 'nil) + (nil (&rest rest) (declare (ignore rest)) 'ok))) + + + + + + +;; compute-restarts +(listp (mapcar #'restart-name (compute-restarts))) +(listp (mapcar #'restart-name + (compute-restarts (make-condition 'simple-error + :format-control "error" + :format-arguments nil)))) +(restart-case (let ((list (compute-restarts))) + (and (member 'my-restart list + :test #'string= :key #'restart-name) + (member 'your-restart list + :test #'string= :key #'restart-name))) + (my-restart ()) + (your-restart ())) +(restart-case (let ((list (compute-restarts))) + (member 'my-restart + (cdr (member 'my-restart list + :test #'string= :key #'restart-name)) + :test #'string= :key #'restart-name)) + (my-restart ()) + (my-restart ())) + + +;; find-restart +(or (find-restart 'continue) t) +(restart-case (find-restart 'my-restart) + (my-restart ())) +(restart-case (find-restart (find-restart 'my-restart)) + (my-restart ())) +(let ((condition (make-condition 'simple-error + :format-control "error" :format-arguments nil))) + (block tag + (handler-bind ((error + #'(lambda (c) + (return-from tag (and (eq c condition) + (find-restart 'my-restart c)))))) + (restart-case (error condition) + (my-restart ()))))) + + +;; restart-name +(string= "MY-RESTART" + (block tag + (handler-bind + ((error + #'(lambda (c) + (return-from tag (restart-name + (find-restart 'my-restart c)))))) + (restart-case (error "error!") + (my-restart ()))))) +(null (block tag + (handler-bind + ((error + #'(lambda (c) + (return-from tag (restart-name + (find-restart 'nil c)))))) + (restart-case (error "error!") + (nil ()))))) + + +;; with-condition-restarts +(null (with-condition-restarts + (make-condition 'simple-error + :format-control "error" :format-arguments nil) + ())) +(with-condition-restarts + (make-condition 'simple-error + :format-control "error" :format-arguments nil) + () t) +(equal + (multiple-value-list + (with-condition-restarts + (make-condition 'simple-error + :format-control "error" :format-arguments nil) + () 0 1 2 (values 3 4 5))) + '(3 4 5)) +(let ((condition (make-condition 'simple-error + :format-control "error" :format-arguments nil)) + (other (make-condition 'simple-error + :format-control "error" :format-arguments nil))) + (block tag + (handler-bind + ((error + #'(lambda (c) + (return-from tag (and (find-restart 'my-restart c) + (null (with-condition-restarts other + (compute-restarts) + (find-restart 'my-restart c)))))))) + (restart-case (progn 3 2 1 'go (error condition)) + (my-restart ()))))) + + +;; with-simple-restart +(null (with-simple-restart (continue "continue"))) +(with-simple-restart (continue "continue") t) +(equal (multiple-value-list + (with-simple-restart (continue "continue") 0 1 (values 2 3 4))) + '(2 3 4)) +(equal (multiple-value-list + (with-simple-restart (continue "continue") + (continue))) + '(nil t)) +(equal (multiple-value-list + (with-simple-restart (continue "continue") + (handler-case (error "boo") + (error (c) (declare (ignore c)) (invoke-restart 'continue))))) + '(nil t)) + + +;; abort +(eq 'ok + (restart-case (abort) + (abort () 'ok))) +(let ((condition (make-condition 'simple-error + :format-control "error" :format-arguments nil))) + (or (find-restart 'abort condition) + (eq 'handled + (handler-case (abort condition) + (control-error () 'handled) + (condition () nil))))) + +;; muffle-warning +(eq 'ok + (restart-case (muffle-warning) + (muffle-warning () 'ok))) +(let ((condition (make-condition 'simple-warning + :format-control "warning" + :format-arguments nil))) + (or (find-restart 'muffle-warning condition) + (eq 'handled + (handler-case (muffle-warning condition) + (control-error () 'handled) + (condition () nil))))) + +;; continue +(eq 'ok + (restart-case (continue) + (continue () 'ok))) +(let ((condition (make-condition 'simple-error + :format-control "error" + :format-arguments nil))) + (or (find-restart 'continue condition) + (null (continue condition)))) + +;; store-value +(eq 'ok + (restart-case (store-value 'ok) + (store-value (value) value))) +(let ((condition (make-condition 'simple-error + :format-control "error" + :format-arguments nil))) + (or (find-restart 'store-value condition) + (null (store-value t condition)))) + +;; use-value +(eq 'ok + (restart-case (use-value 'ok) + (use-value (value) value))) +(let ((condition (make-condition 'simple-error + :format-control "error" + :format-arguments nil))) + (or (find-restart 'use-value condition) + (null (use-value t condition)))) + + + + + +;; assert +(eq (assert t) nil) +(handler-case (assert nil) + (error () t) + (:no-error (&rest rest) (declare (ignore rest)) nil)) +(let ((count 0)) + (and (eq (assert (incf count)) nil) + (= count 1))) +(handler-case (let ((var nil)) (assert var (var) "VAR should be true.")) + (simple-error () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)) +(let ((str (copy-seq "ABC")) + (count 0)) + (and (eq (assert (char= (aref str 0) #\A) ((aref (progn (incf count) str) 0))) + nil) + (zerop count))) +(let ((str (copy-seq "ABC")) + (count 0)) + (and (eq (assert (and (char= (aref str 0) #\A) + (char= (aref str 1) #\B)) + ((aref (progn (incf count) str) 0) + (aref (progn (incf count) str) 1))) + nil) + (zerop count))) +(handler-case (let ((var nil)) + (assert var (var) 'type-error :expected-type 'array)) + (type-error () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)) + + +;; check-type +(null (let ((var nil)) (check-type var null))) +(null (let ((var '(a b c))) (check-type var cons))) +(handler-case (let ((var '(a b c))) (check-type var vector)) + (type-error () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)) +(eq 'handled + (block tag + (handler-bind ((type-error + #'(lambda (c) + (declare (ignore c)) + (return-from tag 'handled))) + (error #'(lambda (c) + (declare (ignore c)) + (return-from tag nil)))) + (let ((var '(a b c))) + (check-type var vector) + var)))) +(string= (block tag + (handler-bind ((type-error + #'(lambda (c) + (declare (ignore c)) + (invoke-restart 'store-value "eat this"))) + (error #'(lambda (c) + (declare (ignore c)) + (return-from tag nil)))) + (let ((var '(a b c))) + (check-type var vector) + var))) + "eat this") + + +;; ignore-errors +(null (ignore-errors)) +(ignore-errors t) +(let ((result (multiple-value-list (ignore-errors (error "error"))))) + (and (null (first result)) + (typep (second result) 'simple-error))) +(equal (multiple-value-list (ignore-errors 'a 'b 'c (values 'd 'e))) + '(d e)) +(let ((result (multiple-value-list + (ignore-errors (signal 'simple-error + :format-control "error" + :format-arguments nil))))) + (and (null (first result)) + (typep (second result) 'simple-error))) +(eq (ignore-errors (signal "only signal") 'ok) 'ok) +(eq (block tag + (handler-bind ((condition #'(lambda (c) + (declare (ignore c)) + (return-from tag 'handled)))) + (ignore-errors (error 'simple-condition + :format-control "only condition" + :format-arguments nil)))) + 'handled) +(let ((result (multiple-value-list + (ignore-errors (warn 'simple-error + :format-control "an error, not a warning" + :format-arguments nil))))) + (and (null (first result)) + (typep (second result) 'type-error))) + diff --git a/Sacla/tests/must-cons.lisp b/Sacla/tests/must-cons.lisp new file mode 100644 index 0000000..a865e70 --- /dev/null +++ b/Sacla/tests/must-cons.lisp @@ -0,0 +1,2309 @@ +;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp> +;; ALL RIGHTS RESERVED. +;; +;; $Id: must-cons.lisp,v 1.4 2004/02/20 07:23:42 yuji Exp $ +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; * Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; * Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(consp (cons 'a 'b)) + +(consp '(1 . 2)) + +(consp (list nil)) + +(not (consp 'a)) + +(not (consp nil)) + +(not (consp 1)) + +(not (consp #\a)) + +(let ((a (cons 1 2))) + (and (eql (car a) 1) + (eql (cdr a) 2))) + +(equal (cons 1 nil) '(1)) + +(equal (cons nil nil) '(nil)) + +(equal (cons 'a (cons 'b (cons 'c '()))) '(a b c)) + +(atom 'a) + +(atom nil) + +(atom 1) + +(atom #\a) + +(not (atom (cons 1 2))) + +(not (atom '(a . b))) + +(not (atom (list nil))) + + +(listp nil) + +(listp '(a b c)) + +(listp '(a . b)) + +(listp (cons 'a 'b)) + +(listp '#1=(1 2 . #1#)) + +(not (listp 1)) + +(not (listp 't)) + +(null '()) +(null 'nil) +(null nil) +(not (null t)) +(null (cdr '(a))) +(not (null (cdr '(1 . 2)))) +(not (null 'a)) + + +(endp '()) +(not (endp '(1))) +(not (endp '(1 2))) +(not (endp '(1 2 3))) +(not (endp (cons 1 2))) +(endp (cddr '(1 2))) + + +(let ((a (cons 1 2))) + (and (eq (rplaca a 0) a) + (equal a '(0 . 2)))) + +(let ((a (list 1 2 3))) + (and (eq (rplaca a 0) a) + (equal a '(0 2 3)))) + +(let ((a (cons 1 2))) + (and (eq (rplacd a 0) a) + (equal a '(1 . 0)))) + +(let ((a (list 1 2 3))) + (and (eq (rplacd a 0) a) + (equal a '(1 . 0)))) + +(eq (car '(a . b)) 'a) + +(null (car nil)) + +(let ((a (cons 1 2))) + (eq (car (list a)) a)) + +(eq (car '#1=(a . #1#)) 'a) + +(eq (cdr '(a . b)) 'b) +(eq (rest '(a . b)) 'b) + +(null (cdr nil)) +(null (rest nil)) + +(let ((a (cons 1 2))) + (eq (cdr (cons 1 a)) a)) +(let ((a (cons 1 2))) + (eq (rest (cons 1 a)) a)) + +(let ((x '#1=(a . #1#))) + (eq (cdr x) x)) +(let ((x '#1=(a . #1#))) + (eq (rest x) x)) + +(eq (caar '((a) b c)) 'a) + +(eq (cadr '(a b c)) 'b) + +(eq (cdar '((a . aa) b c)) 'aa) + +(eq (cddr '(a b . c)) 'c) + +(eq (caaar '(((a)) b c)) 'a) + +(eq (caadr '(a (b) c)) 'b) + +(eq (cadar '((a aa) b c)) 'aa) + +(eq (caddr '(a b c)) 'c) + +(eq (cdaar '(((a . aa)) b c)) 'aa) + +(eq (cdadr '(a (b . bb) c)) 'bb) + +(eq (cddar '((a aa . aaa) b c)) 'aaa) + +(eq (cdddr '(a b c . d)) 'd) + +(eq (caaaar '((((a))) b c)) 'a) + +(eq (caaadr '(a ((b)) c)) 'b) + +(eq (caadar '((a (aa)) b c)) 'aa) + +(eq (caaddr '(a b (c))) 'c) + +(eq (cadaar '(((a aa)) b c)) 'aa) + +(eq (cadadr '(a (b bb) c)) 'bb) + +(eq (caddar '((a aa aaa) b c)) 'aaa) + +(eq (cadddr '(a b c d)) 'd) + +(eq (cdaaar '((((a . aa))) b c)) 'aa) + +(eq (cdaadr '(a ((b . bb)) c)) 'bb) + +(eq (cdadar '((a (aa . aaa)) b c)) 'aaa) + +(eq (cdaddr '(a b (c . cc))) 'cc) + +(eq (cddaar '(((a aa . aaa)) b c)) 'aaa) + +(eq (cddadr '(a (b bb . bbb) c)) 'bbb) + +(eq (cdddar '((a aa aaa . aaaa) b c)) 'aaaa) + +(eq (cddddr '(a b c d . e)) 'e) + +(let ((x (cons 1 2))) + (and (eql (setf (car x) 0) 0) + (equal x '(0 . 2)))) + +(let ((x (cons 1 2))) + (and (eql (setf (cdr x) 0) 0) + (equal x '(1 . 0)))) + +(let ((x (copy-tree '((a) b c)))) + (and (eql (setf (caar x) 0) 0) + (equal x '((0) b c)))) + +(let ((x (list 'a 'b 'c))) + (and (eql (setf (cadr x) 0) 0) + (equal x '(a 0 c)))) + +(let ((x (copy-tree '((a . aa) b c)))) + (and (eql (setf (cdar x) 0) 0) + (equal x '((a . 0) b c)))) + +(let ((x (copy-tree '(a b . c)))) + (and (eql (setf (cddr x) 0) 0) + (equal x '(a b . 0)))) + +(let ((x (copy-tree '(((a)) b c)))) + (and (eql (setf (caaar x) 0) 0) + (equal x '(((0)) b c)))) + +(let ((x (copy-tree '(a (b) c)))) + (and (eql (setf (caadr x) 0) 0) + (equal x '(a (0) c)))) + +(let ((x (copy-tree '((a aa) b c)))) + (and (eql (setf (cadar x) 0) 0) + (equal x '((a 0) b c)))) + +(let ((x (list 'a 'b 'c))) + (and (eql (setf (caddr x) 0) 0) + (equal x '(a b 0)))) + +(let ((x (copy-tree '(((a . aa)) b c)))) + (and (eql (setf (cdaar x) 0) 0) + (equal x '(((a . 0)) b c)))) + +(let ((x (copy-tree '(a (b . bb) c)))) + (and (eql (setf (cdadr x) 0) 0) + (equal x '(a (b . 0) c)))) + +(let ((x (copy-tree '((a aa . aaa) b c)))) + (and (eql (setf (cddar x) 0) 0) + (equal x '((a aa . 0) b c)))) + +(let ((x (copy-tree '(a b c . d)))) + (and (eql (setf (cdddr x) 0) 0) + (equal x '(a b c . 0)))) + +(let ((x (copy-tree '((((a))) b c)))) + (and (eql (setf (caaaar x) 0) 0) + (equal x '((((0))) b c)))) + +(let ((x (copy-tree '(a ((b)) c)))) + (and (eql (setf (caaadr x) 0) 0) + (equal x '(a ((0)) c)))) + +(let ((x (copy-tree '((a (aa)) b c)))) + (and (eql (setf (caadar x) 0) 0) + (equal x '((a (0)) b c)))) + +(let ((x (copy-tree '(a b (c))))) + (and (eql (setf (caaddr x) 0) 0) + (equal x '(a b (0))))) + +(let ((x (copy-tree '(((a aa)) b c)))) + (and (eql (setf (cadaar x) 0) 0) + (equal x '(((a 0)) b c)))) + +(let ((x (copy-tree '(a (b bb) c)))) + (and (eql (setf (cadadr x) 0) 0) + (equal x '(a (b 0) c)))) + +(let ((x (copy-tree '((a aa aaa) b c)))) + (and (eql (setf (caddar x) 0) 0) + (equal x '((a aa 0) b c)))) + +(let ((x (list 'a 'b 'c 'd))) + (and (eql (setf (cadddr x) 0) 0) + (equal x '(a b c 0)))) + +(let ((x (copy-tree '((((a . aa))) b c)))) + (and (eql (setf (cdaaar x) 0) 0) + (equal x '((((a . 0))) b c)))) + +(let ((x (copy-tree '(a ((b . bb)) c)))) + (and (eql (setf (cdaadr x) 0) 0) + (equal x '(a ((b . 0)) c)))) + +(let ((x (copy-tree '((a (aa . aaa)) b c)))) + (and (eql (setf (cdadar x) 0) 0) + (equal x '((a (aa . 0)) b c)))) + +(let ((x (copy-tree '(a b (c . cc))))) + (and (eql (setf (cdaddr x) 0) 0) + (equal x '(a b (c . 0))))) + +(let ((x (copy-tree '(((a aa . aaa)) b c)))) + (and (eql (setf (cddaar x) 0) 0) + (equal x '(((a aa . 0)) b c)))) + +(let ((x (copy-tree '(a (b bb . bbb) c)))) + (and (eql (setf (cddadr x) 0) 0) + (equal x '(a (b bb . 0) c)))) + +(let ((x (copy-tree '((a aa aaa . aaaa) b c)))) + (and (eql (setf (cdddar x) 0) 0) + (equal x '((a aa aaa . 0) b c)))) + +(let ((x (copy-tree '(a b c d . e)))) + (and (eql (setf (cddddr x) 0) 0) + (equal x '(a b c d . 0)))) + +(eq (copy-tree 'a) 'a) + +(eq (copy-tree nil) nil) + +(let* ((a (list 'a)) + (b (list 'b)) + (c (list 'c)) + (x3 (cons c nil)) + (x2 (cons b x3)) + (x (cons a x2)) + (y (copy-tree x))) + (and (not (eq x y)) + (not (eq (car x) (car y))) + (not (eq (cdr x) (cdr y))) + (not (eq (cadr x) (cadr y))) + (not (eq (cddr x) (cddr y))) + (not (eq (caddr x) (caddr y))) + (eq (cdddr x) (cdddr y)) + (equal x y) + (eq (car x) a) (eq (car a) 'a) (eq (cdr a) nil) + (eq (cdr x) x2) + (eq (car x2) b) (eq (car b) 'b) (eq (cdr b) nil) + (eq (cdr x2) x3) + (eq (car x3) c) (eq (car c) 'c) (eq (cdr c) nil) + (eq (cdr x3) nil))) + +(let* ((x (list (list 'a 1) (list 'b 2) (list 'c 3))) + (y (copy-tree x))) + (and (not (eq (car x) (car y))) + (not (eq (cadr x) (cadr y))) + (not (eq (caddr x) (caddr y))))) + +(let* ((x (list (list (list 1)))) + (y (copy-tree x))) + (and (not (eq x y)) + (not (eq (car x) (car y))) + (not (eq (caar x) (caar y))))) + + +(let ((x (list 'a 'b 'c 'd))) + (and (equal (sublis '((a . 1) (b . 2) (c . 3)) x) + '(1 2 3 d)) + (equal x '(a b c d)))) + +(let* ((n (cons 'n nil)) + (m (cons 'm n)) + (l (cons 'l m)) + (x (sublis '((a . 1) (b . 2) (c . 3)) l))) + (and (eq x l) + (eq (car l) 'l) + (eq (cdr l) m) + (eq (car m) 'm) + (eq (cdr m) n) + (eq (car n) 'n) + (eq (cdr n) nil))) + +(eq (sublis '() '()) '()) + +(equal (sublis '() '(1 2 3)) '(1 2 3)) + +(eq (sublis '((a . 1) (b . 2)) '()) nil) + +(equal (sublis '((a b c) (b c d) (c d e)) + '(a b c)) + '((b c) (c d) (d e))) + +(equal (sublis '((a . 1) (b . 2) (c . 3)) + '(((a)) (b) c)) + '(((1)) (2) 3)) + +(equal (sublis '(((a) . 1) ((b) . 2) ((c) . 3)) + '((((a))) ((b)) (c))) + '((((a))) ((b)) (c))) + +(equal (sublis '(((a) . 1) ((b) . 2) ((c) . 3)) + '((((a))) ((b)) (c)) + :test #'equal) + '(((1)) (2) 3)) + +(equal (sublis '(((a) . 1) ((b) . 2) ((c) . 3)) + '((((a))) ((b)) (c)) + :test-not (complement #'equal)) + '(((1)) (2) 3)) + +(equal (sublis '((a . 1) (b . 2) (c . 3)) + '((((a))) ((b)) (c)) + :key #'car) + '(((1)) (2) 3)) + +(equal (sublis '(((a) . 1) ((b) . 2) ((c) . 3)) + '((((a))) ((b)) (c)) + :key #'car + :test #'equal) + '((1) 2 . 3)) + + + +(equal (nsublis '((a . 1) (b . 2) (c . 3)) + (list 'a 'b 'c 'd)) + '(1 2 3 d)) + +(let* ((x (list 'a 'b 'c 'd)) + (y (nsublis '((a . 1) (b . 2) (c . 3)) x))) + (and (eq x y) + (equal x '(1 2 3 d)))) + +(let ((x (list 'l 'm 'n))) + (and (eq (nsublis '((a . 1) (b . 2) (c . 3)) x) x) + (equal x '(l m n)))) + +(let* ((n (cons 'n nil)) + (m (cons 'm n)) + (l (cons 'l m)) + (x (nsublis '((a . 1) (b . 2) (c . 3)) l))) + (and (eq x l) + (eq (car l) 'l) + (eq (cdr l) m) + (eq (car m) 'm) + (eq (cdr m) n) + (eq (car n) 'n) + (eq (cdr n) nil))) + +(eq (nsublis '() '()) '()) + +(equal (nsublis '() '(1 2 3)) '(1 2 3)) + +(eq (nsublis '((a . 1) (b . 2)) '()) nil) + +(equal (nsublis '((a b c) (b c d) (c d e)) + (list 'a 'b 'c)) + '((b c) (c d) (d e))) + +(equal (nsublis '((a . 1) (b . 2) (c . 3)) + (copy-tree '(((a)) (b) c))) + '(((1)) (2) 3)) + +(equal (nsublis '(((a) . 1) ((b) . 2) ((c) . 3)) + (copy-tree '((((a))) ((b)) (c)))) + '((((a))) ((b)) (c))) + +(equal (nsublis '(((a) . 1) ((b) . 2) ((c) . 3)) + (copy-tree '((((a))) ((b)) (c))) + :test #'equal) + '(((1)) (2) 3)) + +(equal (nsublis '(((a) . 1) ((b) . 2) ((c) . 3)) + (copy-tree '((((a))) ((b)) (c))) + :test-not (complement #'equal)) + '(((1)) (2) 3)) + + +(equal (nsublis '((a . 1) (b . 2) (c . 3)) + (copy-tree '((((a))) ((b)) (c))) + :key #'car) + '(((1)) (2) 3)) + +(equal (nsublis '(((a) . 1) ((b) . 2) ((c) . 3)) + (copy-tree '((((a))) ((b)) (c))) + :key 'car + :test #'equal) + '((1) 2 . 3)) + + +(let ((tree '(old (old) ((old))))) + (equal (subst 'new 'old tree) + '(new (new) ((new))))) + +(eq (subst 'new 'old 'old) 'new) + +(eq (subst 'new 'old 'not-old) 'not-old) + +(equal (subst 'new '(b) '(a ((b))) :test #'equal) + '(a (new))) + +(equal (subst 'new '(b) '(a ((b))) :test-not (complement #'equal)) + '(a (new))) + +(equal (subst 'x 3 '(1 (1 2) (1 2 3) (1 2 3 4)) + :key #'(lambda (y) (and (listp y) (third y)))) + '(1 (1 2) X X)) + +(equal (subst 'x "D" '("a" ("a" "b") ("a" "b" "c") ("a" "b" "c" "d")) + :test #'equalp + :key #'(lambda (y) (and (listp y) (fourth y)))) + '("a" ("a" "b") ("a" "b" "c") X)) + + +(equal (subst-if 'new #'(lambda (x) (eq x 'old)) '(old old)) + '(new new)) + +(eq (subst-if 'new #'(lambda (x) (eq x 'old)) 'old) 'new) + +(equal (subst-if 'x #'(lambda (x) (eql x 3)) '(1 (1 2) (1 2 3) (1 2 3 4)) + :key #'(lambda (y) (and (listp y) (third y)))) + '(1 (1 2) x x)) + + +(let ((tree '(old (old) ((old))))) + (equal (subst-if 'new #'(lambda (x) (eq x 'old)) tree) + '(new (new) ((new))))) + +(eq (subst-if 'new #'(lambda (x) (eq x 'old)) 'old) + 'new) + +(eq (subst-if 'new #'(lambda (x) (eq x 'old)) 'not-old) + 'not-old) + +(equal (subst-if 'new #'(lambda (x) (equal x '(b))) '(a ((b)))) + '(a (new))) + +(equal (subst-if 'x + #'(lambda (x) (eql x 3)) '(1 (1 2) (1 2 3) (1 2 3 4)) + :key #'(lambda (y) (and (listp y) (third y)))) + '(1 (1 2) X X)) + +(equal (subst-if 'x + #'(lambda (x) (equalp x "D")) + '("a" ("a" "b") ("a" "b" "c") ("a" "b" "c" "d")) + :key #'(lambda (y) (and (listp y) (fourth y)))) + '("a" ("a" "b") ("a" "b" "c") X)) + + +(equal (subst-if-not 'new #'(lambda (x) (not (eq x 'old))) '(old old)) + '(new new)) + +(eq (subst-if-not 'new #'(lambda (x) (not (eq x 'old))) 'old) 'new) + +(equal (subst-if-not 'x #'(lambda (x) (not (eql x 3))) + '(1 (1 2) (1 2 3) (1 2 3 4)) + :key #'(lambda (y) (and (listp y) (third y)))) + '(1 (1 2) x x)) + + +(let ((tree '(old (old) ((old))))) + (equal (subst-if-not 'new #'(lambda (x) (not (eq x 'old))) tree) + '(new (new) ((new))))) + +(eq (subst-if-not 'new #'(lambda (x) (not (eq x 'old))) 'old) + 'new) + +(eq (subst-if-not 'new #'(lambda (x) (not (eq x 'old))) 'not-old) + 'not-old) + +(equal (subst-if-not 'new #'(lambda (x) (not (equal x '(b)))) '(a ((b)))) + '(a (new))) + +(equal (subst-if-not 'x + #'(lambda (x) (not (eql x 3))) + '(1 (1 2) (1 2 3) (1 2 3 4)) + :key #'(lambda (y) (and (listp y) (third y)))) + '(1 (1 2) X X)) + +(equal (subst-if-not 'x + #'(lambda (x) (not (equalp x "D"))) + '("a" ("a" "b") ("a" "b" "c") ("a" "b" "c" "d")) + :key #'(lambda (y) (and (listp y) (fourth y)))) + '("a" ("a" "b") ("a" "b" "c") X)) + + + +(let ((tree '(old (old) ((old))))) + (equal (nsubst 'new 'old (copy-tree tree)) + '(new (new) ((new))))) + +(let* ((tree (copy-tree '(old (old) ((old))))) + (new-tree (nsubst 'new 'old tree))) + (and (eq tree new-tree) + (equal tree '(new (new) ((new)))))) + +(eq (nsubst 'new 'old 'old) 'new) + +(eq (nsubst 'new 'old 'not-old) 'not-old) + +(equal (nsubst 'new '(b) (copy-tree '(a ((b)))) :test #'equal) + '(a (new))) + +(equal (nsubst 'new '(b) (copy-tree '(a ((b)))) :test-not (complement #'equal)) + '(a (new))) + +(equal (nsubst 'x 3 (copy-tree '(1 (1 2) (1 2 3) (1 2 3 4))) + :key #'(lambda (y) (and (listp y) (third y)))) + '(1 (1 2) X X)) + +(equal (nsubst 'x "D" + (copy-tree '("a" ("a" "b") ("a" "b" "c") ("a" "b" "c" "d"))) + :test #'equalp + :key #'(lambda (y) (and (listp y) (fourth y)))) + '("a" ("a" "b") ("a" "b" "c") X)) + + +(equal (nsubst-if 'new #'(lambda (x) (eq x 'old)) (list 'old 'old)) + '(new new)) + +(eq (nsubst-if 'new #'(lambda (x) (eq x 'old)) 'old) 'new) + +(let* ((x (copy-tree '(old (old) ((old)) (old) old))) + (y (nsubst-if 'new #'(lambda (x) (eq x 'old)) x))) + (and (eq x y) + (equal x '(new (new) ((new)) (new) new)))) + +(equal (nsubst-if 'x + #'(lambda (x) (eql x 3)) + (copy-tree '(1 (1 2) (1 2 3) (1 2 3 4))) + :key #'(lambda (y) (and (listp y) (third y)))) + '(1 (1 2) x x)) + +(let ((tree '(old (old) ((old))))) + (equal (nsubst-if 'new #'(lambda (x) (eq x 'old)) (copy-tree tree)) + '(new (new) ((new))))) + +(eq (nsubst-if 'new #'(lambda (x) (eq x 'old)) 'old) + 'new) + +(eq (nsubst-if 'new #'(lambda (x) (eq x 'old)) 'not-old) + 'not-old) + +(equal (nsubst-if 'new #'(lambda (x) (equal x '(b))) + (copy-tree '(a ((b))))) + '(a (new))) + +(equal (nsubst-if 'x + #'(lambda (x) (eql x 3)) + (copy-tree '(1 (1 2) (1 2 3) (1 2 3 4))) + :key #'(lambda (y) (and (listp y) (third y)))) + '(1 (1 2) X X)) + +(equal (nsubst-if 'x + #'(lambda (x) (equalp x "D")) + (copy-tree '("a" ("a" "b") ("a" "b" "c") ("a" "b" "c" "d"))) + :key #'(lambda (y) (and (listp y) (fourth y)))) + '("a" ("a" "b") ("a" "b" "c") X)) + + +(equal (nsubst-if-not 'new #'(lambda (x) (not (eq x 'old))) + (list 'old 'old)) + '(new new)) + +(eq (nsubst-if-not 'new #'(lambda (x) (not (eq x 'old))) 'old) 'new) + +(let* ((x (copy-tree '(old (old) ((old)) (old) old))) + (y (nsubst-if-not 'new #'(lambda (x) (not (eq x 'old))) x))) + (and (eq x y) + (equal x '(new (new) ((new)) (new) new)))) + +(equal (nsubst-if-not 'x #'(lambda (x) (not (eql x 3))) + (copy-tree '(1 (1 2) (1 2 3) (1 2 3 4))) + :key #'(lambda (y) (and (listp y) (third y)))) + '(1 (1 2) x x)) + +(let ((tree '(old (old) ((old))))) + (equal (nsubst-if-not 'new #'(lambda (x) (not (eq x 'old))) (copy-tree tree)) + '(new (new) ((new))))) + +(eq (nsubst-if-not 'new #'(lambda (x) (not (eq x 'old))) 'old) + 'new) + +(eq (nsubst-if-not 'new #'(lambda (x) (not (eq x 'old))) 'not-old) + 'not-old) + +(equal (nsubst-if-not 'new #'(lambda (x) (not (equal x '(b)))) + (copy-tree '(a ((b))))) + '(a (new))) + +(equal (nsubst-if-not 'x + #'(lambda (x) (not (eql x 3))) + (copy-tree '(1 (1 2) (1 2 3) (1 2 3 4))) + :key #'(lambda (y) (and (listp y) (third y)))) + '(1 (1 2) X X)) + +(equal + (nsubst-if-not 'x + #'(lambda (x) (not (equalp x "D"))) + (copy-tree '("a" ("a" "b") ("a" "b" "c") ("a" "b" "c" "d"))) + :key #'(lambda (y) (and (listp y) (fourth y)))) + '("a" ("a" "b") ("a" "b" "c") X)) + + + +(tree-equal 'a 'a) + +(not (tree-equal 'a 'b)) + +(tree-equal '(a (b (c))) '(a (b (c)))) + +(tree-equal '(a (b (c))) '(a (b (c))) :test #'eq) + +(tree-equal '(a (b (c))) '(a (b (c))) :test-not (complement #'eq)) + +(not (tree-equal '("a" ("b" ("c"))) '("a" ("b" ("c"))))) + +(tree-equal '("a" ("b" ("c"))) '("a" ("b" ("c"))) :test #'equal) + +(tree-equal '("a" ("b" ("c"))) '("a" ("b" ("c"))) + :test-not (complement #'equal)) + +(not (tree-equal '(a b) '(a (b)))) + + +(eq (copy-list '()) '()) + +(equal (copy-list '(a b c)) + '(a b c)) + +(equal (copy-list '(a . b)) '(a . b)) + +(let* ((x '(a b c)) + (y (copy-list x))) + (and (equal x y) + (not (eq x y)))) + +(let* ((a (list 'a)) + (b (list 'b)) + (c (list 'c)) + (x (list a b c)) + (y (copy-list x))) + (and (equal x y) + (not (eq x y)) + (eq (car x) (car y)) + (eq (cadr x) (cadr y)) + (eq (caddr x) (caddr y)) + (eq (caar x) 'a) + (eq (caadr x) 'b) + (eq (caaddr x) 'c))) + + +(null (list)) + +(equal (list 1) '(1)) + +(equal (list 1 2 3) '(1 2 3)) + +(equal (list* 1 2 '(3)) '(1 2 3)) + +(equal (list* 1 2 'x) '(1 2 . x)) + +(equal (list* 1 2 '(3 4)) '(1 2 3 4)) + +(eq (list* 'x) 'x) + + +(eql (list-length '()) 0) + +(eql (list-length '(1)) 1) + +(eql (list-length '(1 2)) 2) + +(null (list-length '#1=(1 2 3 4 . #1#))) + + +(equal (make-list 5) '(nil nil nil nil nil)) + +(equal (make-list 3 :initial-element 'rah) '(rah rah rah)) + +(equal (make-list 2 :initial-element '(1 2 3)) '((1 2 3) (1 2 3))) + +(null (make-list 0)) + +(null (make-list 0 :initial-element 'new-element)) + + +(let ((place nil)) + (and (equal (push 0 place) '(0)) + (equal place '(0)))) + +(let ((place (list 1 2 3))) + (and (equal (push 0 place) '(0 1 2 3)) + (equal place '(0 1 2 3)))) + +(let ((a (list (list 1 2 3) 9))) + (and (equal (push 0 (car a)) '(0 1 2 3)) + (equal a '((0 1 2 3) 9)))) + +(let ((x (copy-tree '(a (b c) d)))) + (and (equal (push 'aa (cadr x)) '(aa b c)) + (equal x '(a (aa b c) d)))) + + +(let ((place (list 1 2 3))) + (and (eql (pop place) 1) + (equal place '(2 3)))) + +(let ((place '())) + (and (eql (pop place) nil) + (equal place '()))) + +(let ((a (list (list 1 2 3) 9))) + (and (eql (pop (car a)) 1) + (equal a '((2 3) 9)))) + +(let ((x (list 'a 'b 'c))) + (and (eq (pop (cdr x)) 'b) + (equal x '(a c)))) + + +(eq (first '(a . b)) 'a) + +(null (first nil)) + +(let ((a (cons 1 2))) + (eq (first (list a)) a)) + +(eq (first '#1=(a . #1#)) 'a) + +(eql (first '(1 2 3)) '1) +(eql (second '(1 2 3)) '2) +(eql (third '(1 2 3)) '3) +(eql (fourth '(1 2 3 4)) '4) +(eql (fifth '(1 2 3 4 5)) '5) +(eql (sixth '(1 2 3 4 5 6)) '6) +(eql (seventh '(1 2 3 4 5 6 7)) '7) +(eql (eighth '(1 2 3 4 5 6 7 8)) '8) +(eql (ninth '(1 2 3 4 5 6 7 8 9)) '9) +(eql (tenth '(1 2 3 4 5 6 7 8 9 10)) '10) + + +(let ((x (list 'a 'b 'c))) + (and (eql (setf (first x) 0) 0) + (equal x '(0 b c)))) + +(let ((x (list 'a 'b 'c))) + (and (eql (setf (second x) 0) 0) + (equal x '(a 0 c)))) + +(let ((x (list 'a 'b 'c))) + (and (eql (setf (third x) 0) 0) + (equal x '(a b 0)))) + +(let ((x (list 'a 'b 'c 'd))) + (and (eql (setf (fourth x) 0) 0) + (equal x '(a b c 0)))) + +(let ((x (list 'a 'b 'c 'd 'e))) + (and (eql (setf (fifth x) 0) 0) + (equal x '(a b c d 0)))) + +(let ((x (list 'a 'b 'c 'd 'e 'f))) + (and (eql (setf (sixth x) 0) 0) + (equal x '(a b c d e 0)))) + +(let ((x (list 'a 'b 'c 'd 'e 'f 'g))) + (and (eql (setf (seventh x) 0) 0) + (equal x '(a b c d e f 0)))) + +(let ((x (list 'a 'b 'c 'd 'e 'f 'g 'h))) + (and (eql (setf (eighth x) 0) 0) + (equal x '(a b c d e f g 0)))) + +(let ((x (list 'a 'b 'c 'd 'e 'f 'g 'h 'i))) + (and (eql (setf (ninth x) 0) 0) + (equal x '(a b c d e f g h 0)))) + +(let ((x (list 'a 'b 'c 'd 'e 'f 'g 'h 'i 'j))) + (and (eql (setf (tenth x) 0) 0) + (equal x '(a b c d e f g h i 0)))) + + +(let ((x '(a b c))) + (eq (nthcdr 0 x) x)) + +(let ((x '(a b c))) + (eq (nthcdr 1 x) (cdr x))) + +(let ((x '(a b c))) + (eq (nthcdr 2 x) (cddr x))) + +(let ((x '(a b c))) + (eq (nthcdr 2 x) (cddr x))) + +(let ((x '(a b c))) + (eq (nthcdr 3 x) (cdddr x))) + +(equal (nthcdr 0 '(0 1 2)) '(0 1 2)) +(equal (nthcdr 1 '(0 1 2)) '(1 2)) +(equal (nthcdr 2 '(0 1 2)) '(2)) +(equal (nthcdr 3 '(0 1 2)) '()) + +(eql (nthcdr 1 '(0 . 1)) 1) + +(eql (nth 0 '(a b c)) 'a) +(eql (nth 1 '(a b c)) 'b) +(eql (nth 2 '(a b c)) 'c) +(eql (nth 3 '(a b c)) '()) +(eql (nth 4 '(a b c)) '()) +(eql (nth 5 '(a b c)) '()) +(eql (nth 6 '(a b c)) '()) + +(eq (nth 0 '(a . b)) 'a) + +(let ((x (list 'a 'b 'c))) + (and (eq (setf (nth 0 x) 'z) 'z) + (equal x '(z b c)))) + +(let ((x (list 'a 'b 'c))) + (and (eq (setf (nth 1 x) 'z) 'z) + (equal x '(a z c)))) + +(let ((x (list 'a 'b 'c))) + (and (eq (setf (nth 2 x) 'z) 'z) + (equal x '(a b z)))) + +(let ((0-to-3 (list 0 1 2 3))) + (and (equal (setf (nth 2 0-to-3) "two") "two") + (equal 0-to-3 '(0 1 "two" 3)))) + + +(eq (nconc) '()) +(equal (nconc nil (list 'a 'b 'c) (list 'd 'e 'f)) + '(a b c d e f)) + +(equal (nconc nil nil (list 'a 'b 'c) (list 'd 'e 'f)) + '(a b c d e f)) + +(equal (nconc nil nil nil (list 'a 'b 'c) (list 'd 'e 'f)) + '(a b c d e f)) + + +(let* ((x (list 'a 'b 'c))) + (eq (nconc x) x)) + +(let* ((x (list 'a 'b 'c)) + (y (list 'd 'e 'f)) + (list (nconc x y))) + (and (eq list x) + (eq (nthcdr 3 list) y) + (equal list '(a b c d e f)))) + +(let* ((x (list 'a)) + (y (list 'b)) + (z (list 'c)) + (list (nconc x y z))) + (and (eq x list) + (eq (first list) 'a) + (eq y (cdr list)) + (eq (second list) 'b) + (eq z (cddr list)) + (eq (third list) 'c))) + +(equal (append '(a b) '() '(c d) '(e f)) + '(a b c d e f)) + +(null (append)) +(null (append '())) +(null (append '() '())) + +(eq (append 'a) 'a) + +(eq (append '() 'a) 'a) + +(eq (append '() '() 'a) 'a) + + +(equal (append '(a b) 'c) '(a b . c)) + +(let* ((x '(a b c)) + (y '(d e f)) + (z (append x y))) + (and (equal z '(a b c d e f)) + (eq (nthcdr 3 z) y) + (not (eq x z)))) + + +(equal (revappend '(a b c) '(d e f)) + '(c b a d e f)) + +(let* ((x '(a b c)) + (y '(d e f)) + (z (revappend x y))) + (and (equal z '(c b a d e f)) + (not (eq x z)) + (eq (nthcdr 3 z) y))) + +(let ((x '(a b c))) + (eq (revappend '() x) x)) + +(null (revappend '() '())) + +(eq (revappend '() 'a) 'a) + +(equal (revappend '(a) 'b) '(a . b)) + +(equal (revappend '(a) '()) '(a)) + +(equal (revappend '(1 2 3) '()) '(3 2 1)) + + +(equal (nreconc (list 'a 'b 'c) '(d e f)) + '(c b a d e f)) + +(let* ((x (list 'a 'b 'c)) + (y '(d e f)) + (z (nreconc x y))) + (and (equal z '(c b a d e f)) + (eq (nthcdr 3 z) y))) + +(let ((x (list 'a 'b 'c))) + (eq (nreconc '() x) x)) + +(null (nreconc '() '())) + +(eq (nreconc '() 'a) 'a) + +(equal (nreconc (list 'a) 'b) '(a . b)) + +(equal (nreconc (list 'a) '()) '(a)) + +(equal (nreconc (list 1 2 3) '()) '(3 2 1)) + + +(null (butlast nil)) +(null (butlast nil 1)) +(null (butlast nil 2)) +(null (butlast nil 3)) +(equal (butlast '(1 2 3 4 5)) '(1 2 3 4)) +(equal (butlast '(1 2 3 4 5) 1) '(1 2 3 4)) +(equal (butlast '(1 2 3 4 5) 2) '(1 2 3)) +(equal (butlast '(1 2 3 4 5) 3) '(1 2)) +(equal (butlast '(1 2 3 4 5) 4) '(1)) +(equal (butlast '(1 2 3 4 5) 5) '()) +(equal (butlast '(1 2 3 4 5) 6) '()) +(equal (butlast '(1 2 3 4 5) 7) '()) + +(equal (butlast '(1 2 3 4 5 . 6)) '(1 2 3 4)) +(equal (butlast '(1 2 3 4 5 . 6) 1) '(1 2 3 4)) +(equal (butlast '(1 2 3 4 5 . 6) 2) '(1 2 3)) +(equal (butlast '(1 2 3 4 5 . 6) 3) '(1 2)) +(equal (butlast '(1 2 3 4 5 . 6) 4) '(1)) +(equal (butlast '(1 2 3 4 5 . 6) 5) '()) +(equal (butlast '(1 2 3 4 5 . 6) 6) '()) +(equal (butlast '(1 2 3 4 5 . 6) 7) '()) + +(let ((a '(1 2 3 4 5))) + (equal (butlast a 3) '(1 2)) + (equal a '(1 2 3 4 5))) + + +(null (nbutlast nil)) +(null (nbutlast nil 1)) +(null (nbutlast nil 2)) +(null (nbutlast nil 3)) +(equal (nbutlast (list 1 2 3 4 5)) '(1 2 3 4)) +(equal (nbutlast (list 1 2 3 4 5) 1) '(1 2 3 4)) +(equal (nbutlast (list 1 2 3 4 5) 2) '(1 2 3)) +(equal (nbutlast (list 1 2 3 4 5) 3) '(1 2)) +(equal (nbutlast (list 1 2 3 4 5) 4) '(1)) +(equal (nbutlast (list 1 2 3 4 5) 5) '()) +(equal (nbutlast (list 1 2 3 4 5) 6) '()) +(equal (nbutlast (list 1 2 3 4 5) 7) '()) + +(equal (nbutlast (list* 1 2 3 4 5 6)) '(1 2 3 4)) +(equal (nbutlast (list* 1 2 3 4 5 6) 1) '(1 2 3 4)) +(equal (nbutlast (list* 1 2 3 4 5 6) 2) '(1 2 3)) +(equal (nbutlast (list* 1 2 3 4 5 6) 3) '(1 2)) +(equal (nbutlast (list* 1 2 3 4 5 6) 4) '(1)) +(equal (nbutlast (list* 1 2 3 4 5 6) 5) '()) +(equal (nbutlast (list* 1 2 3 4 5 6) 6) '()) +(equal (nbutlast (list* 1 2 3 4 5 6) 7) '()) + +(let* ((a '(1 2 3 4 5)) + (b (nbutlast a 3))) + (and (eq a b) + (equal a '(1 2)))) + + +(let ((x '(0 1 2 3 4 5 6 7 8 9))) + (eq (last x) (nthcdr 9 x))) + +(null (last nil)) + +(let ((x '(0 1 . 2))) + (eq (last x) (cdr x))) + +(eql (last '(1 . 2) 0) 2) + +(let ((x '(0 1 2 3 4))) + (eq (last x 0) nil)) + +(let ((x '(0 1 2 3 4))) + (eq (last x) (nthcdr 4 x))) + +(let ((x '(0 1 2 3 4))) + (eq (last x 1) (nthcdr 4 x))) + +(let ((x '(0 1 2 3 4))) + (eq (last x 2) (cdddr x))) + +(let ((x '(0 1 2 3 4))) + (eq (last x 3) (cddr x))) + +(let ((x '(0 1 2 3 4))) + (eq (last x 4) (cdr x))) + +(let ((x '(0 1 2 3 4))) + (eq (last x 5) x)) + +(let ((x '(0 1 2 3 4))) + (eq (last x 6) x)) + +(let ((x '(0 1 2 3 4))) + (eq (last x 7) x)) + +(let ((x '(0 1 2 3 4))) + (eq (last x 8) x)) + + +(tailp '() '()) + +(tailp '() '(1)) + +(tailp '() '(1 2 3 4 5 6 7 8 9)) + +(let ((x '(1 2 3))) + (and (tailp x x) + (tailp (cdr x) x) + (tailp (cddr x) x) + (tailp (cdddr x) x))) + +(let ((x '(1 . 2))) + (and (tailp x x) + (tailp (cdr x) x))) + +(not (tailp nil '(1 . 2))) + +(not (tailp 'x '(1 2 3 4 5 6))) + +(not (tailp (list 1 2 3) '(1 2 3))) + +(let ((x '(1 2 3 4 5 . 6))) + (tailp (last x) x)) + +(let ((x '(1 2 3 4 5 . 6))) + (tailp (last x) x)) + + +(null (ldiff '() '())) + +(equal (ldiff '(1 . 2) 2) '(1)) + +(equal (ldiff '(1 2 3 4 5 6 7 8 9) '()) + '(1 2 3 4 5 6 7 8 9)) + +(let ((x '(1 2 3))) + (and (null (ldiff x x)) + (equal (ldiff x (cdr x)) '(1)) + (equal (ldiff x (cddr x)) '(1 2)) + (equal (ldiff x (cdddr x)) '(1 2 3)))) + +(let* ((x '(1 2 3)) + (y '(a b c)) + (z (ldiff x y))) + (and (not (eq x z)) + (equal z '(1 2 3)))) + +(equal (member 'a '(a b c d)) '(a b c d)) +(equal (member 'b '(a b c d)) '(b c d)) +(equal (member 'c '(a b c d)) '(c d)) +(equal (member 'd '(a b c d)) '(d)) +(equal (member 'e '(a b c d)) '()) +(equal (member 'f '(a b c d)) '()) + +(let ((x '(a b c d))) + (eq (member 'a x) x) + (eq (member 'b x) (cdr x)) + (eq (member 'c x) (cddr x)) + (eq (member 'd x) (cdddr x)) + (eq (member 'e x) nil)) + + +(equal (member 'a '(a b c d) :test #'eq) '(a b c d)) +(equal (member 'b '(a b c d) :test #'eq) '(b c d)) +(equal (member 'c '(a b c d) :test #'eq) '(c d)) +(equal (member 'd '(a b c d) :test #'eq) '(d)) +(equal (member 'e '(a b c d) :test #'eq) '()) +(equal (member 'f '(a b c d) :test #'eq) '()) + +(null (member 'a '())) + +(let* ((x '((1 . a) (2 . b) (3 . c) (4 . d) (5 . e))) + (y (member 'd x :key #'cdr :test #'eq))) + (and (equal y '((4 . d) (5 . e))) + (eq y (nthcdr 3 x)))) + +(let* ((x '((1 . a) (2 . b) (3 . c) (4 . d) (5 . e))) + (y (member 'd x :key #'cdr))) + (and (equal y '((4 . d) (5 . e))) + (eq y (nthcdr 3 x)))) + +(let* ((x '((1 . a) (2 . b) (3 . c) (4 . d) (5 . e))) + (y (member 'd x :key #'cdr :test-not (complement #'eq)))) + (and (equal y '((4 . d) (5 . e))) + (eq y (nthcdr 3 x)))) + +(let* ((x '((1 . a) (2 . b) (3 . c) (4 . d) (5 . e))) + (y (member 'd x :test-not (complement #'eq)))) + (eq y nil)) + +(equal (member 2 '((1 . 2) (3 . 4)) :test-not #'= :key #'cdr) + '((3 . 4))) + +(equal (member-if #'(lambda (x) (eql x 'a)) '(a b c d)) '(a b c d)) +(equal (member-if #'(lambda (x) (eql x 'b)) '(a b c d)) '(b c d)) +(equal (member-if #'(lambda (x) (eql x 'c)) '(a b c d)) '(c d)) +(equal (member-if #'(lambda (x) (eql x 'd)) '(a b c d)) '(d)) +(equal (member-if #'(lambda (x) (eql x 'e)) '(a b c d)) '()) +(equal (member-if #'(lambda (x) (eql x 'f)) '(a b c d)) '()) + +(null (member-if #'(lambda (x) (eql x 'a)) '())) + +(let* ((x '((1 . a) (2 . b) (3 . c) (4 . d) (5 . e))) + (y (member-if #'(lambda (p) (eq p 'd)) x :key #'cdr))) + (and (equal y '((4 . d) (5 . e))) + (eq y (nthcdr 3 x)))) + +(equal (member-if #'cdr '((1) (2 . 2) (3 3 . 3))) + '((2 . 2) (3 3 . 3))) + +(null (member-if #'zerop '(7 8 9))) + + +(equal (member-if-not #'(lambda (x) (not (eql x 'a))) '(a b c d)) '(a b c d)) +(equal (member-if-not #'(lambda (x) (not (eql x 'b))) '(a b c d)) '(b c d)) +(equal (member-if-not #'(lambda (x) (not (eql x 'c))) '(a b c d)) '(c d)) +(equal (member-if-not #'(lambda (x) (not (eql x 'd))) '(a b c d)) '(d)) +(equal (member-if-not #'(lambda (x) (not (eql x 'e))) '(a b c d)) '()) +(equal (member-if-not #'(lambda (x) (not (eql x 'f))) '(a b c d)) '()) + +(null (member-if-not #'(lambda (x) (not (eql x 'a))) '())) + +(let* ((x '((1 . a) (2 . b) (3 . c) (4 . d) (5 . e))) + (y (member-if-not #'(lambda (p) (not (eq p 'd))) x :key #'cdr))) + (and (equal y '((4 . d) (5 . e))) + (eq y (nthcdr 3 x)))) + + +(let ((x '((1 2) (2 3) (3 4) (4 5))) + (y nil)) + (and (eq (mapc #'(lambda (a) (push (car a) y)) x) x) + (equal y '(4 3 2 1)))) + +(let ((dummy nil) + (list-1 '(1 2 3 4))) + (and (eq (mapc #'(lambda (&rest x) (setq dummy (append dummy x))) + list-1 + '(a b c d e) + '(x y z)) + list-1) + (equal dummy '(1 a x 2 b y 3 c z)))) + +(let* ((x '(0 1 2 3)) + (y nil) + (z (mapc #'(lambda (a b c) (push (list a b c) y)) + x '(1 2 3 4) '(2 3 4 5)))) + (and (eq z x) + (equal y '((3 4 5) (2 3 4) (1 2 3) (0 1 2))))) + + +(let* ((x '(0 1 2 3)) + (y nil) + (z (mapc #'(lambda (a b c) (push (list a b c) y)) + nil x '(1 2 3 4) '(2 3 4 5)))) + (and (null z) + (null y))) + +(let ((sum 0)) + (mapc #'(lambda (&rest rest) (setq sum (+ sum (apply #'+ rest)))) + '(0 1 2) + '(1 2 0) + '(2 0 1)) + (eql sum 9)) + +(let ((result 'initial-value) + (list-1 nil)) + (and (eq (mapc #'(lambda (a b) (setq result (cons (cons a b) result))) list-1) list-1) + (eq result 'initial-value))) + +(let ((result 'initial-value) + (list-1 nil)) + (and (eq (mapc #'(lambda (a b) (setq result (cons (cons a b) result))) + list-1 + '(1 2 3)) + list-1) + (eq result 'initial-value))) + +(let ((result 'initial-value) + (list-1 '(1 2 3))) + (and (eq (mapc #'(lambda (a b) (setq result (cons (cons a b) result))) + list-1 + '()) + list-1) + (eq result 'initial-value))) + + +(equal (mapcar #'car '((1 2) (2 3) (3 4) (4 5))) + '(1 2 3 4)) + +(null (mapcar #'identity '())) + +(equal (mapcar #'list '(0 1 2 3) '(a b c d) '(w x y z)) + '((0 a w) (1 b x) (2 c y) (3 d z))) + +(null (mapcar #'list '() '(0 1 2 3) '(1 2 3 4) '(2 3 4 5))) +(null (mapcar #'list '(0 1 2 3) '() '(1 2 3 4) '(2 3 4 5))) +(null (mapcar #'list '(0 1 2 3) '(1 2 3 4) '() '(2 3 4 5))) +(null (mapcar #'list '(0 1 2 3) '(1 2 3 4) '(2 3 4 5) '())) + +(equal (mapcar #'list '(0) '(a b) '(x y z)) '((0 a x))) +(equal (mapcar #'list '(a b) '(0) '(x y z)) '((a 0 x))) +(equal (mapcar #'list '(a b) '(x y z) '(0)) '((a x 0))) + +(equal (mapcar #'cons '(a b c) '(1 2 3)) + '((A . 1) (B . 2) (C . 3))) + + +(equal (mapcan #'cdr (copy-tree '((1 2) (2 3) (3 4) (4 5)))) + '(2 3 4 5)) + +(equal (mapcan #'append + '((1 2 3) (4 5 6) (7 8 9)) + '((a) (b c) (d e f)) + (list (list 'x 'y 'z) (list 'y 'z) (list 'z))) + '(1 2 3 a x y z 4 5 6 b c y z 7 8 9 d e f z)) + +(null (mapcan #'append '((1 2 3) (4 5 6) (7 8 9)) '((a) (b c)) '())) +(null (mapcan #'append '((1 2 3) (4 5 6) (7 8 9)) '() '((a) (b c)))) +(null (mapcan #'append '() '((1 2 3) (4 5 6) (7 8 9)) '((a) (b c)))) + +(equal (mapcan #'list + (list 1 2 3 4 5) + (list 2 3 4 5 6) + (list 3 4 5 6 7) + (list 4 5 6 7 8)) + '(1 2 3 4 2 3 4 5 3 4 5 6 4 5 6 7 5 6 7 8)) + +(equal (mapcan #'(lambda (x y) (if (null x) nil (list x y))) + '(nil nil nil d e) + '(1 2 3 4 5 6)) + '(d 4 e 5)) + +(equal (mapcan #'(lambda (x) (and (numberp x) (list x))) + '(a 1 b c 3 4 d 5)) + '(1 3 4 5)) + + +(equal (maplist #'identity '(a b c d)) + '((a b c d) (b c d) (c d) (d))) + +(equal (maplist #'car '((1 2) (2 3) (3 4) (4 5))) + '((1 2) (2 3) (3 4) (4 5))) + +(equal (maplist #'list '(a b c) '(b c d) '(c d e)) + '(((a b c) (b c d) (c d e)) + ((b c) (c d) (d e)) + ((c) (d) (e)))) + +(equal (maplist #'append '(a b c) '(b c d) '(c d e)) + '((a b c b c d c d e) (b c c d d e) (c d e))) + +(equal (maplist #'append '(a b c) '(b c) '(c)) + '((a b c b c c))) + +(null (maplist #'append '() '(a b c) '(b c) '(c))) +(null (maplist #'append '(a b c) '() '(b c) '(c))) +(null (maplist #'append '(a b c) '(b c) '(c) '())) + +(let ((x '((1 2) (2 3) (3 4) (4 5))) + (y nil)) + (and (eq (mapl #'(lambda (a) (push (car a) y)) x) x) + (equal y '((4 5) (3 4) (2 3) (1 2))))) + +(let ((x nil)) + (and (null (mapl #'(lambda (&rest rest) (push rest x)) '() '(0) '(0 1))) + (null x))) + +(let ((x nil)) + (and (equal (mapl #'(lambda (&rest rest) (push rest x)) '(0) '() '(0 1)) + '(0)) + (null x))) + +(let ((x nil)) + (and (equal (mapl #'(lambda (&rest rest) (push rest x)) '(0) '(0 1) '()) + '(0)) + (null x))) + +(equal (mapcon #'car (copy-tree '((1 2) (2 3) (3 4) (4 5)))) + '(1 2 2 3 3 4 4 5)) + + +(equal (mapcon #'list '(0 1 2 3) '(1 2 3 4) '(2 3 4 5) '(3 4 5 6)) + '((0 1 2 3) (1 2 3 4) (2 3 4 5) (3 4 5 6) (1 2 3) (2 3 4) (3 4 5) + (4 5 6) (2 3) (3 4) (4 5) (5 6) (3) (4) (5) (6))) + + +(null (mapcon #'list '() '(0 1 2 3) '(1 2 3 4) '(2 3 4 5) '(3 4 5 6))) +(null (mapcon #'list '(0 1 2 3) '() '(1 2 3 4) '(2 3 4 5) '(3 4 5 6))) +(null (mapcon #'list '(0 1 2 3) '(1 2 3 4) '() '(2 3 4 5) '(3 4 5 6))) +(null (mapcon #'list '(0 1 2 3) '(1 2 3 4) '(2 3 4 5) '() '(3 4 5 6))) +(null (mapcon #'list '(0 1 2 3) '(1 2 3 4) '(2 3 4 5) '(3 4 5 6) '())) + + +(let* ((x '((apple . 1) (orange . 2) (grapes . 3))) + (y (acons 'plum 9 x))) + (and (equal y '((plum . 9) (apple . 1) (orange . 2) (grapes . 3))) + (eq x (cdr y)))) + +(equal (acons 'a '0 nil) '((a . 0))) + +(equal (acons 'apple 1 (acons 'orange 2 (acons 'grapes '3 nil))) + '((apple . 1) (orange . 2) (grapes . 3))) + +(equal (acons nil nil nil) '((nil))) + + +(let ((alist '((x . 100) (y . 200) (z . 50)))) + (eq (assoc 'y alist) (cadr alist))) + +(null (assoc 'no-such-key '((x . 100) (y . 200) (z . 50)))) + +(let ((alist '((x . 100) (y . 200) (z . 50)))) + (eq (assoc 'y alist :test #'eq) (cadr alist))) + +(null (assoc 'key '())) +(null (assoc 'nil '(()))) +(null (assoc 'nil '(() ()))) +(let ((alist '(nil nil nil (x . 100) (y . 200) (z . 50)))) + (eq (assoc 'y alist) (car (cddddr alist)))) +(let ((alist '((1 . a) nil (2 . b) (nil)))) + (eq (assoc 'nil alist) (cadddr alist))) + +(let ((alist '((x . 100) (y . 200) (x . 100) (z . 50)))) + (eq (assoc 'y alist) (cadr alist))) + +(let ((alist '((a . 1) (b . 2) (c . 3) (d . 4)))) + (eq (assoc 'a alist :test-not (complement #'eq)) (car alist))) + +(let ((alist '((a . 1) (b . 2) (c . 3) (d . 4)))) + (null (assoc 'z alist :test-not (complement #'eq)))) + +(let ((alist '(((a aa aaa)) ((b bb bbb)) ((c cc ccc)) ((d dd ddd))))) + (eq (assoc 'aa alist :key #'cadr :test #'eq) (car alist))) + +(let ((alist '(((a aa aaa)) ((b bb bbb)) ((c cc ccc)) ((d dd ddd))))) + (eq (assoc 'bb alist :key #'cadr :test #'eq) (cadr alist))) + +(let ((alist '(((a aa aaa)) ((b bb bbb)) ((c cc ccc)) ((d dd ddd))))) + (eq (assoc 'cc alist :key #'cadr :test #'eq) (caddr alist))) + +(let ((alist '(((a aa aaa)) ((b bb bbb)) ((c cc ccc)) ((d dd ddd))))) + (eq (assoc 'dd alist :key #'cadr :test #'eq) (cadddr alist))) + +(let ((alist '(((a aa aaa)) ((b bb bbb)) ((c cc ccc)) ((d dd ddd))))) + (null (assoc 'ee alist :key #'cadr :test #'eq))) + +(let ((alist '(((a aa aaa)) nil ((b bb bbb)) ((c cc ccc)) ((d dd ddd))))) + (eq (assoc 'dd alist :key #'cadr :test #'eq) (car (cddddr alist)))) + +(let ((alist '(((a aa aaa)) ((b bb bbb)) nil ((c cc ccc)) ((d dd ddd))))) + (eq (assoc 'dd alist :key #'cadr :test #'eq) (car (cddddr alist)))) + +(let ((alist '(((a aa aaa)) nil ((b bb bbb)) ((c cc ccc)) ((d dd ddd))))) + (eq (assoc 'dd alist :key #'cadr :test #'eq) (car (cddddr alist)))) + +(let ((alist '(((a aa aaa)) ((b bb bbb)) ((c cc ccc)) ((d dd ddd)) nil))) + (eq (assoc 'dd alist :key #'cadr :test #'eq) (cadddr alist))) + + + +(let ((alist '((x . 100) (y . 200) (z . 50)))) + (eq (assoc-if #'(lambda (arg) (eq arg 'y)) alist) (cadr alist))) + +(null (assoc-if #'consp '((x . 100) (y . 200) (z . 50)))) + +(null (assoc-if #'(lambda (x) (eq x 'key)) '())) +(null (assoc-if #'identity '(()))) +(null (assoc-if #'identity '(() ()))) +(let ((alist '(nil nil nil (x . 100) (y . 200) (z . 50)))) + (eq (assoc-if #'(lambda (arg) (eq arg 'y)) alist) (car (cddddr alist)))) +(let ((alist '((1 . a) nil (2 . b) (nil)))) + (eq (assoc-if #'(lambda (arg) (null arg)) alist) (cadddr alist))) + + +(let ((alist '(((a aa aaa)) ((b bb bbb)) ((c cc ccc)) ((d dd ddd))))) + (eq (assoc-if #'(lambda (x) (eq x 'aa)) alist :key #'cadr) (car alist))) + +(let ((alist '(((a aa aaa)) ((b bb bbb)) ((c cc ccc)) ((d dd ddd))))) + (eq (assoc-if #'(lambda (x) (eq x 'bb)) alist :key #'cadr) (cadr alist))) + +(let ((alist '(((a aa aaa)) ((b bb bbb)) ((c cc ccc)) ((d dd ddd))))) + (null (assoc-if #'(lambda (x) (eq x 'ee)) alist :key #'cadr))) + + + +(let ((alist '((x . 100) (y . 200) (z . 50)))) + (eq (assoc-if-not #'(lambda (arg) (not (eq arg 'y))) alist) (cadr alist))) + +(null (assoc-if-not (complement #'consp) '((x . 100) (y . 200) (z . 50)))) + +(null (assoc-if-not #'(lambda (x) (not (eq x 'key))) '())) +(null (assoc-if-not #'identity '(()))) +(null (assoc-if-not #'identity '(() ()))) +(let ((alist '(nil nil nil (x . 100) (y . 200) (z . 50)))) + (eq (assoc-if-not #'(lambda (arg) (not (eq arg 'y))) alist) + (car (cddddr alist)))) +(let ((alist '((1 . a) nil (2 . b) (nil)))) + (eq (assoc-if-not #'identity alist) (cadddr alist))) + +(let ((alist '(((a aa aaa)) ((b bb bbb)) ((c cc ccc)) ((d dd ddd))))) + (eq (assoc-if-not #'(lambda (x) (not (eq x 'aa))) alist :key #'cadr) + (car alist))) + +(let ((alist '(((a aa aaa)) ((b bb bbb)) ((c cc ccc)) ((d dd ddd))))) + (eq (assoc-if-not #'(lambda (x) (not (eq x 'bb))) alist :key #'cadr) + (cadr alist))) + +(let ((alist '(((a aa aaa)) ((b bb bbb)) ((c cc ccc)) ((d dd ddd))))) + (null (assoc-if-not #'(lambda (x) (not (eq x 'ee))) alist :key #'cadr))) + + +(equal (copy-alist '((a . 10) (b . 100) (c . 1000))) + '((a . 10) (b . 100) (c . 1000))) + +(let* ((alist '((a . 10) (b . 100) (c . 1000))) + (copy (copy-alist alist))) + (and (not (eq alist copy)) + (not (eq (cdr alist) (cdr copy))) + (not (eq (cddr alist) (cddr copy))) + (not (eq (car alist) (car copy))) + (not (eq (cadr alist) (cadr copy))) + (not (eq (caddr alist) (caddr copy))))) + +(let* ((alist '((a 10 x) (b 100 y) (c 1000 z))) + (copy (copy-alist alist))) + (and (not (eq alist copy)) + (not (eq (cdr alist) (cdr copy))) + (not (eq (cddr alist) (cddr copy))) + (not (eq (car alist) (car copy))) + (not (eq (cadr alist) (cadr copy))) + (not (eq (caddr alist) (caddr copy))) + (eq (cdar alist) (cdar copy)) + (eq (cdadr alist) (cdadr copy)) + (eq (cdaddr alist) (cdaddr copy)))) + + +(let* ((alist (pairlis '(x y z) '(xx yy zz) '((a . aa) (b . bb))))) + (and (equal (assoc 'x alist) '(x . xx)) + (equal (assoc 'y alist) '(y . yy)) + (equal (assoc 'z alist) '(z . zz)) + (equal (assoc 'a alist) '(a . aa)) + (equal (assoc 'b alist) '(b . bb)) + (null (assoc 'key alist)))) + +(let* ((alist (pairlis '(x y z) '(xx yy zz)))) + (and (equal (assoc 'x alist) '(x . xx)) + (equal (assoc 'y alist) '(y . yy)) + (equal (assoc 'z alist) '(z . zz)) + (null (assoc 'key alist)))) + + +(let ((alist '((x . 100) (y . 200) (z . 50)))) + (eq (rassoc '200 alist) (cadr alist))) + +(null (rassoc 'no-such-datum '((x . 100) (y . 200) (z . 50)))) + +(let ((alist '((x . 100) (y . 200) (z . 50)))) + (eq (rassoc '200 alist :test #'=) (cadr alist))) + +(null (rassoc 'key '())) +(null (rassoc 'nil '(()))) +(null (rassoc 'nil '(() ()))) + +(let ((alist '(nil nil nil (x . 100) (y . 200) (z . 50)))) + (eq (rassoc '200 alist) (car (cddddr alist)))) +(let ((alist '((1 . a) nil (2 . b) (nil)))) + (eq (rassoc 'nil alist) (cadddr alist))) + +(let ((alist '((x . 100) (y . 200) (x . 100) (z . 50)))) + (eq (rassoc '200 alist) (cadr alist))) + +(let ((alist '((a . 1) (b . 2) (c . 3) (d . 4)))) + (eq (rassoc '1 alist :test-not (complement #'=)) (car alist))) + +(let ((alist '((a . 1) (b . 2) (c . 3) (d . 4)))) + (null (rassoc '9 alist :test-not (complement #'=)))) + +(let ((alist '((a aa aaa) (b bb bbb) (c cc ccc) (d dd ddd)))) + (eq (rassoc 'aa alist :key #'car :test #'eq) (car alist))) + +(let ((alist '((a aa aaa) (b bb bbb) (c cc ccc) (d dd ddd)))) + (eq (rassoc 'ddd alist :key #'cadr :test #'eq) (cadddr alist))) + +(let ((alist '((a aa aaa) (b bb bbb) (c cc ccc) (d dd ddd)))) + (null (rassoc 'eee alist :key #'cadr :test #'eq))) + +(let ((alist '((a aa aaa) nil (b bb bbb) (c cc ccc) (d dd ddd)))) + (eq (rassoc 'ddd alist :key #'cadr :test #'eq) (car (cddddr alist)))) + +(let ((alist '((a aa aaa) (b bb bbb) nil (c cc ccc) (d dd ddd)))) + (eq (rassoc 'ddd alist :key #'cadr :test #'eq) (car (cddddr alist)))) + +(let ((alist '((a aa aaa) (b bb bbb) (c cc ccc) (d dd ddd) nil))) + (eq (rassoc 'ddd alist :key #'cadr :test #'eq) (car (cdddr alist)))) + +(let ((alist '((x . 100) (y . 200) (z . 50)))) + (eq (rassoc-if #'(lambda (arg) (= arg 200)) alist) (cadr alist))) + +(null (rassoc-if #'consp '((x . 100) (y . 200) (z . 50)))) + +(null (rassoc-if #'(lambda (x) (eq x 'key)) '())) +(null (rassoc-if #'identity '(()))) +(null (rassoc-if #'identity '(() ()))) +(let ((alist '(nil nil nil (x . 100) (y . 200) (z . 50)))) + (eq (rassoc-if #'(lambda (arg) (= arg 200)) alist) (car (cddddr alist)))) +(let ((alist '((1 . a) nil (2 . b) (nil)))) + (eq (rassoc-if #'(lambda (arg) (null arg)) alist) (cadddr alist))) + +(let ((alist '((a aa aaa) (b bb bbb) (c cc ccc) (d dd ddd)))) + (eq (rassoc-if #'(lambda (x) (eq x 'aaa)) alist :key #'cadr) (car alist))) + +(let ((alist '((a aa aaa) (b bb bbb) (c cc ccc) (d dd ddd)))) + (eq (rassoc-if #'(lambda (x) (eq x 'bbb)) alist :key #'cadr) (cadr alist))) + +(let ((alist '((a aa aaa) (b bb bbb) (c cc ccc) (d dd ddd)))) + (null (rassoc-if #'(lambda (x) (eq x 'eee)) alist :key #'cadr))) + + +(let ((alist '((x . 100) (y . 200) (z . 50)))) + (eq (rassoc-if-not #'(lambda (arg) (not (= arg 200))) alist) (cadr alist))) + +(null (rassoc-if-not (complement #'consp) '((x . 100) (y . 200) (z . 50)))) + +(null (rassoc-if-not #'(lambda (x) (not (eq x 'key))) '())) +(null (rassoc-if-not #'identity '(()))) +(null (rassoc-if-not #'identity '(() ()))) +(let ((alist '(nil nil nil (x . 100) (y . 200) (z . 50)))) + (eq (rassoc-if-not #'(lambda (arg) (not (= arg 200))) alist) + (car (cddddr alist)))) +(let ((alist '((1 . a) nil (2 . b) (nil)))) + (eq (assoc-if-not #'identity alist) (cadddr alist))) + +(let ((alist '((a aa aaa) (b bb bbb) (c cc ccc) (d dd ddd)))) + (eq (rassoc-if-not #'(lambda (x) (not (eq x 'aaa))) alist :key #'cadr) + (car alist))) + +(let ((alist '((a aa aaa) (b bb bbb) (c cc ccc) (d dd ddd)))) + (eq (rassoc-if-not #'(lambda (x) (not (eq x 'bbb))) alist :key #'cadr) + (cadr alist))) + +(let ((alist '(((a aa aaa) . 0) ((b bb bbb) . 1) ((c cc ccc) . 2)))) + (eq (rassoc-if-not #'(lambda (x) (not (= x '2))) alist :key #'1+) + (cadr alist))) + + +(let ((plist '(prop1 1 prop2 2 prop3 3 prop4 4))) + (multiple-value-bind (indicator value tail) + (get-properties plist '(prop3 prop4 propX propY)) + (and (eq indicator 'prop3) + (eql value 3) + (eq tail (nthcdr 4 plist))))) + +(multiple-value-bind (indicator value tail) + (get-properties '(prop1 1 prop2 2 prop3 3 prop4 4) + '(propX propY propZ)) + (and (eq indicator nil) + (eq value nil) + (eq tail nil))) + +(let ((plist '(prop1 1 prop2 2 prop3 3 prop4 4))) + (multiple-value-bind (indicator value tail) + (get-properties plist '(prop1)) + (and (eq indicator 'prop1) + (eql value 1) + (eq tail plist)))) + +(let ((plist '(prop1 1 nil nil prop2 2 prop3 3 prop4 4))) + (multiple-value-bind (indicator value tail) + (get-properties plist '(nil)) + (and (eq indicator nil) + (eql value nil) + (eq tail (cddr plist))))) + +(let ((plist '(prop1 1 prop2 2 prop3 3 prop4 4))) + (multiple-value-bind (indicator value tail) + (get-properties plist '(prop3 prop4 propX propY prop1)) + (and (eq indicator 'prop1) + (eql value 1) + (eq tail plist)))) + + +(let ((plist '(prop1 1 prop2 2 prop3 3 prop4 4))) + (eql (getf plist 'prop1) 1)) + +(let ((plist '(prop1 1 prop2 2 prop3 3 prop4 4))) + (eql (getf plist 'prop2) 2)) + +(let ((plist '(prop1 1 prop2 2 prop3 3 prop4 4))) + (eql (getf plist 'prop3) 3)) + +(let ((plist '(prop1 1 prop2 2 prop3 3 prop4 4))) + (eql (getf plist 'prop4) 4)) + +(let ((plist + '(prop1 1 prop2 2 prop3 3 prop4 4 prop1 5 prop2 6 prop3 7 prop4 8))) + (eql (getf plist 'prop1) 1)) + +(let ((plist + '(prop1 1 prop2 2 prop3 3 prop4 4 prop1 5 prop2 6 prop3 7 prop4 8))) + (eql (getf plist 'prop2) 2)) + +(let ((plist + '(prop1 1 prop2 2 prop3 3 prop4 4 prop1 5 prop2 6 prop3 7 prop4 8))) + (eql (getf plist 'prop3) 3)) + +(let ((plist + '(prop1 1 prop2 2 prop3 3 prop4 4 prop1 5 prop2 6 prop3 7 prop4 8))) + (eql (getf plist 'prop4) 4)) + +(let ((plist + '(prop1 1 prop2 2 prop3 3 prop4 4 prop1 5 prop2 6 prop3 7 prop4 8))) + (null (getf plist 'propX))) + +(let ((plist '(prop1 1 prop2 2 prop3 3 prop4 4))) + (eq (getf plist 'weird-property 'not-found) 'not-found)) + + +(let ((plist (copy-list '(prop1 1 prop2 2 prop3 3 prop4 4)))) + (and (eql (setf (getf plist 'prop1) 9) 9) + (eql (getf plist 'prop1) 9))) + +(let ((plist nil)) + (and (eql (setf (getf plist 'prop1) 9) 9) + (eql (getf plist 'prop1) 9))) + +(let ((plist '())) + (incf (getf plist 'count 0)) + (eql (getf plist 'count) 1)) + +(let ((x (list nil))) + (and (eql (setf (getf (car x) 'prop1) 9) 9) + (eql (getf (car x) 'prop1) 9))) + + +(let ((plist (list 'p1 1 'p2 2 'p3 3 'p4 4))) + (and (remf plist 'p2) + (eq (getf plist 'p2 'not-found) 'not-found))) + +(let ((plist (list 'p1 1 'p2 2 'p3 3 'p4 4))) + (and (remf plist 'p3) + (eq (getf plist 'p3 'not-found) 'not-found))) + +(let ((plist (list 'p1 1 'p2 2 'p3 3 'p4 4))) + (and (remf plist 'p4) + (eq (getf plist 'p4 'not-found) 'not-found))) + +(let ((plist (list 'p1 1 'p2 2 'p3 3 'p4 4))) + (and (null (remf plist 'pX)) + (equal plist '(p1 1 p2 2 p3 3 p4 4)))) + +(let ((plist (list 'p1 1 'p2 2 'p3 3 'p4 4))) + (and (remf plist 'p4) + (remf plist 'p2) + (remf plist 'p3) + (remf plist 'p1) + (null (remf plist 'pX)) + (null (remf plist 'p1)) + (null (remf plist 'p2)) + (null (remf plist 'p3)) + (null (remf plist 'p4)) + (null plist))) + + +(let ((plist (list 'p1 1 'p2 2 'p3 3 'p4 4 'p1 5 'p2 6 'p3 7 'p4 8))) + (and (remf plist 'p4) + (remf plist 'p2) + (remf plist 'p3) + (remf plist 'p1) + (null (remf plist 'pX)) + (eql (getf plist 'p1) 5) + (eql (getf plist 'p2) 6) + (eql (getf plist 'p3) 7) + (eql (getf plist 'p4) 8))) + +(let ((plist (list 'p1 100 'p1 1 'p2 2 'p3 3 'p4 4))) + (and (eql (getf plist 'p1) 100) + (remf plist 'p1) + (eql (getf plist 'p1) 1) + (remf plist 'p1) + (null (getf plist 'p1)))) + +(let ((plist (list 'p1 1 'p2 2 'p3 3 'p4 4))) + (and (remf plist 'p4) + (null (getf plist 'p4)))) + + +(let ((list1 (list 1 1 2 3 4 'a 'b 'c "A" "B" "C" "d")) + (list2 (list 1 4 5 'b 'c 'd "a" "B" "c" "D"))) + (null (set-exclusive-or (intersection list1 list2) '(C B 4 1 1))) + (null (set-exclusive-or (intersection list1 list2 :test 'equal) + '("B" C B 4 1 1) + :test 'equal)) + (null (set-exclusive-or (intersection list1 list2 :test #'equalp) + '("d" "C" "B" "A" C B 4 1 1) + :test #'equalp))) + +(null (intersection '(0 1 2) '())) +(null (intersection '() '())) +(null (intersection '() '(0 1 2))) +(equal (intersection '(0) '(0)) '(0)) +(equal (intersection '(0 1 2 3) '(2)) '(2)) +(member 0 (intersection '(0 0 0 0 0) '(0 1 2 3 4 5))) +(null (set-exclusive-or (intersection '(0 1 2 3 4) '(4 3 2 1 0)) + '(4 3 2 1 0))) +(null (set-exclusive-or (intersection '(0 1 2 3 4) '(0 1 2 3 4)) + '(0 1 2 3 4))) +(null (set-exclusive-or (intersection '(0 1 2 3 4) '(4 3 2 1 0)) + '(0 1 2 3 4))) + + +(let ((list1 (list "A" "B" "C" "d" "e" "F" "G" "h")) + (list2 (list "a" "B" "c" "D" "E" "F" "g" "h"))) + (null (set-exclusive-or (intersection list1 list2 + :test #'char= + :key #'(lambda (x) (char x 0))) + '("B" "F" "h") + :test #'char= + :key #'(lambda (x) (char x 0))))) + +(let ((list1 (list "A" "B" "C" "d" "e" "F" "G" "h")) + (list2 (list "a" "B" "c" "D" "E" "F" "g" "h"))) + (null (set-exclusive-or (intersection list1 list2 + :test #'char-equal + :key #'(lambda (x) (char x 0))) + '("A" "B" "C" "d" "e" "F" "G" "h") + :test #'char-equal + :key #'(lambda (x) (char x 0))))) + +(let ((list1 (list "A" "B" "C" "d")) + (list2 (list "D" "E" "F" "g" "h"))) + (null (set-exclusive-or (intersection list1 list2 + :test #'char-equal + :key #'(lambda (x) (char x 0))) + '("d") + :test #'char-equal + :key #'(lambda (x) (char x 0))))) + + + + +(let ((list1 (list 1 1 2 3 4 'a 'b 'c "A" "B" "C" "d")) + (list2 (list 1 4 5 'b 'c 'd "a" "B" "c" "D"))) + (null (set-exclusive-or (nintersection (copy-list list1) list2) '(C B 4 1 1))) + (null (set-exclusive-or (nintersection (copy-list list1) list2 :test 'equal) + '("B" C B 4 1 1) + :test 'equal)) + (null (set-exclusive-or (nintersection (copy-list list1) list2 :test #'equalp) + '("d" "C" "B" "A" C B 4 1 1) + :test #'equalp))) + +(null (nintersection (list 0 1 2) '())) +(null (nintersection '() '())) +(null (nintersection '() '(0 1 2))) +(equal (nintersection (list 0) '(0)) '(0)) +(equal (nintersection (list 0 1 2 3) '(2)) '(2)) +(member 0 (nintersection (list 0 0 0 0 0) '(0 1 2 3 4 5))) +(null (set-exclusive-or (nintersection (list 0 1 2 3 4) '(4 3 2 1 0)) + '(4 3 2 1 0))) +(null (set-exclusive-or (nintersection (list 0 1 2 3 4) '(0 1 2 3 4)) + '(0 1 2 3 4))) +(null (set-exclusive-or (nintersection (list 0 1 2 3 4) '(4 3 2 1 0)) + '(0 1 2 3 4))) + + +(let ((list1 (list "A" "B" "C" "d" "e" "F" "G" "h")) + (list2 (list "a" "B" "c" "D" "E" "F" "g" "h"))) + (null (set-exclusive-or (nintersection list1 list2 + :test #'char= + :key #'(lambda (x) (char x 0))) + '("B" "F" "h") + :test #'char= + :key #'(lambda (x) (char x 0))))) + +(let ((list1 (list "A" "B" "C" "d" "e" "F" "G" "h")) + (list2 (list "a" "B" "c" "D" "E" "F" "g" "h"))) + (null (set-exclusive-or (nintersection list1 list2 + :test #'char-equal + :key #'(lambda (x) (char x 0))) + '("A" "B" "C" "d" "e" "F" "G" "h") + :test #'char-equal + :key #'(lambda (x) (char x 0))))) + +(let ((list1 (list "A" "B" "C" "d")) + (list2 (list "D" "E" "F" "g" "h"))) + (null (set-exclusive-or (nintersection list1 list2 + :test #'char-equal + :key #'(lambda (x) (char x 0))) + '("d") + :test #'char-equal + :key #'(lambda (x) (char x 0))))) + + +(let ((set '(a b c))) + (eq (adjoin 'a set) set)) + +(let* ((set '(a b c)) + (new-set (adjoin 'x set))) + (and (equal new-set '(x a b c)) + (eq set (cdr new-set)))) + +(equal (adjoin 1 nil) '(1)) +(equal (adjoin nil nil) '(nil)) +(equal (adjoin nil '(nil)) '(nil)) +(let ((set '((test-item 1)))) + (equal (adjoin '(test-item 1) set) '((test-item 1) (test-item 1)))) + +(let ((set '((test-item 1)))) + (equal (adjoin '(test-item 1) set) + '((test-item 1) (test-item 1)))) + +(let ((set '((test-item 1)))) + (eq (adjoin '(test-item 1) set :test #'equal) set)) + +(let ((set '((test-item 1)))) + (eq (adjoin '(test-item) set :key #'car) set)) + +(let ((set '((test-item 1)))) + (eq (adjoin '(test-item) set :key #'car :test #'eq) set)) + +(let ((set '(("test-item" 1)))) + (eq (adjoin '("test-item") set :key #'car :test #'equal) set)) + + +(let ((set '((test-item 1)))) + (eq (adjoin '(test-item 1) set :test-not (complement #'equal)) set)) + +(let ((set '((test-item 1)))) + (eq (adjoin '(test-item) set :test-not (complement #'eql) :key #'car) set)) + +(let ((set '((test-item 1)))) + (eq (adjoin '(test-item) set :key #'car :test-not (complement #'eq)) set)) + +(let ((set '(("test-item" 1)))) + (eq (adjoin '("test-item") set :key #'car :test-not (complement #'equal)) + set)) + + +(let ((place nil)) + (and (equal (pushnew 'a place) '(a)) + (equal place '(a)))) + +(let ((place nil)) + (and (equal (pushnew 'a place) '(a)) + (equal place '(a)))) + +(let ((place '((a . 1) (b . 2)))) + (and (equal (pushnew '(b . 2) place :test #'= :key #'cdr) '((a . 1) (b . 2))) + (equal place '((a . 1) (b . 2))))) + +(let ((place '((a . 1) (b . 2)))) + (and (equal (pushnew '(b . 2) place :test-not (complement #'=) :key #'cdr) + '((a . 1) (b . 2))) + (equal place '((a . 1) (b . 2))))) + +(let ((place '((a . 1) (b . 2)))) + (and (eq (pushnew '(z . 2) place :test #'= :key #'cdr) place) + (equal place '((a . 1) (b . 2))))) + +(let ((place '((a . 1) (b . 2)))) + (and (eq (pushnew '(z . 2) place :test-not (complement #'=) :key #'cdr) place) + (equal place '((a . 1) (b . 2))))) + +(let ((place '("love" "peace"))) + (equal (pushnew "war" place :test #'equal) '("war" "love" "peace"))) + +(let ((place '("love" "peace"))) + (equal (pushnew "war" place :test-not (complement #'equal)) + '("war" "love" "peace"))) + +(let ((place '("love" "peace"))) + (and (eq (pushnew "peace" place :test #'equal) place) + (equal place '("love" "peace")))) + +(let ((place '("love" "peace"))) + (and (eq (pushnew "peace" place :test-not (complement #'equal)) place) + (equal place '("love" "peace")))) + +(let ((place '(("love" . l) ("peace" . p)))) + (equal (pushnew '("war" . w) place :test #'equal :key #'car) + '(("war" . w) ("love" . l) ("peace" . p)))) + +(let ((place '(("love" . l) ("peace" . p)))) + (equal (pushnew '("war" . w) place :test-not (complement #'equal) :key #'car) + '(("war" . w) ("love" . l) ("peace" . p)))) + +(let ((place '(("love" . l) ("peace" . p)))) + (and (eq (pushnew '("love" . l) place :test #'equal :key #'car) place) + (equal place '(("love" . l) ("peace" . p))))) + +(let ((place '(("love" . l) ("peace" . p)))) + (and (eq (pushnew '("love" . l) place + :test-not (complement #'equal) :key #'car) place) + (equal place '(("love" . l) ("peace" . p))))) + +(let ((place '(("love" . l) ("peace" . p)))) + (and (eq (pushnew '("LOVE" . L) place :test #'equalp :key #'car) place) + (equal place '(("love" . l) ("peace" . p))))) + +(let ((place '(("love" . l) ("peace" . p)))) + (and (eq (pushnew '("LOVE" . L) place + :test-not (complement #'equalp) :key #'car) place) + (equal place '(("love" . l) ("peace" . p))))) + +(let ((place '(("love" . l) ("peace" . p)))) + (equal (pushnew '("LOVE" . L) place :test #'equal :key #'car) + '(("LOVE" . L) ("love" . l) ("peace" . p)))) + +(let ((place '(("love" . l) ("peace" . p)))) + (equal (pushnew '("LOVE" . L) place :test-not (complement #'equal) :key #'car) + '(("LOVE" . L) ("love" . l) ("peace" . p)))) + +(let ((list '((1) (1 2) (1 2 3)))) + (and (equal (pushnew '(1) list) '((1) (1) (1 2) (1 2 3))) + (equal list '((1) (1) (1 2) (1 2 3))))) + + +(let* ((list '((1) (1 2) (1 2 3))) + (original list)) + (and (equal (pushnew '(1) list :test #'equal) '((1) (1 2) (1 2 3))) + (eq list original))) + +(let* ((list '((1) (1 2) (1 2 3))) + (original list)) + (and (equal (pushnew '(1) list :test #'equal :key nil) '((1) (1 2) (1 2 3))) + (eq list original))) + +(let ((list (copy-tree '(1 (2) 3 4)))) + (and (equal (pushnew 4 (cadr list)) '(4 2)) + (equal list '(1 (4 2) 3 4)))) + +(let ((list (copy-tree '(1 (2) 3 4)))) + (and (equal (pushnew 4 (cadr list) :key nil) '(4 2)) + (equal list '(1 (4 2) 3 4)))) + + +(null (set-difference (set-difference '(1 2 3 4 5 6 7 8 9) + '(2 4 6 8)) + '(1 3 5 7 9))) +(null (nset-difference (set-difference (list 1 2 3 4 5 6 7 8 9) + '(2 4 6 8)) + '(1 3 5 7 9))) + +(null (set-difference (set-difference '("1" "2" "3" "4" "5" "6" "7" "8" "9") + '("2" "4" "6" "8") :test #'equal) + '("1" "3" "5" "7" "9") :test-not (complement #'equal))) + +(null (set-difference (set-difference '("1" "2" "3" "4" "5" "6" "7" "8" "9") + '("2" "4" "6" "8") :test #'equal) + '("1" "3" "5" "7" "9") :test-not (complement #'equal))) + +(null (nset-difference (nset-difference + (list "1" "2" "3" "4" "5" "6" "7" "8" "9") + '("2" "4" "6" "8") :test #'equal) + '("1" "3" "5" "7" "9") :test-not (complement #'equal))) + +(null (set-difference (set-difference '(("love") ("hate") ("peace") ("war")) + '(("love") ("peace")) + :key #'car + :test #'equal) + '(("hate") ("war")) + :key #'car + :test-not (complement #'equal))) + +(null (nset-difference (nset-difference + (list '("love") '("hate") '("peace") '("war")) + '(("love") ("peace")) + :key #'car + :test #'equal) + '(("hate") ("war")) + :key #'car + :test-not (complement #'equal))) + + +(null (set-difference '() '())) +(null (set-difference '() '() :test #'equal :key 'identity)) +(null (nset-difference '() '())) +(null (set-difference '() '(1 2 3))) +(null (set-difference '() '(1 2 3) :test #'equal :key 'identity)) +(null (nset-difference '() '(1 2 3))) + +(null (set-difference '(1 2 3 4) '(4 3 2 1))) +(null (nset-difference (list 1 2 3 4) '(4 3 2 1))) +(null (set-difference '(1 2 3 4) '(2 4 3 1))) +(null (nset-difference (list 1 2 3 4) '(2 4 3 1))) +(null (set-difference '(1 2 3 4) '(1 3 4 2))) +(null (nset-difference (list 1 2 3 4) '(1 3 4 2))) +(null (set-difference '(1 2 3 4) '(1 3 2 4))) +(null (nset-difference (list 1 2 3 4) '(1 3 2 4))) + + +(eq (set-difference (set-difference '(1 2 3) '()) + '(1 2 3)) + '()) +(eq (nset-difference (nset-difference (list 1 2 3) '()) + '(1 2 3)) + '()) + +(eq (set-difference (set-difference '(1 2 3) '(1)) + '(2 3)) + '()) +(eq (nset-difference (nset-difference (list 1 2 3) '(1)) + '(2 3)) + '()) + +(eq (set-difference (set-difference '(1 2 3) '(1 2)) + '(3)) + '()) +(eq (nset-difference (nset-difference (list 1 2 3) '(1 2)) + '(3)) + '()) + + +(null (set-exclusive-or (set-exclusive-or '(1 2 3) '(2 3 4)) + '(1 4))) +(null (nset-exclusive-or (nset-exclusive-or (list 1 2 3) '(2 3 4)) + '(1 4))) +(null (set-exclusive-or (set-exclusive-or '(1 2 3) '(1 3)) + '(2))) +(null (nset-exclusive-or (nset-exclusive-or (list 1 2 3) '(1 3)) + '(2))) +(null (set-exclusive-or '() '())) +(null (nset-exclusive-or '() '())) +(null (set-exclusive-or '(1 2 3) '(3 2 1))) +(null (nset-exclusive-or (list 1 2 3) '(3 2 1))) +(null (set-exclusive-or '(1 2 3) '(2 3 1))) +(null (nset-exclusive-or (list 1 2 3) '(2 3 1))) +(null (set-exclusive-or '(1 2 3) '(1 3 2))) +(null (nset-exclusive-or (list 1 2 3) '(1 3 2))) + +(null (set-exclusive-or (set-exclusive-or '(1 2 3) '()) + '(3 2 1))) +(null (nset-exclusive-or (nset-exclusive-or (list 1 2 3) '()) + '(3 2 1))) +(null (set-exclusive-or (set-exclusive-or '() '(1 2 3)) + '(2 1 3))) +(null (nset-exclusive-or (nset-exclusive-or '() '(1 2 3)) + '(2 1 3))) + +(null (set-exclusive-or '("car" "ship" "airplane" "submarine") + '("car" "ship" "airplane" "submarine") + :test #'equal)) +(null (nset-exclusive-or (copy-list '("car" "ship" "airplane" "submarine")) + '("car" "ship" "airplane" "submarine") + :test #'equal)) + +(null (set-exclusive-or '("car" "ship" "airplane" "submarine") + '("CAR" "SHIP" "AIRPLANE" "SUBMARINE") + :test #'equalp)) +(null (nset-exclusive-or (copy-list '("car" "ship" "airplane" "submarine")) + '("CAR" "SHIP" "AIRPLANE" "SUBMARINE") + :test #'equalp)) + +(null (set-exclusive-or '("car" "ship" "airplane" "submarine") + '("ship" "airplane" "submarine" "car") + :test-not (complement #'equal))) +(null (nset-exclusive-or (copy-list '("car" "ship" "airplane" "submarine")) + '("ship" "airplane" "submarine" "car") + :test-not (complement #'equal))) + +(null (set-exclusive-or '(("car") ("ship") ("airplane") ("submarine")) + '(("car") ("ship") ("airplane") ("submarine")) + :test #'string= + :key #'car)) +(null (nset-exclusive-or (copy-tree + '(("car") ("ship") ("airplane") ("submarine"))) + '(("car") ("ship") ("airplane") ("submarine")) + :test #'string= + :key #'car)) + +(null (set-exclusive-or '(("car") ("ship") ("airplane") ("submarine")) + '(("car") ("ship") ("airplane") ("submarine")) + :test-not (complement #'string=) + :key #'car)) +(null (nset-exclusive-or (copy-tree + '(("car") ("ship") ("airplane") ("submarine"))) + '(("car") ("ship") ("airplane") ("submarine")) + :test-not (complement #'string=) + :key #'car)) + +(null (set-exclusive-or + (set-exclusive-or '("car" "ship" "airplane" "submarine") + '("car" "ship" "horse" "airplane" "submarine" "camel") + :test #'equal) + '("camel" "horse") + :test-not (complement #'equal))) + +(null (nset-exclusive-or + (nset-exclusive-or (list "car" "ship" "airplane" "submarine") + '("car" "ship" "horse" "airplane" "submarine" "camel") + :test #'equal) + '("camel" "horse") + :test-not (complement #'equal))) + + +(subsetp '(1 2 3) '(1 2 3)) +(subsetp '(1 2 3) '(3 2 1)) +(subsetp '(1 2 3) '(2 1 3)) + +(null (subsetp '(1 2 3 4) '(2 1 3))) +(subsetp '(1) '(2 1 3)) +(subsetp '(1 2) '(1 2 3 4 5 6 7 8)) +(subsetp '(1 2 3 4 5) '(8 7 6 5 4 3 2 1)) +(null (subsetp '("car" "ship" "airplane" "submarine") + '("car" "ship" "horse" "airplane" "submarine" "camel"))) + +(subsetp '("car" "ship" "airplane" "submarine") + '("car" "ship" "horse" "airplane" "submarine" "camel") + :test #'equal) + +(subsetp '("CAR" "SHIP" "AIRPLANE" "SUBMARINE") + '("car" "ship" "horse" "airplane" "submarine" "camel") + :test #'equalp) + +(subsetp '(("car") ("ship") ("airplane") ("submarine")) + '(("car") ("ship") ("horse") ("airplane") ("submarine") ("camel")) + :test #'string= + :key #'car) + + +(null (union '() '())) +(null (nunion '() '())) +(null (set-difference (union '(1 2 3) '(2 3 4)) + '(1 2 3 4))) +(null (set-difference (nunion (list 1 2 3) (list 2 3 4)) + '(1 2 3 4))) + +(null (set-difference (union '(1 2 3) '(1 2 3)) + '(1 2 3))) +(null (set-difference (nunion (list 1 2 3) (list 1 2 3)) + '(1 2 3))) + +(null (set-difference (union '(1) '(3 2 1)) + '(1 2 3))) +(null (set-difference (nunion (list 1) (list 3 2 1)) + '(1 2 3))) + +(null (set-difference (union '(1 2 3) '()) + '(1 2 3))) +(null (set-difference (nunion (list 1 2 3) '()) + '(1 2 3))) + +(null (set-difference (union '() '(1 2 3)) + '(1 2 3))) +(null (set-difference (nunion '() (list 1 2 3)) + '(1 2 3))) + +(null (set-difference (union '(1 2 3) '(2)) + '(1 2 3))) +(null (set-difference (nunion (list 1 2 3) (list 2)) + '(1 2 3))) + + +(null (set-difference (union '("Alpha" "Bravo" "Charlie") + '("Bravo" "Charlie" "Delta" "Echo") + :test #'string=) + '("Alpha" "Bravo" "Charlie" "Delta" "Echo") + :test-not (complement #'string=))) + +(null (set-difference (nunion (list "Alpha" "Bravo" "Charlie") + (list "Bravo" "Charlie" "Delta" "Echo") + :test #'string=) + '("Alpha" "Bravo" "Charlie" "Delta" "Echo") + :test-not (complement #'string=))) + +(null (set-difference + (union (copy-tree '(("Alpha") ("Bravo") ("Charlie"))) + (copy-tree '(("Bravo") ("Charlie") ("Delta") ("Echo"))) + :test #'string= + :key #'car) + '(("Alpha") ("Bravo") ("Charlie") ("Delta") ("Echo")) + :test-not (complement #'string=) + :key #'car)) + +(null (set-difference + (nunion (copy-tree '(("Alpha") ("Bravo") ("Charlie"))) + (copy-tree '(("Bravo") ("Charlie") ("Delta") ("Echo"))) + :test #'string= + :key #'car) + '(("Alpha") ("Bravo") ("Charlie") ("Delta") ("Echo")) + :test-not (complement #'string=) + :key #'car)) + + +(null (set-difference (union '("Alpha" "Bravo" "Charlie") + '("BRAVO" "CHARLIE" "DELTA" "ECHO") + :test #'string-equal) + '("ALPHA" "BRAVO" "CHARLIE" "DELTA" "ECHO") + :test-not (complement #'string-equal))) + diff --git a/Sacla/tests/must-data-and-control.lisp b/Sacla/tests/must-data-and-control.lisp new file mode 100644 index 0000000..0b0fb96 --- /dev/null +++ b/Sacla/tests/must-data-and-control.lisp @@ -0,0 +1,1660 @@ +;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp> +;; ALL RIGHTS RESERVED. +;; +;; $Id: must-data-and-control.lisp,v 1.15 2004/02/20 07:23:42 yuji Exp $ +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; * Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; * Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(let (a b c) + (and (null (psetq a 1 b 2 c 3)) + (eql a 1) + (eql b 2) + (eql c 3))) + +(let ((a 1) + (b 2) + (c 3)) + (and (null (psetq a (1+ b) b (1+ a) c (+ a b))) + (eql a 3) + (eql b 2) + (eql c 3))) + +(let ((x (list 10 20 30))) + (symbol-macrolet ((y (car x)) (z (cadr x))) + (psetq y (1+ z) z (1+ y)) + (equal (list x y z) '((21 11 30) 21 11)))) + +(let ((a 1) (b 2)) + (and (null (psetq a b b a)) + (eql a 2) + (eql b 1))) + + +(null (psetq)) +(let ((a nil)) + (and (null (psetq a t)) + (eq a t))) +(let ((a 0) + (b 1)) + (and (null (psetq a b + b a)) + (eq a 1) + (eq b 0))) + +(let ((a 0) + (b 1) + (c 2)) + (and (null (psetq a b + b c + c a)) + (eq a 1) + (eq b 2) + (eq c 0))) + +(let ((a 0) + (b 1) + (c 2) + (d 3)) + (and (null (psetq a b + b c + c d + d a)) + (eq a 1) + (eq b 2) + (eq c 3) + (eq d 0))) + + + +(null (block nil (return) 1)) +(eql (block nil (return 1) 2) 1) +(equal (multiple-value-list (block nil (return (values 1 2)) 3)) '(1 2)) +(eql (block nil (block alpha (return 1) 2)) 1) +(eql (block alpha (block nil (return 1)) 2) 2) +(eql (block nil (block nil (return 1) 2)) 1) + +(eq (dotimes (i 10 nil) + (return t)) + t) + +(eq (dolist (elt (list 0 1 2 3) nil) + (when (numberp elt) + (return t))) + t) + +(not nil) +(not '()) +(not (integerp 'sss)) +(null (not (integerp 1))) +(null (not 3.7)) +(null (not 'apple)) + +(not nil) +(null (not t)) +(not (cdr '(a))) + + +(equal 'a 'a) +(not (equal 'a 'b)) +(equal 'abc 'abc) +(equal 1 1) +(equal 2 2) +(equal 0.1 0.1) +(equal 1/3 1/3) +(not (equal 0 1)) +(not (equal 1 1.0)) +(not (equal 1/3 1/4)) +(equal #\a #\a) +(equal #\b #\b) +(not (equal #\b #\B)) +(not (equal #\C #\c)) +(equal '(0) '(0)) +(equal '(0 #\a) '(0 #\a)) +(equal '(0 #\a x) '(0 #\a x)) +(equal '(0 #\a x (0)) '(0 #\a x (0))) +(equal '(0 #\a x (0 (#\a (x "abc" #*0101)))) + '(0 #\a x (0 (#\a (x "abc" #*0101))))) +(not (equal (make-array '(2 2) :initial-contents '((a b) (c d))) + (make-array '(2 2) :initial-contents '((a b) (c d))))) +(let ((array (make-array '(2 2) :initial-contents '((a b) (c d))))) + (equal array array)) + + +(eql (identity 101) 101) +(equal (mapcan #'identity (list (list 1 2 3) '(4 5 6))) '(1 2 3 4 5 6)) +(eq (identity 'x) 'x) + + + +(funcall (complement #'zerop) 1) +(not (funcall (complement #'characterp) #\A)) +(not (funcall (complement #'member) 'a '(a b c))) +(funcall (complement #'member) 'd '(a b c)) + + + +(equal (mapcar (constantly 3) '(a b c d)) '(3 3 3 3)) +(let ((const-func (constantly 'xyz))) + (every #'(lambda (arg) (eq arg 'xyz)) + (list (funcall const-func) + (funcall const-func 'a) + (funcall const-func 'a 'b) + (funcall const-func 'a 'b 'c) + (funcall const-func 'a 'b 'c 'd)))) + + + +(let ((temp1 1) + (temp2 1) + (temp3 1)) + (and (eql (and (incf temp1) (incf temp2) (incf temp3)) 2) + (and (eql 2 temp1) (eql 2 temp2) (eql 2 temp3)) + (eql (decf temp3) 1) + (null (and (decf temp1) (decf temp2) (eq temp3 'nil) (decf temp3))) + (and (eql temp1 temp2) (eql temp2 temp3)) + (and))) + +(eq (and) t) +(equal (multiple-value-list (and 't 't 't (values 'a 'b 'c))) + '(a b c)) +(null (and 't 't (cdr '(a)) (error "error"))) + + + +(let ((temp0 nil) + (temp1 10) + (temp2 20) + (temp3 30)) + (and (eql (or temp0 temp1 (setq temp2 37)) 10) + (eql temp2 20) + (eql (or (incf temp1) (incf temp2) (incf temp3)) 11) + (eql temp1 11) + (eql temp2 20) + (eql temp3 30) + (equal (multiple-value-list (or (values) temp1)) '(11)) + (equal (multiple-value-list (or (values temp1 temp2) temp3)) '(11)) + (equal (multiple-value-list (or temp0 (values temp1 temp2))) '(11 20)) + (equal (multiple-value-list (or (values temp0 temp1) + (values temp2 temp3))) + '(20 30)))) + +(zerop (or '0 '1 '2)) +(let ((a 0)) + (and (eql (or (incf a) (incf a) (incf a)) 1) + (eql a 1))) +(equal (multiple-value-list (or (values) 1)) '(1)) +(equal (multiple-value-list (or (values 1 2) 3)) '(1)) + +(null (or)) +(equal (multiple-value-list (or (values 0 1 2))) '(0 1 2)) +(equal (multiple-value-list (or nil (values 0 1 2))) '(0 1 2)) +(equal (multiple-value-list (or nil nil (values 0 1 2))) '(0 1 2)) +(equal (multiple-value-list (or nil nil nil (values 0 1 2))) '(0 1 2)) + + +(let ((a nil)) + (flet ((select-options () + (cond ((= a 1) (setq a 2)) + ((= a 2) (setq a 3)) + ((and (= a 3) (floor a 2))) + (t (floor a 3))))) + (and (eql (setq a 1) 1) + (eql (select-options) 2) + (eql a 2) + (eql (select-options) 3) + (eql a 3) + (eql (select-options) 1) + (setq a 5) + (equal (multiple-value-list (select-options)) '(1 2))))) + +(null (cond)) +(equal (multiple-value-list (cond ((values 1 2 3)))) '(1)) +(equal (multiple-value-list (cond (t (values 1 2 3)))) '(1 2 3)) +(equal (multiple-value-list (cond (t (values 1) + (values 1 2) + (values 1 2 3)))) '(1 2 3)) +(let ((a 0)) + (and (eql (cond + ((incf a)) + ((incf a)) + ((incf a))) + 1) + (eql a 1))) + +(let ((a 0)) + (and (eql (cond + ((incf a) (incf a) (incf a)) + ((incf a) (incf a) (incf a)) + ((incf a) (incf a) (incf a))) + 3) + (eql a 3))) + + + +(eq (when t 'hello) 'HELLO) +(null (unless t 'hello)) +(null (when nil 'hello)) +(eq (unless nil 'hello) 'HELLO) +(null (when t)) +(null (unless nil)) +(let ((x 3)) + (equal (list (when (oddp x) (incf x) (list x)) + (when (oddp x) (incf x) (list x)) + (unless (oddp x) (incf x) (list x)) + (unless (oddp x) (incf x) (list x)) + (if (oddp x) (incf x) (list x)) + (if (oddp x) (incf x) (list x)) + (if (not (oddp x)) (incf x) (list x)) + (if (not (oddp x)) (incf x) (list x))) + '((4) NIL (5) NIL 6 (6) 7 (7)))) + + + + +(equal (let ((list nil)) + (dolist (k '(1 2 3 :four #\v () t 'other)) + (push (case k + ((1 2) 'clause1) + (3 'clause2) + (nil 'no-keys-so-never-seen) + ((nil) 'nilslot) + ((:four #\v) 'clause4) + ((t) 'tslot) + (otherwise 'others)) + list)) + list) + '(OTHERS TSLOT NILSLOT CLAUSE4 CLAUSE4 CLAUSE2 CLAUSE1 CLAUSE1)) + + +(macro-function 'case) +(macro-function 'ccase) +(macro-function 'ecase) + +(eql (case 'a + ((a b c) 0) + (x 1) + (y 2) + (z 3)) + 0) + +(eql (case 'j + ((a b c) 0) + (x 1) + (y 2) + (z 3) + (t 9)) + 9) + +(eql (case 'j + ((a b c) 0) + (x 1) + (y 2) + (z 3) + (otherwise 9)) + 9) + +(eql (case 'j + ((a b c) 0) + (x 1) + (y 2) + (z 3)) + nil) + +(null (case 'x)) + +(let ((x #\a)) + (equal (case x + ((#\x #\y #\z) "xyz") + (#\a "a") + (t "-")) + "a")) + +(let ((x #\A)) + (equal (case x + ((#\x #\y #\z) "xyz") + (#\a "a") + (t "-")) + "-")) + +(let ((x t)) + (eql (case x + ((t) 0) + (t 1)) + 0)) + +(let ((x nil)) + (eql (case x + ((t) 0) + (t 1)) + 1)) + +(let ((x 'a)) + (eql (case x + ((t) 0)) + nil)) + +(let ((x 'otherwise)) + (eql (case x + ((otherwise) 0) + (otherwise 1)) + 0)) + +(let ((x nil)) + (eql (case x + ((otherwise) 0) + (otherwise 1)) + 1)) + +(let ((x 'a)) + (eql (case x + ((otherwise) 0)) + nil)) + + +(let ((x 'a)) + (and (eql (case x + ((a b c) (setq x 0) 'a) + ((x y z) (setq x 1) 'x)) + 'a) + (eql x 0))) + +(let ((x 'x)) + (and (eql (case x + ((a b c) (setq x 0) 'a) + ((x y z) (setq x 1) 'x)) + 'x) + (eql x 1))) + + +(equal (mapcar #'(lambda (x) (case x (a 0) (b 1) (c 2) (d 3) (e 4))) + '(a b c d e f)) + '(0 1 2 3 4 nil)) + +(case 'a (otherwise t)) + +(eql (case 'a (otherwise 10)) 10) + +(let ((a 0) + (b 1)) + (and (eq (case (progn (incf a) (incf b)) + (0 'a) + (1 'b) + (2 'c)) + 'c) + (eql a 1) + (eql b 2))) + +(let ((a 0) + (b 1)) + (and (eq (case (progn (incf a) (incf b)) + (0 'a) + (1 'b) + (2 (incf a) (incf b) 'c)) + 'c) + (eql a 2) + (eql b 3))) + +(let ((a (list 0 1 2 3))) + (eq (case (caddr a) + (0 'x) + (1 'y) + (2 'z) + (3 t)) + 'z)) + + +(equal (multiple-value-list (case 2 + (0 (values 0 'x)) + (1 (values 1 'y)) + (2 (values 2 'z)) + (3 (values 3 't)))) + '(2 z)) + + + +(let ((a 'c)) + (eql (ccase a + ((a b c) 0) + (x 1) + (y 2) + (z 3)) + 0)) + +(HANDLER-CASE + (PROGN + (LET ((A 'J)) + (CCASE A ((A B C) 0) (X 1) (Y 2) (Z 3)))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE + (PROGN + (LET ((A NIL)) + (CCASE A))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE + (PROGN + (LET ((A #\a)) + (CCASE A ((#\A #\B #\C) 0) ((#\X #\Y #\Z) 1)))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(let ((a (list 0 1 2 3))) + (eq (ccase (caddr a) + (0 'x) + (1 'y) + (2 'z) + (3 t)) + 'z)) + +(let ((x #\a)) + (equal (ccase x + ((#\x #\y #\z) "xyz") + (#\a "a")) + "a")) + +(let ((x 'a)) + (and (eql (ccase x + ((a b c) (setq x 0) 'a) + ((x y z) (setq x 1) 'x)) + 'a) + (eql x 0))) + +(let ((x 'x)) + (and (eql (ccase x + ((a b c) (setq x 0) 'a) + ((x y z) (setq x 1) 'x)) + 'x) + (eql x 1))) + +(equal (mapcar #'(lambda (x) (ccase x (a 0) (b 1) (c 2) (d 3) (e 4))) + '(a b c d e)) + '(0 1 2 3 4)) + + +(equal (multiple-value-list (let ((a 2)) + (ccase a + (0 (values 0 'x)) + (1 (values 1 'y)) + (2 (values 2 'z)) + (3 (values 3 't))))) + '(2 z)) + +(let ((a 'c)) + (eql (ecase a + ((a b c) 0) + (x 1) + (y 2) + (z 3)) + 0)) + +(HANDLER-CASE + (PROGN + (LET ((A 'J)) + (ECASE A ((A B C) 0) (X 1) (Y 2) (Z 3)))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE + (PROGN + (LET ((A NIL)) + (ECASE A))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE + (PROGN + (LET ((A #\a)) + (ECASE A ((#\A #\B #\C) 0) ((#\X #\Y #\Z) 1)))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(let ((a (list 0 1 2 3))) + (eq (ecase (caddr a) + (0 'x) + (1 'y) + (2 'z) + (3 t)) + 'z)) + +(let ((x #\a)) + (equal (ecase x + ((#\x #\y #\z) "xyz") + (#\a "a")) + "a")) + +(let ((x 'a)) + (and (eql (ecase x + ((a b c) (setq x 0) 'a) + ((x y z) (setq x 1) 'x)) + 'a) + (eql x 0))) + +(let ((x 'x)) + (and (eql (ecase x + ((a b c) (setq x 0) 'a) + ((x y z) (setq x 1) 'x)) + 'x) + (eql x 1))) + +(equal (mapcar #'(lambda (x) (ecase x (a 0) (b 1) (c 2) (d 3) (e 4))) + '(a b c d e)) + '(0 1 2 3 4)) + +(equal (multiple-value-list (let ((a 2)) + (ecase a + (0 (values 0 'x)) + (1 (values 1 'y)) + (2 (values 2 'z)) + (3 (values 3 't))))) + '(2 z)) + + +(let ((x 'a)) + (equal (typecase x + (cons "cons") + (symbol "symbol") + (number "number") + (otherwise "unknown")) + "symbol")) + +(let ((x (list 'a))) + (equal (typecase x + (cons "cons") + (symbol "symbol") + (number "number") + (otherwise "unknown")) + "cons")) + +(let ((x 0)) + (equal (typecase x + (cons "cons") + (symbol "symbol") + (number "number") + (otherwise "unknown")) + "number")) + +(let ((x (make-array '(3 3)))) + (equal (typecase x + (cons "cons") + (symbol "symbol") + (number "number") + (otherwise "unknown")) + "unknown")) + + +(null (typecase 'a)) +(typecase 'a (otherwise t)) +(typecase 'a (t t)) + +(let ((x (make-array '(3 3)))) + (equal (typecase x + (cons "cons") + (symbol "symbol") + (number "number")) + nil)) + +(let ((x "")) + (equal (typecase x + (t "anything") + (otherwise nil)) + "anything")) + +(let ((x "")) + (and (eql (typecase x + (string (setq x 'string) 0) + (cons (setq x 'cons) 1) + (array (setq x 'array) 2) + (t (setq x 't) 9)) + 0) + (eq x 'string))) + +(let ((x (list nil))) + (and (eql (typecase x + (string (setq x 'string) 0) + (cons (setq x 'cons) 1) + (array (setq x 'array) 2) + (t (setq x 't) 9)) + 1) + (eq x 'cons))) + + +(let ((x #*01)) + (and (eql (typecase x + (string (setq x 'string) 0) + (cons (setq x 'cons) 1) + (array (setq x 'array) 2) + (t (setq x 't) 9)) + 2) + (eq x 'array))) + +(let ((x #\a)) + (and (eql (typecase x + (string (setq x 'string) 0) + (cons (setq x 'cons) 1) + (array (setq x 'array) 2) + (t (setq x 't) 9)) + 9) + (eq x 't))) + +(let ((x #*01)) + (and (equal (multiple-value-list (typecase x + (string (setq x 'string) (values 'string 0)) + (cons (setq x 'cons) (values 'cons 1)) + (array (setq x 'array) (values 'array 2)) + (t (setq x 't) (values 't 9)))) + '(array 2)) + (eq x 'array))) + + +(let ((x 'a)) + (equal (ctypecase x + (cons "cons") + (symbol "symbol") + (number "number")) + "symbol")) + +(let ((x (list 'a))) + (equal (ctypecase x + (cons "cons") + (symbol "symbol") + (number "number")) + "cons")) + +(let ((x 0)) + (equal (ctypecase x + (cons "cons") + (symbol "symbol") + (number "number")) + "number")) + +(HANDLER-CASE + (LET ((X (MAKE-ARRAY '(3 3)))) + (CTYPECASE X + (CONS "cons") + (SYMBOL "symbol") + (NUMBER "number"))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + + +(HANDLER-CASE + (LET ((A NIL)) (CTYPECASE A)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +;; (let ((x "")) +;; (equal (ctypecase x (t "anything")) +;; "anything")) + +(let ((x "")) + (and (eql (ctypecase x + (string (setq x 'string) 0) + (cons (setq x 'cons) 1) + (array (setq x 'array) 2)) + 0) + (eq x 'string))) + +(let ((x (list nil))) + (and (eql (ctypecase x + (string (setq x 'string) 0) + (cons (setq x 'cons) 1) + (array (setq x 'array) 2)) + 1) + (eq x 'cons))) + + +(let ((x #*01)) + (and (eql (ctypecase x + (string (setq x 'string) 0) + (cons (setq x 'cons) 1) + (array (setq x 'array) 2)) + 2) + (eq x 'array))) + +;; (let ((x #\a)) +;; (and (eql (ctypecase x +;; (string (setq x 'string) 0) +;; (cons (setq x 'cons) 1) +;; (array (setq x 'array) 2) +;; (t (setq x 't) 9)) +;; 9) +;; (eq x 't))) + +(HANDLER-CASE + (LET ((X #\a)) + (CTYPECASE X + (STRING (SETQ X 'STRING) 0) + (CONS (SETQ X 'CONS) 1) + (ARRAY (SETQ X 'ARRAY) 2))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(let ((x #*01)) + (and (equal (multiple-value-list (ctypecase x + (string (setq x 'string) (values 'string 0)) + (cons (setq x 'cons) (values 'cons 1)) + (array (setq x 'array) (values 'array 2)))) + '(array 2)) + (eq x 'array))) + + +(let ((x 'a)) + (equal (etypecase x + (cons "cons") + (symbol "symbol") + (number "number")) + "symbol")) + +(let ((x (list 'a))) + (equal (etypecase x + (cons "cons") + (symbol "symbol") + (number "number")) + "cons")) + +(let ((x 0)) + (equal (etypecase x + (cons "cons") + (symbol "symbol") + (number "number")) + "number")) + +(HANDLER-CASE + (PROGN + (LET ((X (MAKE-ARRAY '(3 3)))) + (ETYPECASE X (CONS "cons") (SYMBOL "symbol") (NUMBER "number")))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + + +(HANDLER-CASE + (PROGN + (LET ((A NIL)) + (ETYPECASE A))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +;; (let ((x "")) +;; (equal (etypecase x +;; (t "anything")) +;; "anything")) + +(let ((x "")) + (and (eql (etypecase x + (string (setq x 'string) 0) + (cons (setq x 'cons) 1) + (array (setq x 'array) 2)) + 0) + (eq x 'string))) + +(let ((x (list nil))) + (and (eql (etypecase x + (string (setq x 'string) 0) + (cons (setq x 'cons) 1) + (array (setq x 'array) 2)) + 1) + (eq x 'cons))) + + +(let ((x #*01)) + (and (eql (etypecase x + (string (setq x 'string) 0) + (cons (setq x 'cons) 1) + (array (setq x 'array) 2)) + 2) + (eq x 'array))) + +;; (let ((x #\a)) +;; (and (eql (etypecase x +;; (string (setq x 'string) 0) +;; (cons (setq x 'cons) 1) +;; (array (setq x 'array) 2) +;; (t (setq x 't) 9)) +;; 9) +;; (eq x 't))) + +(HANDLER-CASE + (PROGN + (LET ((X #\a)) + (ETYPECASE X + (STRING (SETQ X 'STRING) 0) + (CONS (SETQ X 'CONS) 1) + (ARRAY (SETQ X 'ARRAY) 2)))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(let ((x #*01)) + (and (equal (multiple-value-list (etypecase x + (string (setq x 'string) (values 'string 0)) + (cons (setq x 'cons) (values 'cons 1)) + (array (setq x 'array) (values 'array 2)))) + '(array 2)) + (eq x 'array))) + + +(macro-function 'multiple-value-bind) +(equal (multiple-value-bind (f r) + (floor 130 11) + (list f r)) + '(11 9)) + +(multiple-value-bind (a b c d) + (values 0 1 2 3 4 5) + (and (eql a 0) + (eql b 1) + (eql c 2) + (eql d 3))) + +(multiple-value-bind (a b c d) + (values 0 1) + (and (eql a 0) + (eql b 1) + (eql c nil) + (eql d nil))) + +(equal (multiple-value-list (multiple-value-bind (a b) + (values 0 1) + (values a b 2 3))) + '(0 1 2 3)) + +(multiple-value-bind () + (values 0 1 2) + t) + +(null (multiple-value-bind () nil)) + +(eql (multiple-value-bind (a) + (floor 130 11) + (+ a 10)) + 21) + +(eql (multiple-value-bind (a) + (floor 130 11) + (+ a 10) + (incf a 100) + (+ a 10)) + 121) + + + +(equal (multiple-value-call #'list 1 '/ (values 2 3) '/ (values) '/ (floor 2.5)) + '(1 / 2 3 / / 2 0.5)) +(eql (+ (floor 5 3) (floor 19 4)) (+ 1 4)) +(eql (multiple-value-call #'+ (floor 5 3) (floor 19 4)) (+ 1 2 4 3)) + +(let ((list nil)) + (and (eql (multiple-value-call (progn (push 'function list) #'+) + (progn (push 0 list) 0) + (progn (push 1 list) (values 1 2)) + (progn (push 2 list) (values 3 4 5)) + (progn (push 3 list) (values 6 7 8 9))) + 45) + (equal (reverse list) '(function 0 1 2 3)))) + +(eql (multiple-value-call #'+ 0 1 2 3 4) 10) +(eql (multiple-value-call #'+) 0) +(equal (multiple-value-list + (multiple-value-call #'values + 0 1 (values 2) (values 3 4) (values 5 6 7))) + '(0 1 2 3 4 5 6 7)) +(special-operator-p 'multiple-value-call) + + + +(macro-function 'multiple-value-list) +(equal (multiple-value-list (floor -3 4)) '(-1 1)) +(equal (multiple-value-list + (progn + (values 'a 'b) + 0)) + '(0)) +(equal (multiple-value-list + (prog1 + (values 'a 'b) + 0)) + '(a)) + +(equal (multiple-value-list + (multiple-value-prog1 + (values 'a 'b) + 0)) + '(a b)) + +(special-operator-p 'multiple-value-prog1) +(eql (multiple-value-prog1 1 2 3) 1) +(eql (multiple-value-prog1 1 2 3) 1) + + +(let ((temp '(1 2 3))) + (multiple-value-bind (a b c) + (multiple-value-prog1 + (values-list temp) + (setq temp nil) + (values-list temp)) + (and (eql a 1) + (eql b 2) + (eql c 3)))) + + +(zerop (multiple-value-prog1 0 + (values 0 1) + (values 0 1 2))) + +(equal (multiple-value-list (multiple-value-prog1 (progn 0 + (values 0 1) + (values 0 1 2)))) + '(0 1 2)) + + +(let (quotient remainder) + (and (eql (multiple-value-setq (quotient remainder) (truncate 3.2 2)) 1) + (eql quotient 1) + (eql remainder 1.2))) +(let ((a 7) + (b 8) + (c 9)) + (and (eql (multiple-value-setq (a b c) (values 1 2)) 1) + (eql a 1) + (eql b 2) + (eql c NIL))) + +(let ((a 0) + (b 1)) + (and (eql (multiple-value-setq (a b) (values 4 5 6)) 4) + (eql a 4) + (eql b 5))) + + +(null (multiple-value-list (values-list nil))) +(equal (multiple-value-list (values-list '(1))) '(1)) +(equal (multiple-value-list (values-list '(1 2))) '(1 2)) +(equal (multiple-value-list (values-list '(1 2 3))) '(1 2 3)) + +(every #'(lambda (list) (equal (multiple-value-list (values-list list)) list)) + '() + '(a) + '(a b) + '(a b c) + '(a b c d) + '(a b c d e) + '(a b c d e f) + '(a b c d e f g) + '(a b c d e f g h)) + + +(macro-function 'nth-value) +(eql (nth-value 0 (values 'a 'b)) 'A) +(eql (nth-value 1 (values 'a 'b)) 'B) +(null (nth-value 2 (values 'a 'b))) +(multiple-value-bind (a b eq?) + (let* ((x 83927472397238947423879243432432432) + (y 32423489732) + (a (nth-value 1 (floor x y))) + (b (mod x y))) + (values a b (= a b))) + (and (eql a 3332987528) + (eql b 3332987528) + eq?)) + +(null (nth-value 0 (values))) +(eql (nth-value 0 1) 1) +(null (nth-value 1 1)) +(eql (nth-value 0 (values 0 1 2)) 0) +(eql (nth-value 1 (values 0 1 2)) 1) +(eql (nth-value 2 (values 0 1 2)) 2) +(eql (nth-value 3 (values 0 1 2)) nil) +(eql (nth-value 4 (values 0 1 2)) nil) +(eql (nth-value 5 (values 0 1 2)) nil) + + +(let ((z (list 0 1 2 3))) + (eql (prog* ((y z) + (x (car y))) + (return x)) + (car z))) + + +(macro-function 'prog) +(macro-function 'prog*) +(let ((a 1)) + (eq (prog ((a 2) (b a)) (return (if (= a b) '= '/=))) '/=)) + +(eq (prog* ((a 2) (b a)) (return (if (= a b) '= '/=))) '=) +(null (prog () 'no-return-value)) + +(flet ((king-of-confusion (w) + "Take a cons of two lists and make a list of conses. +Think of this function as being like a zipper." + (prog (x y z) ;Initialize x, y, z to NIL + (setq y (car w) z (cdr w)) + loop + (cond ((null y) (return x)) + ((null z) (go err))) + rejoin + (setq x (cons (cons (car y) (car z)) x)) + (setq y (cdr y) z (cdr z)) + (go loop) + err + (cerror "Will self-pair extraneous items" + "Mismatch - gleep! ~S" y) + (setq z y) + (go rejoin)))) + (and (equal (king-of-confusion '((0 1 2) . (a b c))) + '((2 . C) (1 . B) (0 . A))) + (equal (king-of-confusion '((0 1 2 3 4 5) . (a b c d e f))) + '((5 . F) (4 . E) (3 . D) (2 . C) (1 . B) (0 . A))))) + + +(null (prog () t)) +(null (prog ())) +(eql (let ((a 0) + (b 0)) + (prog ((a 10) + (b 100)) + (return (+ a b)))) + 110) + +(prog (a + (b 1) + (c 2)) + (return (and (null a) (eql b 1) (eql c 2)))) + +(prog ((a 0) + b + (c 2)) + (return (and (eql a 0) (null b) (eql c 2)))) + +(prog ((a 0) + (b 1) + c) + (return (and (eql a 0) (eql b 1) (null c)))) + +(prog (a b c) + (return (every #'null (list a b c)))) + +(eql (let ((a 0)) + (declare (special a)) + (flet ((ref-a () a)) + (prog ((a 10)) + (declare (special a)) + (return (ref-a))))) + 10) + +(let ((a 0)) + (declare (special a)) + (and (eql (flet ((ref-a () a)) + (prog ((a 10) + b + (c 100)) + (declare (special a)) + (setq b 1) + (return (+ (ref-a) b c)))) + 111) + (eql a 0))) + +(let ((a 0)) + (declare (special a)) + (and (equal (multiple-value-list (flet ((ref-a () a)) + (prog ((a 10) + b + (c 100)) + (declare (special a)) + (setq b 1) + (return (values (ref-a) b c))))) + '(10 1 100)) + (eql a 0))) + +(let ((a 0)) + (and (eql (prog () (return a)) 0) + (eql a 0))) + + +(flet ((rev (list) + (prog ((x list) + (result nil)) + top + (when (null x) + (return result)) + (psetq x (cdr x) + result (cons (car x) result)) + (go top)))) + (and (equal (rev '(0 1 2 3)) + '(3 2 1 0)) + (equal (rev nil) + nil) + (equal (rev '(0)) + '(0)))) + +(eql (prog (val) + (setq val 1) + (go point-a) + (incf val 16) + point-c + (incf val 04) + (go point-b) + (incf val 32) + point-a + (incf val 02) + (go point-c) + (incf val 64) + point-b + (incf val 08) + (return val)) + 15) + +(let ((a 0)) + (and (equal (multiple-value-list (prog ((a 100) + (b a) + (c 1)) + (return (values a b c)))) + '(100 0 1)) + (eql a 0))) + + +(null (prog* () 'no-return-value)) +(flet ((king-of-confusion (w) + "Take a cons of two lists and make a list of conses. +Think of this function as being like a zipper." + (prog* (x y z) ;Initialize x, y, z to NIL + (setq y (car w) z (cdr w)) + loop + (cond ((null y) (return x)) + ((null z) (go err))) + rejoin + (setq x (cons (cons (car y) (car z)) x)) + (setq y (cdr y) z (cdr z)) + (go loop) + err + (cerror "Will self-pair extraneous items" + "Mismatch - gleep! ~S" y) + (setq z y) + (go rejoin)))) + (and (equal (king-of-confusion '((0 1 2) . (a b c))) + '((2 . C) (1 . B) (0 . A))) + (equal (king-of-confusion '((0 1 2 3 4 5) . (a b c d e f))) + '((5 . F) (4 . E) (3 . D) (2 . C) (1 . B) (0 . A))))) + +(null (prog* () t)) +(null (prog* ())) +(eql (let ((a 0) + (b 0)) + (prog* ((a 10) + (b 100)) + (return (+ a b)))) + 110) + +(prog* (a + (b 1) + (c 2)) + (return (and (null a) (eql b 1) (eql c 2)))) + +(prog* ((a 0) + b + (c 2)) + (return (and (eql a 0) (null b) (eql c 2)))) + +(prog* ((a 0) + (b 1) + c) + (return (and (eql a 0) (eql b 1) (null c)))) + +(prog* (a b c) + (return (every #'null (list a b c)))) + +(eql (let ((a 0)) + (declare (special a)) + (flet ((ref-a () a)) + (prog* ((a 10)) + (declare (special a)) + (return (ref-a))))) + 10) + +(let ((a 0)) + (declare (special a)) + (and (eql (flet ((ref-a () a)) + (prog* ((a 10) + b + (c 100)) + (declare (special a)) + (setq b 1) + (return (+ (ref-a) b c)))) + 111) + (eql a 0))) + +(let ((a 0)) + (declare (special a)) + (and (equal (multiple-value-list (flet ((ref-a () a)) + (prog* ((a 10) + b + (c 100)) + (declare (special a)) + (setq b 1) + (return (values (ref-a) b c))))) + '(10 1 100)) + (eql a 0))) + +(let ((a 0)) + (and (eql (prog* () (return a)) 0) + (eql a 0))) + + +(flet ((rev (list) + (prog* ((x list) + (result nil)) + top + (when (null x) + (return result)) + (psetq x (cdr x) + result (cons (car x) result)) + (go top)))) + (and (equal (rev '(0 1 2 3)) + '(3 2 1 0)) + (equal (rev nil) + nil) + (equal (rev '(0)) + '(0)))) + +(eql (prog* (val) + (setq val 1) + (go point-a) + (incf val 16) + point-c + (incf val 04) + (go point-b) + (incf val 32) + point-a + (incf val 02) + (go point-c) + (incf val 64) + point-b + (incf val 08) + (return val)) + 15) + +(let ((a 0)) + (and (equal (multiple-value-list (prog* ((a 100) + (b a) + (c 1)) + (return (values a b c)))) + '(100 100 1)) + (eql a 0))) + + + +(macro-function 'prog1) +(macro-function 'prog2) + +(eql (let ((temp 1)) + (prog1 temp (incf temp) temp)) + 1) +(let ((temp t)) + (and (eq (prog1 temp (setq temp nil)) 't) + (null temp))) + +(equal (multiple-value-list (prog1 (values 1 2 3) 4)) '(1)) + +(let ((temp (list 'a 'b 'c))) + (and (eq (prog1 (car temp) (setf (car temp) 'alpha)) 'a) + (equal temp '(ALPHA B C)))) + +(equal (flet ((swap-symbol-values (x y) + (setf (symbol-value x) + (prog1 (symbol-value y) + (setf (symbol-value y) (symbol-value x)))))) + (let ((*foo* 1) (*bar* 2)) + (declare (special *foo* *bar*)) + (swap-symbol-values '*foo* '*bar*) + (list *foo* *bar*))) + '(2 1)) + +(let ((temp 1)) + (and (eql (prog2 (incf temp) (incf temp) (incf temp)) 3) + (eql temp 4))) + +(equal (multiple-value-list (prog2 1 (values 2 3 4) 5)) '(2)) +(equal (multiple-value-list (prog2 1 (values 2 3 4) 5 (values 6 7))) '(2)) + +(eql (prog1 1) 1) +(eql (prog1 1 2) 1) +(eql (prog1 1 2 3) 1) + +(equal (multiple-value-list (prog1 (values 1 2 3))) '(1)) + +(equal (multiple-value-list (prog1 + (values 1 2 3) + (values 4 5 6) + (values 7 8 9))) + '(1)) + +(eql (prog2 1 2) 2) +(eql (prog2 1 2 3) 2) +(eql (prog2 1 2 3 4) 2) + +(let ((x 0)) + (and (eql (prog2 (incf x) + (incf x) + (incf x) + (incf x)) + 2) + (eql x 4))) + + + +(let ((x (cons 'a 'b)) + (y (list 1 2 3))) + (and (equal (setf (car x) 'x (cadr y) (car x) (cdr x) y) '(1 X 3)) + (equal x '(X 1 X 3)) + (equal y '(1 X 3)))) + +(let ((x (cons 'a 'b)) + (y (list 1 2 3))) + (and (null (psetf (car x) 'x (cadr y) (car x) (cdr x) y)) + (equal x '(X 1 A 3)) + (equal y '(1 A 3)))) + +(null (setf)) +(null (psetf)) + +(let ((a 0)) + (and (eql (setf a 10) 10) + (eql a 10))) + +(let ((a 0) + (b 1)) + (and (eql (setf a 10 b 20) 20) + (eql a 10) + (eql b 20))) + +(let ((a 0) + (b 1) + (c 2)) + (and (eql (setf a 10 b (+ a 10) c (+ b 10)) 30) + (eql a 10) + (eql b 20) + (eql c 30))) + +(let ((x (list 0 1 2))) + (and (eq (setf (car x) 'a) 'a) + (eq (setf (cadr x) 'b) 'b) + (eq (setf (caddr x) 'c) 'c) + (equal x '(a b c)))) + + +(let ((a 0)) + (and (null (psetf a 10)) + (eql a 10))) + +(let ((a 0) + (b 1)) + (and (null (psetf a 10 b 20)) + (eql a 10) + (eql b 20))) + +(let ((a 0) + (b 1) + (c 2)) + (and (null (psetf a 10 b (+ a 10) c (+ b 10))) + (eql a 10) + (eql b 10) + (eql c 11))) + +(let ((x (list 0 1 2))) + (and (null (psetf (car x) 'a)) + (null (psetf (cadr x) 'b)) + (null (psetf (caddr x) 'c)) + (equal x '(a b c)))) + + +(let ((x (make-array '(2 3) :initial-contents '((a b c) (x y z))))) + (and (eql (setf (aref x 0 0) 0.0) 0.0) + (eql (setf (aref x 0 1) 0.1) 0.1) + (eql (setf (aref x 0 2) 0.2) 0.2) + (eql (setf (aref x 1 0) 1.0) 1.0) + (eql (setf (aref x 1 1) 1.1) 1.1) + (eql (setf (aref x 1 2) 1.2) 1.2) + (equalp x #2A((0.0 0.1 0.2) (1.0 1.1 1.2))))) + +(let ((x (make-array 4 :element-type 'bit :initial-element 0))) + (and (equalp x #*0000) + (eql (setf (bit x 0) 1) 1) + (eql (setf (bit x 2) 1) 1) + (equal x #*1010))) + +(let ((x (copy-seq "dog"))) + (and (eql (setf (char x 0) #\c) #\c) + (eql (setf (char x 1) #\a) #\a) + (eql (setf (char x 2) #\t) #\t) + (equal x "cat"))) + +(let ((x (copy-seq "dog"))) + (and (eql (setf (schar x 0) #\c) #\c) + (eql (setf (schar x 1) #\a) #\a) + (eql (setf (schar x 2) #\t) #\t) + (equal x "cat"))) + +(let ((x (copy-seq "dog"))) + (and (eql (setf (elt x 0) #\c) #\c) + (eql (setf (elt x 1) #\a) #\a) + (eql (setf (elt x 2) #\t) #\t) + (equal x "cat"))) + +(let ((x (list 0 1 2))) + (and (eql (setf (elt x 0) #\c) #\c) + (eql (setf (elt x 1) #\a) #\a) + (eql (setf (elt x 2) #\t) #\t) + (equal x '(#\c #\a #\t)))) + +(let ((x #'(lambda (a) (+ a 10))) + (saved (when (fboundp 'test-fn) (fdefinition 'test-fn)))) + (unwind-protect (and (eq (setf (fdefinition 'test-fn) x) x) + (eql (test-fn 10) 20)) + (when saved + (setf (fdefinition 'test-fn) saved)))) + +(let ((table (make-hash-table))) + (and (equal (multiple-value-list (gethash 1 table)) '(NIL NIL)) + (equal (multiple-value-list (gethash 1 table 2)) '(2 NIL)) + (equal (setf (gethash 1 table) "one") "one") + (equal (setf (gethash 2 table "two") "two") "two") + (multiple-value-bind (value present-p) (gethash 1 table) + (and (equal value "one") + present-p)) + (multiple-value-bind (value present-p) (gethash 2 table) + (and (equal value "two") + present-p)))) + +(let ((table (make-hash-table))) + (and (equal (multiple-value-list (gethash nil table)) '(NIL NIL)) + (null (setf (gethash nil table) nil)) + (multiple-value-bind (value present-p) (gethash nil table) + (and (equal value NIL) + present-p)))) + +(let ((x (copy-seq #*0101))) + (and (eql (setf (sbit x 0) 1) 1) + (eql (setf (sbit x 2) 1) 1) + (equal x #*1111))) + + +(let ((a 0) + (b 1)) + (and (equal (multiple-value-list (setf (values a b) (values 'x 'y 'z))) + '(x y)) + (eq a 'x) + (eq b 'y))) + +(let ((x (list 0 1 2)) + (order nil)) + (and + (equal (multiple-value-list (setf (values (car (prog1 x (push 0 order))) + (cadr (prog1 x (push 1 order))) + (caddr (prog1 x (push 2 order)))) + (values 'a 'b))) + '(a b nil)) + (equal x '(a b nil)) + (equal order '(2 1 0)))) + + +(let ((a 'a) + (b 'b) + (c 'c)) + (and (equal (multiple-value-list (setf (values (values a) (values b c)) + (values 0 1 2 3 4))) + '(0 1)) + (eql a 0) + (eql b 1) + (null c))) + +(let ((a 'a) + (b 'b) + (c 'c) + (d 'd)) + (and (equal (multiple-value-list (setf (values (values a b) (values c d)) + (values 0 1 2 3 4))) + '(0 1)) + (eql a 0) + (null b) + (eql c 1) + (null d))) + +(let ((a 'a) + (b 'b) + (c 'c) + (d 'd)) + (and (equal (multiple-value-list (setf (values (values a b) (values c d)) + (values 0))) + '(0 nil)) + (eql a 0) + (null b) + (null c) + (null d))) + +(let ((a 'a) + (b 'b) + (c 'c)) + (and (equal (multiple-value-list (setf (values a) (values 0 1 2))) + '(0)) + (eql a 0) + (eq b 'b) + (eq c 'c))) + + +(let ((x (list 1 2 3)) + (y 'trash)) + (and (eq (shiftf y x (cdr x) '(hi there)) 'TRASH) + (equal x '(2 3)) + (equal y '(1 HI THERE)))) + +(let ((x (list 'a 'b 'c))) + (and (eq (shiftf (cadr x) 'z) 'B) + (equal x '(A Z C)) + (eq (shiftf (cadr x) (cddr x) 'q) 'Z) + (equal x '(A (C) . Q)))) + +(let ((n 0) + (x (list 'a 'b 'c 'd))) + (and (eq (shiftf (nth (setq n (+ n 1)) x) 'z) 'B) + (equal x '(A Z C D)))) + + +(let ((a 0) + (b 1) + (c 2) + (d 3)) + (and (equal (multiple-value-list (shiftf (values a b) (values c d) + (values 4 5))) + '(0 1)) + (eql a 2) + (eql b 3) + (eql c 4) + (eql d 5))) + + + +(let ((n 0) + (x (list 'a 'b 'c 'd 'e 'f 'g))) + (and (null (rotatef (nth (incf n) x) + (nth (incf n) x) + (nth (incf n) x))) + (equal x '(A C D B E F G)))) + +(let ((x (list 'a 'b 'c))) + (and (null (rotatef (first x) (second x) (third x))) + (equal x '(b c a)))) + +(let ((x (list 'a 'b 'c 'd 'e 'f))) + (and (null (rotatef (second x) (third x) (fourth x) (fifth x))) + (equal x '(a c d e b f)))) + +(null (rotatef)) +(let ((a 0)) + (and (null (rotatef a)) + (zerop a))) + +(let ((x (list 'a 'b 'c)) + (order nil)) + (and (null (rotatef (first (progn (push 1 order) x)) + (second (progn (push 2 order) x)) + (third (progn (push 3 order) x)))) + (equal x '(b c a)) + (equal order '(3 2 1)))) + +(let ((x (list 'a 'b 'c)) + (order nil)) + (and (null (psetf (first (progn (push 1 order) x)) + (second (progn (push 2 order) x)) + + (second (progn (push 2 order) x)) + (third (progn (push 3 order) x)) + + (third (progn (push 3 order) x)) + (first (progn (push 1 order) x)))) + (equal x '(b c a)) + (equal order '(1 3 3 2 2 1)))) + +(let ((a 0) + (b 1) + (c 2) + (d 3)) + (and (null (rotatef (values a b) (values c d))) + (eql a 2) + (eql b 3) + (eql c 0) + (eql d 1))) + diff --git a/Sacla/tests/must-do.lisp b/Sacla/tests/must-do.lisp new file mode 100644 index 0000000..7cbd326 --- /dev/null +++ b/Sacla/tests/must-do.lisp @@ -0,0 +1,451 @@ +;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp> +;; ALL RIGHTS RESERVED. +;; +;; $Id: must-do.lisp,v 1.8 2004/02/20 07:23:42 yuji Exp $ +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; * Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; * Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;; dotimes +(null (dotimes (i 10))) +(= (dotimes (temp-one 10 temp-one)) 10) +(let ((temp-two 0)) + (and (eq t (dotimes (temp-one 10 t) (incf temp-two))) + (eql temp-two 10))) + +(progn + (defun palindromep (string &optional (start 0) (end (length string))) + (dotimes (k (floor (- end start) 2) t) + (unless (char-equal (char string (+ start k)) + (char string (- end k 1))) + (return nil)))) + (and (palindromep "Able was I ere I saw Elba") + (not (palindromep "A man, a plan, a canal--Panama!")) + (equal (remove-if-not #'alpha-char-p ;Remove punctuation. + "A man, a plan, a canal--Panama!") + "AmanaplanacanalPanama") + (palindromep (remove-if-not #'alpha-char-p + "A man, a plan, a canal--Panama!")) + (palindromep + (remove-if-not #'alpha-char-p + "Unremarkable was I ere I saw Elba Kramer, nu?")))) + + +(let ((count 0)) + (eql (dotimes (i 5 count) (incf count)) 5)) + +(let ((count 0)) + (eql (dotimes (i 1 count) (incf count)) 1)) + +(let ((count 0)) + (zerop (dotimes (i 0 count) (incf count)))) + +(let ((count 0)) + (zerop (dotimes (i -1 count) (incf count)))) + +(let ((count 0)) + (zerop (dotimes (i -100 count) (incf count)))) + +(eql (dotimes (i 3 i)) 3) +(eql (dotimes (i 2 i)) 2) +(eql (dotimes (i 1 i)) 1) +(eql (dotimes (i 0 i)) 0) +(eql (dotimes (i -1 i)) 0) +(eql (dotimes (i -2 i)) 0) +(eql (dotimes (i -10 i)) 0) + +(let ((list nil)) + (and (eq (dotimes (i 10 t) (push i list)) t) + (equal list '(9 8 7 6 5 4 3 2 1 0)))) + +(let ((list nil)) + (equal (dotimes (i 10 (push i list)) (push i list)) + '(10 9 8 7 6 5 4 3 2 1 0))) + +(let ((list nil)) + (equal (dotimes (i '10 (push i list)) (push i list)) + '(10 9 8 7 6 5 4 3 2 1 0))) + +(let ((list nil)) + (equal (dotimes (i (/ 100 10) (push i list)) (push i list)) + '(10 9 8 7 6 5 4 3 2 1 0))) + +(null (dotimes (i 10 t) (return nil))) + +(equal (multiple-value-list (dotimes (i 10 t) (return (values 'a 'b 'c)))) + '(a b c)) + +(let ((val 0)) + (= (dotimes (i 10 val) + (incf val 1) + (when (< i 9) + (go lp)) + (incf val 2) + lp + (incf val 3)) + 42)) + +(= (let ((val 0)) + (dotimes (i 10 val) + (when (< i 9) + (go loop)) + 9 + (incf val 100) + (go last) + loop + (when (= i 0) + (go 9)) + (incf val) + last)) + 208) + +(= 3 (let ((i 3)) (dotimes (i i i) (declare (fixnum i))))) +(= 3 (let ((x 0)) (dotimes (i 3 x) (declare (fixnum i)) (incf x)))) +(= 3 (dotimes (i 3 i) (declare (fixnum i)))) +(= 3 (let ((x 0)) (dotimes (i 3 x) (declare (fixnum i)) (incf x)))) +(equal '((8 6 4 2 0) (9 7 5 3 1)) + (let (even odd) + (dotimes (i 10 (list even odd)) + (cond + ((evenp i) (go even)) + ((oddp i) (go odd)) + (t (error "logic error"))) + even (push i even) (go end) + odd (push i odd) (go end) + end))) + + +;; dolist +(let ((list (copy-tree '((0) (1) (2) (3))))) + (and (null (dolist (item list) (incf (car item)))) + (equal list '((1) (2) (3) (4))))) + +(eq 'ok (dolist (x '(0 1 2) t) (return 'ok))) +(eq 'ok (dolist (x '(0 1 2) t) (return-from nil 'ok))) +(equal '(ok fine) + (multiple-value-list (dolist (x '(0 1 2) t) (return (values 'ok 'fine))))) +(equal '(ok fine) + (multiple-value-list (dolist (x '(0 1 2) t) + (return-from nil (values 'ok 'fine))))) + +(null (let ((x '(0 1 2))) (dolist (x x x)))) +(= 3 (let ((x '(0 1 2)) (i 0)) (dolist (x x i) (incf i)))) + +(null (dolist (x '()))) +(null (dolist (x '(a)))) +(eq t (dolist (x nil t))) +(= 6 (let ((sum 0)) + (dolist (x '(0 1 2 3) sum) + (declare (fixnum x)) + (incf sum x)))) + +(equal '(5 4 3 2 1) + (let (stack) + (flet ((f () (declare (special x)) (1+ x))) + (dolist (x '(0 1 2 3 4) stack) + (declare (special x)) + (declare (type fixnum x)) + (push (f) stack))))) + +(equal '((3 1) (4 2 0)) + (let (odd even) + (dolist (x '(0 1 2 3 4) (list odd even)) + (cond + ((oddp x) (go odd)) + ((evenp x) (go even)) + (t (error "This code mustn't have got executed."))) + odd (push x odd) (go loop-end) + even (push x even) (go loop-end) + loop-end))) + + +(let ((temp-two '())) + (equal (dolist (temp-one '(1 2 3 4) temp-two) (push temp-one temp-two)) + '(4 3 2 1))) + +(let ((temp-two 0)) + (and (null (dolist (temp-one '(1 2 3 4)) (incf temp-two))) + (eql temp-two 4))) + + +(null (dolist (var nil var))) +(let ((list nil)) + (equal (dolist (var '(0 1 2 3) list) + (push var list)) + '(3 2 1 0))) + +(let ((list nil)) + (equal (dolist (var '(0 1 2 3) (push var list)) + (push var list)) + '(nil 3 2 1 0))) + + +(null (dolist (var '(0 1 2 3)))) + +(let ((list nil)) + (and (null (dolist (var '(0 1 2 3)) + (push var list))) + (equal list '(3 2 1 0)))) + +(let ((list nil)) + (and (eq (dolist (var '() t) (push var list)) t) + (null list))) + +(let ((list '((a) (b) (c))) + (count 0)) + (dolist (var list t) + (unless (eq (nth count list) var) + (return nil)) + (incf count))) + +(let ((list nil)) + (and (null (dolist (var '(0 1 2 3) t) + (if (= var 2) + (return) + (push var list)))) + (equal list '(1 0)))) + +(let ((val 0)) + (= (dolist (var '(a b c) val) + (incf val 1) + (unless (eq var 'c) + (go lp)) + (incf val 2) + lp + (incf val 3)) + 14)) + +(= (let ((val 0)) + (dolist (i '(0 1 2 3 4 5 6 7 8 9) val) + (when (< i 9) + (go loop)) + 9 + (incf val 100) + (go last) + loop + (when (= i 0) + (go 9)) + (incf val) + last)) + 208) + +(let ((val 0)) + (= (dolist (i '(0 1 2 3 4 5 6 7 8 9) val) + (incf val 1) + (when (< i 9) + (go lp)) + (incf val 2) + lp + (incf val 3)) + 42)) + +(eq 'ok (block nil + (tagbody + (dolist (x '(0 1 2 3) t) (when (oddp x) (go there))) + there (return 'ok)))) + + + +;; do +(flet ((rev (list) + (do ((x list (cdr x)) + (reverse nil (cons (car x) reverse))) + ((null x) reverse)))) + (and (null (rev nil)) + (equal (rev '(0 1 2 3 4)) '(4 3 2 1 0)))) + +(flet ((nrev (list) + (do ((1st (cdr list) (cdr 1st)) + (2nd list 1st) + (3rd '() 2nd)) + ((null 2nd) 3rd) + (rplacd 2nd 3rd)))) + (and (null (nrev nil)) + (equal (nrev (list 0 1 2 3 4)) '(4 3 2 1 0)))) + +(flet ((sub (list start end) + (do* ((x (nthcdr start list) (cdr x)) + (i start (1+ i)) + (result (list nil)) + (splice result)) + ((>= i end) (cdr result)) + (setq splice (cdr (rplacd splice (list (car x)))))))) + (and (eq (sub '() 0 0) '()) + (equal (sub '(0 1 2 3) 1 4) '(1 2 3)) + (equal (sub '(0 1 2 3) 1 1) '()) + (equal (sub '(0 1 2 3) 1 2) '(1)) + (equal (sub '(0 1 2 3) 1 3) '(1 2)))) + + +(eql (do ((temp-one 1 (1+ temp-one)) + (temp-two 0 (1- temp-two))) + ((> (- temp-one temp-two) 5) temp-one)) + 4) + +(eql (do ((temp-one 1 (1+ temp-one)) + (temp-two 0 (1+ temp-one))) + ((= 3 temp-two) temp-one)) + 3) + +(eql (do* ((temp-one 1 (1+ temp-one)) + (temp-two 0 (1+ temp-one))) + ((= 3 temp-two) temp-one)) + 2) + +(let ((a-vector (vector 1 nil 3 nil))) + (and (null (do ((i 0 (+ i 1)) + (n (array-dimension a-vector 0))) + ((= i n)) + (when (null (aref a-vector i)) + (setf (aref a-vector i) 0)))) + (equalp a-vector #(1 0 3 0)))) + +(let ((vec (vector 0 1 2 3 4 5 6 7 8 9))) + (equalp (do ((i 0 (1+ i)) + n + (j 9 (1- j))) + ((>= i j) vec) + (setq n (aref vec i)) + (setf (aref vec i) (aref vec j)) + (setf (aref vec j) n)) + #(9 8 7 6 5 4 3 2 1 0))) + +(let ((vec (vector 0 1 2 3 4 5 6 7 8 9))) + (and (null (do ((i 0 (1+ i)) + n + (j 9 (1- j))) + ((>= i j)) + (setq n (aref vec i)) + (setf (aref vec i) (aref vec j)) + (setf (aref vec j) n))) + (equalp vec #(9 8 7 6 5 4 3 2 1 0)))) + +(let ((vec (vector 0 1 2 3 4 5 6 7 8 9))) + (and (null (do ((i 0 (1+ i)) + n + (j 9 (1- j))) + ((>= i j)) + (declare (fixnum i j n)) + (setq n (aref vec i)) + (setf (aref vec i) (aref vec j)) + (setf (aref vec j) n))) + (equalp vec #(9 8 7 6 5 4 3 2 1 0)))) + +(let ((vec (vector 0 1 2 3 4 5 6 7 8 9))) + (and (null (do ((i 0 (1+ i)) + n + (j 9 (1- j))) + ((>= i j)) + (declare (fixnum i)) + (declare (fixnum j)) + (declare (fixnum n)) + (setq n (aref vec i)) + (setf (aref vec i) (aref vec j)) + (setf (aref vec j) n))) + (equalp vec #(9 8 7 6 5 4 3 2 1 0)))) + +(let ((vec (vector 0 1 2 3 4 5 6 7 8 9))) + (and (null (do (n + (i 0 (1+ i)) + (j 9 (1- j))) + ((>= i j)) + (declare (fixnum i)) + (declare (fixnum j)) + (declare (fixnum n)) + (setq n (aref vec i)) + (setf (aref vec i) (aref vec j)) + (setf (aref vec j) n))) + (equalp vec #(9 8 7 6 5 4 3 2 1 0)))) + +(let ((vec (vector 0 1 2 3 4 5 6 7 8 9))) + (and (null (do ((i 0 (1+ i)) + (j 9 (1- j)) + n) + ((>= i j)) + (declare (fixnum i)) + (declare (fixnum j)) + (declare (fixnum n)) + (setq n (aref vec i)) + (setf (aref vec i) (aref vec j)) + (setf (aref vec j) n))) + (equalp vec #(9 8 7 6 5 4 3 2 1 0)))) + +(= (do* ((list (list 0 1 2 3 4 5 6 7 8 9) (cdr list)) + (elm (car list) (car list)) + (n 0 (+ n (or elm 0)))) + ((endp list) n)) + 45) + +(= (do* ((list (list 0 1 2 3 4 5 6 7 8 9) (cdr list)) + (elm (car list) (car list)) + (n 0)) + ((endp list) n) + (incf n elm)) + 45) + + +(let ((vec (vector 0 1 2 3 4 5 6 7 8 9))) + (and (null (do* (n + (i 0 (1+ i)) + (j (- 9 i) (- 9 i))) + ((>= i j)) + (declare (fixnum i)) + (declare (fixnum j)) + (declare (fixnum n)) + (setq n (aref vec i)) + (setf (aref vec i) (aref vec j)) + (setf (aref vec j) n))) + (equalp vec #(9 8 7 6 5 4 3 2 1 0)))) + +(let ((vec (vector 0 1 2 3 4 5 6 7 8 9))) + (and (null (do* ((i 0 (1+ i)) + n + (j (- 9 i) (- 9 i))) + ((>= i j)) + (declare (fixnum i j n)) + (setq n (aref vec i)) + (setf (aref vec i) (aref vec j)) + (setf (aref vec j) n))) + (equalp vec #(9 8 7 6 5 4 3 2 1 0)))) + +(let ((vec (vector 0 1 2 3 4 5 6 7 8 9))) + (and (null (do* ((i 0 (1+ i)) + (j (- 9 i) (- 9 i)) + n) + ((>= i j)) + (declare (fixnum i j n)) + (setq n (aref vec i)) + (setf (aref vec i) (aref vec j)) + (setf (aref vec j) n))) + (equalp vec #(9 8 7 6 5 4 3 2 1 0)))) + +(let ((vec (vector 0 1 2 3 4 5 6 7 8 9))) + (and (null (do* ((i 0 (1+ i)) + (j (- 9 i) (- 9 i)) + n) + ((>= i j)) + (setf n (aref vec i) + (aref vec i) (aref vec j) + (aref vec j) n))) + (equalp vec #(9 8 7 6 5 4 3 2 1 0)))) + diff --git a/Sacla/tests/must-eval.lisp b/Sacla/tests/must-eval.lisp new file mode 100644 index 0000000..5b4a8b7 --- /dev/null +++ b/Sacla/tests/must-eval.lisp @@ -0,0 +1,44 @@ +;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp> +;; ALL RIGHTS RESERVED. +;; +;; $Id: must-eval.lisp,v 1.8 2004/08/09 02:49:54 yuji Exp $ +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; * Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; * Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(= (funcall (lambda (x) (+ x 3)) 4) 7) +(= (funcall (lambda (&rest args) (apply #'+ args)) 1 2 3 4) 10) +(functionp (lambda (&rest args) (apply #'+ args))) +(functionp (macro-function 'lambda)) + + + +(every #'special-operator-p '(block catch eval-when flet function go if labels let let* load-time-value locally macrolet multiple-value-call multiple-value-prog1 progn progv quote return-from setq symbol-macrolet tagbody the throw unwind-protect)) +(not (special-operator-p 'car)) +(not (special-operator-p 'cdr)) +;; Bruno: The spec of MACRO-FUNCTION says that an implementation can have +;; additional special operators provided the macro expander is available through +;; MACRO-FUNCTION. +#-CLISP +(not (special-operator-p 'cond)) +(not (special-operator-p 'values)) diff --git a/Sacla/tests/must-eval.patch b/Sacla/tests/must-eval.patch new file mode 100644 index 0000000..8c1211b --- /dev/null +++ b/Sacla/tests/must-eval.patch @@ -0,0 +1,15 @@ +*** sacla/lisp/test/must-eval.lisp 2004-08-03 08:34:54.000000000 +0200 +--- CLISP/clisp-20040712/sacla-tests/must-eval.lisp 2004-08-06 02:38:25.000000000 +0200 +*************** +*** 36,40 **** + (every #'special-operator-p '(block catch eval-when flet function go if labels let let* load-time-value locally macrolet multiple-value-call multiple-value-prog1 progn progv quote return-from setq symbol-macrolet tagbody the throw unwind-protect)) + (not (special-operator-p 'car)) + (not (special-operator-p 'cdr)) +! (not (special-operator-p 'cond)) + (not (special-operator-p 'values)) +--- 36,40 ---- + (every #'special-operator-p '(block catch eval-when flet function go if labels let let* load-time-value locally macrolet multiple-value-call multiple-value-prog1 progn progv quote return-from setq symbol-macrolet tagbody the throw unwind-protect)) + (not (special-operator-p 'car)) + (not (special-operator-p 'cdr)) +! #-CLISP (not (special-operator-p 'cond)) + (not (special-operator-p 'values)) diff --git a/Sacla/tests/must-hash-table.lisp b/Sacla/tests/must-hash-table.lisp new file mode 100644 index 0000000..d3c1e0c --- /dev/null +++ b/Sacla/tests/must-hash-table.lisp @@ -0,0 +1,696 @@ +;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp> +;; ALL RIGHTS RESERVED. +;; +;; $Id: must-hash-table.lisp,v 1.8 2004/08/09 02:49:54 yuji Exp $ +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; * Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; * Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(let ((table (make-hash-table))) + (and (hash-table-p table) + (eql (setf (gethash "one" table) 1) 1) + (equal (multiple-value-list (gethash (copy-seq "one") table)) + '(NIL NIL)))) + +(let ((table (make-hash-table :test 'equal))) + (and (hash-table-p table) + (eql (setf (gethash "one" table) 1) 1) + (equal (multiple-value-list (gethash (copy-seq "one") table)) + '(1 T)))) + +(make-hash-table :rehash-size 1.5 :rehash-threshold 0.7) + +(make-hash-table) +(hash-table-p (make-hash-table)) +#-CLISP ; Bruno: unfounded expectations about hash-table-test +(dolist (test '(eq eql equal equalp) t) + (let ((hash-table (make-hash-table :test test))) + (unless (and (hash-table-p hash-table) + (eq (hash-table-test hash-table) test)) + (return nil)))) +#-CLISP ; Bruno: unfounded expectations about hash-table-test +(dolist (test '(eq eql equal equalp) t) + (let* ((test-function (symbol-function test)) + (hash-table (make-hash-table :test test-function))) + (unless (and (hash-table-p hash-table) + (eq (hash-table-test hash-table) test)) + (return nil)))) + +(hash-table-p (make-hash-table :size 0)) +(hash-table-p (make-hash-table :size 1)) +(hash-table-p (make-hash-table :size 2)) +(hash-table-p (make-hash-table :size 3)) +(hash-table-p (make-hash-table :size 1000)) +(hash-table-p (make-hash-table :rehash-size 1)) +(hash-table-p (make-hash-table :rehash-size 100)) +(hash-table-p (make-hash-table :rehash-size 1.5)) +#-clisp (hash-table-p (make-hash-table :rehash-size 1.0)) +(hash-table-p (make-hash-table :rehash-threshold 0)) +(hash-table-p (make-hash-table :rehash-threshold 0.0)) +(hash-table-p (make-hash-table :rehash-threshold 0.1)) +(hash-table-p (make-hash-table :rehash-threshold 0.12)) +(hash-table-p (make-hash-table :rehash-threshold 0.5)) +(hash-table-p (make-hash-table :rehash-threshold 2/3)) +(hash-table-p (make-hash-table :rehash-threshold 0.888)) +(hash-table-p (make-hash-table :rehash-threshold 0.99)) +(hash-table-p (make-hash-table :rehash-threshold 1)) +(hash-table-p (make-hash-table :rehash-threshold 1.0)) + +(let ((table (make-hash-table :size 0 :rehash-size 1.1 :rehash-threshold 0))) + (and (dotimes (i 10 t) + (setf (gethash i table) i)) + (dotimes (i 10 t) + (unless (eql (gethash i table) i) + (return nil))) + (hash-table-p table))) + +(let ((table (make-hash-table :size 1 :rehash-size 1 :rehash-threshold 1))) + (and (dotimes (i 100 t) + (setf (gethash i table) i)) + (dotimes (i 100 t) + (unless (eql (gethash i table) i) + (return nil))) + (hash-table-p table))) + + + +(not (hash-table-p 'hash-table)) + +(let ((table (make-hash-table))) + (hash-table-p table)) +(not (hash-table-p 37)) +(not (hash-table-p '((a . 1) (b . 2)))) +(not (hash-table-p (type-of (make-hash-table)))) + + +(let ((table (make-hash-table))) + (and (zerop (hash-table-count table)) + (equal (setf (gethash 57 table) "fifty-seven") "fifty-seven") + (eql (hash-table-count table) 1) + (dotimes (i 100 t) (setf (gethash i table) i)) + (eql (hash-table-count table) 100))) + +(zerop (hash-table-count (make-hash-table))) +(let ((table (make-hash-table))) + (and (eql (setf (gethash 'key table) 9) 9) + (= (hash-table-count table) 1))) + + +#-CLISP ;Bruno: unfounded expectations about hash-table-rehash-size +(let ((table (make-hash-table :size 100 :rehash-size 1.4))) + (= (hash-table-rehash-size table) 1.4)) + +#-CLISP ;Bruno: unfounded expectations about hash-table-rehash-threshold +(let ((table (make-hash-table :size 100 :rehash-threshold 0.5))) + (= (hash-table-rehash-threshold table) 0.5)) + +(<= 0 (hash-table-size (make-hash-table))) + +#-CLISP ;Bruno: unfounded expectations about hash-table-test +(eq 'eq (hash-table-test (make-hash-table :test 'eq))) +#-CLISP ;Bruno: unfounded expectations about hash-table-test +(eq 'eq (hash-table-test (make-hash-table :test #'eq))) +#-CLISP ;Bruno: unfounded expectations about hash-table-test +(eq 'eql (hash-table-test (make-hash-table))) +#-CLISP ;Bruno: unfounded expectations about hash-table-test +(eq 'eql (hash-table-test (make-hash-table :test 'eql))) +#-CLISP ;Bruno: unfounded expectations about hash-table-test +(eq 'eql (hash-table-test (make-hash-table :test #'eql))) +#-CLISP ;Bruno: unfounded expectations about hash-table-test +(eq 'equal (hash-table-test (make-hash-table :test 'equal))) +#-CLISP ;Bruno: unfounded expectations about hash-table-test +(eq 'equal (hash-table-test (make-hash-table :test #'equal))) +#-CLISP ;Bruno: unfounded expectations about hash-table-test +(eq 'equalp (hash-table-test (make-hash-table :test 'equalp))) +#-CLISP ;Bruno: unfounded expectations about hash-table-test +(eq 'equalp (hash-table-test (make-hash-table :test #'equalp))) + +(let* ((table0 (make-hash-table)) + (table (make-hash-table + :size (hash-table-size table0) + :test (hash-table-test table0) + :rehash-threshold (hash-table-rehash-threshold table0) + :rehash-size (hash-table-rehash-size table0)))) + (and (hash-table-p table) + (zerop (hash-table-count table)) + (eq (type-of table) 'hash-table))) + + +(let ((table (make-hash-table))) + (and (equal (multiple-value-list (gethash 1 table)) '(NIL NIL)) + (equal (multiple-value-list (gethash 1 table 2)) '(2 nil)) + (equal (setf (gethash 1 table) "one") "one") + (equal (setf (gethash 2 table "two") "two") "two") + (multiple-value-bind (value present-p) (gethash 1 table) + (and (equal value "one") present-p)) + (multiple-value-bind (value present-p) (gethash 2 table) + (and (equal value "two") present-p)) + (equal (multiple-value-list (gethash nil table)) '(nil nil)) + (null (setf (gethash nil table) nil)) + (multiple-value-bind (value present-p) (gethash nil table) + (and (not value) present-p)))) + +(multiple-value-bind (value present-p) + (gethash 'key (make-hash-table) 'default) + (and (eq value 'default) (not present-p))) + +(multiple-value-bind (value present-p) + (gethash 'key (make-hash-table)) + (and (null value) (not present-p))) + + +(let ((table (make-hash-table))) + (and (multiple-value-bind (value present-p) (gethash 'key table) + (and (null value) (not present-p))) + (eql (setf (gethash 'key table) 100) 100) + (multiple-value-bind (value present-p) (gethash 'key table) + (and (eql value 100) present-p)))) + +(let ((table (make-hash-table)) + (list nil)) + (and (eql (setf (gethash (progn (push 0 list) 0) + (progn (push 1 list) table) + (progn (push 2 list) 'default)) + (progn (push 3 list) 9)) + 9) + (equal list '(3 2 1 0)))) + +(let ((table (make-hash-table))) + (and (dotimes (i 100 t) + (unless (eql (setf (gethash i table) (* i 10)) (* i 10)) + (return nil))) + (= (hash-table-count table) 100) + (dotimes (i 100 t) + (unless (multiple-value-bind (value present-p) (gethash i table) + (and (eql value (* i 10)) present-p)) + (return nil))))) + + +(let ((table (make-hash-table))) + (and (equal (setf (gethash 100 table) "C") "C") + (multiple-value-bind (value present-p) (gethash 100 table) + (and (equal value "C") present-p)) + (remhash 100 table) + (multiple-value-bind (value present-p) (gethash 100 table) + (and (not value) (not present-p))) + (not (remhash 100 table)))) + +(let ((table (make-hash-table))) + (and (zerop (hash-table-count table)) + (eql (setf (gethash 'a table) 'abc) 'abc) + (multiple-value-bind (value present-p) (gethash 'a table) + (and (eq value 'abc) present-p)) + (eql (hash-table-count table) 1) + (remhash 'a table) + (multiple-value-bind (value present-p) (gethash 'a table) + (and (not value) (not present-p))) + (zerop (hash-table-count table)))) + +(not (remhash 'key (make-hash-table))) + + +(with-hash-table-iterator (iterator (make-hash-table)) + (macrolet ((test (&environment env) + (if (macro-function 'iterator env) t nil))) + (test))) + + +(let ((table (make-hash-table)) + (alist nil)) + (dotimes (i 10) (setf (gethash i table) i)) + (with-hash-table-iterator (iterator table) + (loop + (multiple-value-bind (more key value) (iterator) + (unless more + (return)) + (push (list key value) alist)))) + (setq alist (sort alist #'< :key #'car)) + (equal alist '((0 0) (1 1) (2 2) (3 3) (4 4) (5 5) (6 6) (7 7) (8 8) (9 9)))) + + +(let ((table (make-hash-table)) + (eval 0)) + (dotimes (i 10) (setf (gethash i table) i)) + (with-hash-table-iterator (iterator (progn (incf eval) table)) + (loop + (multiple-value-bind (more key value) (iterator) + (declare (ignore key value)) + (unless more + (return))))) + (eql eval 1)) + + +(with-hash-table-iterator (iterator (make-hash-table)) + (null (iterator))) + + +(let ((table (make-hash-table)) + alist0 alist1 alist2) + (dotimes (i 100) (setf (gethash i table) i)) + (and (with-hash-table-iterator (iterator0 table) + (with-hash-table-iterator (iterator1 table) + (with-hash-table-iterator (iterator2 table) + (loop + (multiple-value-bind (more0 key0 value0) (iterator0) + (multiple-value-bind (more1 key1 value1) (iterator1) + (multiple-value-bind (more2 key2 value2) (iterator2) + (unless (or (every #'null (list more0 more1 more2)) + (every #'identity (list more0 more1 more2))) + (return nil)) + (when (every #'null (list more0 more1 more2)) + (return t)) + (push (cons key0 value0) alist0) + (push (cons key1 value1) alist1) + (push (cons key2 value2) alist2)))))))) + (equal (sort alist0 #'< :key #'car) + (setq alist1 (sort alist1 #'< :key #'car))) + (equal alist1 (sort alist2 #'< :key #'car)))) + + + +(let ((table (make-hash-table :rehash-size 100)) + (n 0) + (alist nil)) + (and (dolist (key '(a b c d e f g h i j k) t) + (unless (eql (setf (gethash key table) n) n) + (return nil)) + (incf n)) + (remhash 'b table) + (remhash 'd table) + (remhash 'f table) + (remhash 'h table) + (remhash 'j table) + (not (remhash 'b table)) + (not (remhash 'd table)) + (not (remhash 'f table)) + (not (remhash 'h table)) + (not (remhash 'j table)) + (with-hash-table-iterator (iterator table) + (loop + (multiple-value-bind (more key value) (iterator) + (unless more + (return t)) + (push (cons key value) alist)))) + (equal (sort alist #'< :key #'cdr) + '((a . 0) (c . 2) (e . 4) (g . 6) (i . 8) (k . 10))))) + + +(let ((table (make-hash-table))) + (and (null (dotimes (i 10) (setf (gethash i table) i))) + (eql (let ((sum-of-squares 0)) + (maphash #'(lambda (key val) + (let ((square (* val val))) + (incf sum-of-squares square) + (setf (gethash key table) square))) + table) + sum-of-squares) + 285) + (eql (hash-table-count table) 10) + (null (maphash #'(lambda (key val) + (when (oddp val) (remhash key table))) + table)) + (eql (hash-table-count table) 5) + (let ((alist nil)) + (and (null (maphash #'(lambda (key val) + (push (list key val) alist)) + table)) + (equalp (sort alist #'< :key #'car) + '((0 0) (2 4) (4 16) (6 36) (8 64))))))) + + +(let ((table (make-hash-table)) + (alist nil)) + (and (null (dotimes (i 10) (setf (gethash i table) i))) + (null (maphash #'(lambda (key val) + (if (evenp key) + (setf (gethash key table) (* val val)) + (remhash key table))) + table)) + (null (maphash #'(lambda (key val) (push (cons key val) alist)) table)) + (equal (sort alist #'< :key #'car) + '((0 . 0) (2 . 4) (4 . 16) (6 . 36) (8 . 64))))) + + + +(flet ((test-hash-table-iterator (hash-table) + (let ((all-entries '()) + (generated-entries '()) + (unique (list nil))) + (maphash #'(lambda (key value) (push (list key value) all-entries)) + hash-table) + (with-hash-table-iterator (generator-fn hash-table) + (loop + (multiple-value-bind (more? key value) (generator-fn) + (unless more? (return)) + (unless (eql value (gethash key hash-table unique)) + (error "Key ~S not found for value ~S" key value)) + (push (list key value) generated-entries)))) + (unless (= (length all-entries) + (length generated-entries) + (length (union all-entries generated-entries + :key #'car + :test (hash-table-test hash-table)))) + (error "Generated entries and Maphash entries don't correspond")) + t))) + (let ((table (make-hash-table :rehash-size 100)) + (n 0)) + (and (dolist (key '(a b c d e f g h i j k) t) + (unless (eql (setf (gethash key table) n) n) + (return nil)) + (incf n)) + (remhash 'b table) + (remhash 'd table) + (remhash 'f table) + (remhash 'h table) + (remhash 'j table) + (not (remhash 'b table)) + (not (remhash 'd table)) + (not (remhash 'f table)) + (not (remhash 'h table)) + (not (remhash 'j table)) + (test-hash-table-iterator table) + (test-hash-table-iterator (make-hash-table))))) + + + + +(let ((table (make-hash-table))) + (and (null (dotimes (i 100) (setf (gethash i table) (format nil "~R" i)))) + (eql (hash-table-count table) 100) + (multiple-value-bind (value present-p) (gethash 57 table) + (and (equal value "fifty-seven") present-p)) + (hash-table-p (clrhash table)) + (zerop (hash-table-count table)) + (multiple-value-bind (value present-p) (gethash 57 table) + (and (null value) (not present-p))))) + + +(let ((code (sxhash 'a))) + (and (typep code 'fixnum) + (<= 0 code))) + +(dolist (item '(a "" #\a (make-hash-table) (make-array '(2 3 4)) #*0101 "xx") t) + (let ((code (sxhash item))) + (unless (and (typep code 'fixnum) (<= 0 code)) + (return nil)))) + + + +(let ((table (make-hash-table :rehash-threshold 0.8))) + (and (eql (setf (gethash 'key table) 'value0) 'value0) + (eql (hash-table-count table) 1) + (eql (setf (gethash 'key table) 'value1) 'value1) + (eql (hash-table-count table) 1) + (eq (gethash 'key table) 'value1))) + +(let ((table (make-hash-table :rehash-threshold 0.8))) + (and (eql (setf (gethash 'key0 table) 'value0) 'value0) + (eql (hash-table-count table) 1) + (eql (setf (gethash 'key1 table) 'value1) 'value1) + (eql (hash-table-count table) 2) + (eql (setf (gethash 'key2 table) 'value2) 'value2) + (eql (hash-table-count table) 3) + (eql (setf (gethash 'key0 table) 'value00) 'value00) + (eql (hash-table-count table) 3) + (eql (setf (gethash 'key2 table) 'value22) 'value22) + (eql (hash-table-count table) 3) + (eq (gethash 'key0 table) 'value00) + (eq (gethash 'key1 table) 'value1) + (eq (gethash 'key2 table) 'value22))) + + +(let ((table (make-hash-table :size 0 :test 'eq)) + (key0 (copy-seq "key")) + (key1 (copy-seq "key"))) + (and (not (eq key0 key1)) + (eq (setf (gethash key0 table) 'value) 'value) + (multiple-value-bind (value present-p) (gethash key1 table) + (and (null value) (not present-p))) + (multiple-value-bind (value present-p) (gethash key0 table) + (and (eq value 'value) present-p)))) + +(let ((table (make-hash-table :size 0 :test 'eql)) + (key0 (copy-seq "key")) + (key1 (copy-seq "key"))) + (and (not (eql key0 key1)) + (eq (setf (gethash key0 table) 'value) 'value) + (multiple-value-bind (value present-p) (gethash key1 table) + (and (null value) (not present-p))) + (multiple-value-bind (value present-p) (gethash key0 table) + (and (eq value 'value) present-p)))) + +(let ((table (make-hash-table :size 0 :test 'eql)) + (key0 1.0) + (key1 1.0)) + (and (eql key0 key1) + (eq (setf (gethash key0 table) 'value) 'value) + (multiple-value-bind (value present-p) (gethash key1 table) + (and (eq value 'value) present-p)) + (multiple-value-bind (value present-p) (gethash key0 table) + (and (eq value 'value) present-p)))) + +(let ((table (make-hash-table :size 0 :test 'eql)) + (key0 #\a) + (key1 #\a)) + (and (eql key0 key1) + (eq (setf (gethash key0 table) 'value) 'value) + (multiple-value-bind (value present-p) (gethash key1 table) + (and (eq value 'value) present-p)) + (multiple-value-bind (value present-p) (gethash key0 table) + (and (eq value 'value) present-p)))) + +(let ((table (make-hash-table :size 0 :test 'eql)) + (key0 #\a) + (key1 #\A)) + (and (not (eql key0 key1)) + (eq (setf (gethash key0 table) 'value) 'value) + (multiple-value-bind (value present-p) (gethash key1 table) + (and (null value) (not present-p))) + (multiple-value-bind (value present-p) (gethash key0 table) + (and (eq value 'value) present-p)))) + +(let ((table (make-hash-table :size 16 :test 'equal)) + (key0 'key) + (key1 'key)) + (and (eq key0 key1) + (equal key0 key1) + (eq (setf (gethash key0 table) 'value) 'value) + (multiple-value-bind (value present-p) (gethash key1 table) + (and (eq value 'value) present-p)) + (multiple-value-bind (value present-p) (gethash key0 table) + (and (eq value 'value) present-p)))) + +(let ((table (make-hash-table :size 0 :test 'equal)) + (key0 1.0) + (key1 1.0)) + (and (equal key0 key1) + (eq (setf (gethash key0 table) 'value) 'value) + (multiple-value-bind (value present-p) (gethash key1 table) + (and (eq value 'value) present-p)) + (multiple-value-bind (value present-p) (gethash key0 table) + (and (eq value 'value) present-p)))) + +(let ((table (make-hash-table :size 0 :test 'equal)) + (key0 #\a) + (key1 #\a)) + (and (equal key0 key1) + (eq (setf (gethash key0 table) 'value) 'value) + (multiple-value-bind (value present-p) (gethash key1 table) + (and (eq value 'value) present-p)) + (multiple-value-bind (value present-p) (gethash key0 table) + (and (eq value 'value) present-p)))) + +(let ((table (make-hash-table :size 0 :test 'equal)) + (key0 #\a) + (key1 #\A)) + (and (not (equal key0 key1)) + (eq (setf (gethash key0 table) 'value) 'value) + (multiple-value-bind (value present-p) (gethash key1 table) + (and (null value) (not present-p))) + (multiple-value-bind (value present-p) (gethash key0 table) + (and (eq value 'value) present-p)))) + +(let ((table (make-hash-table :size 16 :test 'equal)) + (key0 (copy-seq "key")) + (key1 (copy-seq "key"))) + (and (not (eq key0 key1)) + (equal key0 key1) + (eq (setf (gethash key0 table) 'value) 'value) + (multiple-value-bind (value present-p) (gethash key1 table) + (and (eq value 'value) present-p)) + (multiple-value-bind (value present-p) (gethash key0 table) + (and (eq value 'value) present-p)))) + +(let ((table (make-hash-table :size 16 :test 'equal)) + (key0 (copy-seq "key")) + (key1 (copy-seq "KEY"))) + (and (not (eq key0 key1)) + (not (equal key0 key1)) + (eq (setf (gethash key0 table) 'value) 'value) + (multiple-value-bind (value present-p) (gethash key1 table) + (and (null value) (not present-p))) + (multiple-value-bind (value present-p) (gethash key0 table) + (and (eq value 'value) present-p)))) + +(let ((table (make-hash-table :size 10 :test 'equal)) + (key0 (copy-seq '(key))) + (key1 (copy-seq '(key)))) + (and (not (eq key0 key1)) + (equal key0 key1) + (eq (setf (gethash key0 table) 'value) 'value) + (multiple-value-bind (value present-p) (gethash key1 table) + (and (eq value 'value) present-p)) + (multiple-value-bind (value present-p) (gethash key0 table) + (and (eq value 'value) present-p)))) + +(let ((table (make-hash-table :size 16 :test 'equal)) + (key0 (copy-seq #*1010)) + (key1 (copy-seq #*1010))) + (and (not (eq key0 key1)) + (equal key0 key1) + (eq (setf (gethash key0 table) 'value) 'value) + (multiple-value-bind (value present-p) (gethash key1 table) + (and (eq value 'value) present-p)) + (multiple-value-bind (value present-p) (gethash key0 table) + (and (eq value 'value) present-p)))) + +(let ((table (make-hash-table :size 16 :test 'equal)) + (key0 (copy-seq #(a b c))) + (key1 (copy-seq #(a b c)))) + (and (not (eq key0 key1)) + (not (equal key0 key1)) + (eq (setf (gethash key0 table) 'value) 'value) + (multiple-value-bind (value present-p) (gethash key1 table) + (and (null value) (not present-p))) + (multiple-value-bind (value present-p) (gethash key0 table) + (and (eq value 'value) present-p)))) + +(let ((table (make-hash-table :size 10 :test 'equal)) + (key0 (make-pathname)) + (key1 (make-pathname))) + (and (not (eq key0 key1)) + (equal key0 key1) + (eq (setf (gethash key0 table) 'value) 'value) + (multiple-value-bind (value present-p) (gethash key1 table) + (and (eq value 'value) present-p)) + (multiple-value-bind (value present-p) (gethash key0 table) + (and (eq value 'value) present-p)))) + + +(let ((table (make-hash-table :size 0 :test 'equalp)) + (key0 (copy-seq "key")) + (key1 (copy-seq "key"))) + (and (equalp key0 key1) + (eq (setf (gethash key0 table) 'value) 'value) + (multiple-value-bind (value present-p) (gethash key1 table) + (and (eq value 'value) present-p)) + (multiple-value-bind (value present-p) (gethash key0 table) + (and (eq value 'value) present-p)))) + +(let ((table (make-hash-table :size 0 :test 'equalp)) + (key0 1.0) + (key1 1.0)) + (and (equalp key0 key1) + (eq (setf (gethash key0 table) 'value) 'value) + (multiple-value-bind (value present-p) (gethash key1 table) + (and (eq value 'value) present-p)) + (multiple-value-bind (value present-p) (gethash key0 table) + (and (eq value 'value) present-p)))) + +(let ((table (make-hash-table :size 100 :test 'equalp)) + (key0 1) + (key1 1.0)) + (and (not (eq key0 key1)) + (equalp key0 key1) + (eq (setf (gethash key0 table) 'value) 'value) + (multiple-value-bind (value present-p) (gethash key1 table) + (and (eq value 'value) present-p)) + (multiple-value-bind (value present-p) (gethash key0 table) + (and (eq value 'value) present-p)))) + +(let ((table (make-hash-table :size 0 :test 'equalp)) + (key0 #\a) + (key1 #\a)) + (and (equalp key0 key1) + (eq (setf (gethash key0 table) 'value) 'value) + (multiple-value-bind (value present-p) (gethash key1 table) + (and (eq value 'value) present-p)) + (multiple-value-bind (value present-p) (gethash key0 table) + (and (eq value 'value) present-p)))) + +(let ((table (make-hash-table :size 10 :test 'equalp)) + (key0 #\a) + (key1 #\A)) + (and (not (eq key0 key1)) + (equalp key0 key1) + (eq (setf (gethash key0 table) 'value) 'value) + (multiple-value-bind (value present-p) (gethash key1 table) + (and (eq value 'value) present-p)) + (multiple-value-bind (value present-p) (gethash key0 table) + (and (eq value 'value) present-p)))) + +(let ((table (make-hash-table :size 3 :test 'equalp)) + (key0 (copy-seq '(#\a))) + (key1 (copy-seq '(#\A)))) + (and (not (eq key0 key1)) + (equalp key0 key1) + (eq (setf (gethash key0 table) 'value) 'value) + (multiple-value-bind (value present-p) (gethash key1 table) + (and (eq value 'value) present-p)) + (multiple-value-bind (value present-p) (gethash key0 table) + (and (eq value 'value) present-p)))) + +(let ((table (make-hash-table :size 3 :test 'equalp)) + (key0 (copy-seq '(#\a (1)))) + (key1 (copy-seq '(#\A (1.0))))) + (and (not (eq key0 key1)) + (equalp key0 key1) + (eq (setf (gethash key0 table) 'value) 'value) + (multiple-value-bind (value present-p) (gethash key1 table) + (and (eq value 'value) present-p)) + (multiple-value-bind (value present-p) (gethash key0 table) + (and (eq value 'value) present-p)))) + +(let ((table (make-hash-table :test 'equalp)) + (key0 (make-hash-table)) + (key1 (make-hash-table))) + (and (not (eq key0 key1)) + (equalp key0 key1) + (eq (setf (gethash key0 table) 'value) 'value) + (multiple-value-bind (value present-p) (gethash key1 table) + (and (eq value 'value) present-p)) + (multiple-value-bind (value present-p) (gethash key0 table) + (and (eq value 'value) present-p)))) + +(let ((table (make-hash-table))) + (and (zerop (hash-table-count table)) + (dolist (pair '((a abc) (a bc) (1 "one") (1.0 "ONE") (#\a a) (#\A b)) t) + (unless (eq (setf (gethash (car pair) table) (cadr pair)) (cadr pair)) + (return nil))) + (eql (hash-table-count table) 5) + (eq (gethash 'a table) 'bc) + (equal (gethash 1 table) "one") + (equal (gethash 1.0 table) "ONE") + (eql (gethash #\A table) 'b) + (eql (gethash #\a table) 'a))) + diff --git a/Sacla/tests/must-hash-table.patch b/Sacla/tests/must-hash-table.patch new file mode 100644 index 0000000..c9ea48c --- /dev/null +++ b/Sacla/tests/must-hash-table.patch @@ -0,0 +1,55 @@ +*** sacla/lisp/test/must-hash-table.lisp 2004-08-03 08:34:54.000000000 +0200 +--- CLISP/clisp-20040712/sacla-tests/must-hash-table.lisp 2004-08-06 02:45:56.000000000 +0200 +*************** +*** 42,52 **** +--- 42,54 ---- + + (make-hash-table) + (hash-table-p (make-hash-table)) ++ #-CLISP ; unfounded expectations about hash-table-test + (dolist (test '(eq eql equal equalp) t) + (let ((hash-table (make-hash-table :test test))) + (unless (and (hash-table-p hash-table) + (eq (hash-table-test hash-table) test)) + (return nil)))) ++ #-CLISP ; unfounded expectations about hash-table-test + (dolist (test '(eq eql equal equalp) t) + (let* ((test-function (symbol-function test)) + (hash-table (make-hash-table :test test-function))) +*************** +*** 114,135 **** +--- 116,148 ---- + (= (hash-table-count table) 1))) + + ++ #-CLISP ; unfounded expectations about hash-table-rehash-size + (let ((table (make-hash-table :size 100 :rehash-size 1.4))) + (= (hash-table-rehash-size table) 1.4)) + ++ #-CLISP ; unfounded expectations about hash-table-rehash-threshold + (let ((table (make-hash-table :size 100 :rehash-threshold 0.5))) + (= (hash-table-rehash-threshold table) 0.5)) + + (<= 0 (hash-table-size (make-hash-table))) + ++ #-CLISP ; unfounded expectations about hash-table-test + (eq 'eq (hash-table-test (make-hash-table :test 'eq))) ++ #-CLISP ; unfounded expectations about hash-table-test + (eq 'eq (hash-table-test (make-hash-table :test #'eq))) ++ #-CLISP ; unfounded expectations about hash-table-test + (eq 'eql (hash-table-test (make-hash-table))) ++ #-CLISP ; unfounded expectations about hash-table-test + (eq 'eql (hash-table-test (make-hash-table :test 'eql))) ++ #-CLISP ; unfounded expectations about hash-table-test + (eq 'eql (hash-table-test (make-hash-table :test #'eql))) ++ #-CLISP ; unfounded expectations about hash-table-test + (eq 'equal (hash-table-test (make-hash-table :test 'equal))) ++ #-CLISP ; unfounded expectations about hash-table-test + (eq 'equal (hash-table-test (make-hash-table :test #'equal))) ++ #-CLISP ; unfounded expectations about hash-table-test + (eq 'equalp (hash-table-test (make-hash-table :test 'equalp))) ++ #-CLISP ; unfounded expectations about hash-table-test + (eq 'equalp (hash-table-test (make-hash-table :test #'equalp))) + + (let* ((table0 (make-hash-table)) + diff --git a/Sacla/tests/must-loop.lisp b/Sacla/tests/must-loop.lisp new file mode 100644 index 0000000..bb28d00 --- /dev/null +++ b/Sacla/tests/must-loop.lisp @@ -0,0 +1,3605 @@ +;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp> +;; ALL RIGHTS RESERVED. +;; +;; $Id: must-loop.lisp,v 1.16 2004/09/28 01:52:16 yuji Exp $ +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; * Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; * Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + +;; simple loop +(null (loop (return))) +(loop (return-from nil t)) +(null (let ((stack '(0 1 2))) (loop (unless (pop stack) (return))) stack)) +(equal (multiple-value-list (loop (return (values 0 1 2)))) '(0 1 2)) +(= 100 (let ((i 0)) (loop (incf i) (when (>= i 100) (return i))))) +(eq (let (x) (tagbody (loop (go end)) end (setq x t)) x) t) +(eq t (catch 'end (loop (throw 'end t)))) +(eq t (block here (loop (return-from here t)))) +(= 3 (let ((i 0)) (loop (incf i) (if (= i 3) (return i))))) +(= 9 (let ((i 0)(j 0)) + (tagbody + (loop (incf j 3) (incf i) (if (= i 3) (go exit))) + exit) + j)) + + +;; loop keyword identity +(equal (let (stack) (loop :for a :from 1 :to 3 :by 1 :do (push a stack)) stack) + '(3 2 1)) +(let ((for (make-symbol "FOR")) + (from (make-symbol "FROM")) + (to (make-symbol "TO")) + (by (make-symbol "BY")) + (do (make-symbol "DO"))) + (equal (eval `(let (stack) + (loop ,for a ,from 1 ,to 3 ,by 1 ,do (push a stack)) + stack)) + '(3 2 1))) +(let ((for (make-symbol "FOR"))) + (equal (eval `(let (stack) (loop ,for a :from 1 :to 3 :by 1 :do (push a stack)) + stack)) + '(3 2 1))) + +(progn + (when (find-package "LOOP-KEY-TEST") + (delete-package "LOOP-KEY-TEST")) + (let* ((pkg (defpackage "LOOP-KEY-TEST")) + (for (intern "FOR" pkg)) + (in (intern "IN" pkg)) + (by (progn (import 'by pkg) (intern "BY" pkg))) + (collect (progn (import 'collect pkg) (intern "COLLECT" pkg)))) + (export collect pkg) + (and (equal (eval `(loop ,for elt ,in '(1 2 3 4 5) ,by #'cddr + ,collect elt)) + '(1 3 5)) + (delete-package pkg)))) + + +;; for-as-arithmetic-up with 3 forms +(equal (let (stack) (loop for a from 1 to 3 by 1 do (push a stack)) stack) + '(3 2 1)) +(equal (let (stack) (loop for a from 1 by 1 to 3 do (push a stack)) stack) + '(3 2 1)) +(equal (let (stack) (loop for a to 3 by 1 from 1 do (push a stack)) stack) + '(3 2 1)) +(equal (let (stack) (loop for a to 3 from 1 by 1 do (push a stack)) stack) + '(3 2 1)) +(equal (let (stack) (loop for a by 1 to 3 from 1 do (push a stack)) stack) + '(3 2 1)) +(equal (let (stack) (loop for a by 1 from 1 to 3 do (push a stack)) stack) + '(3 2 1)) + +(equal (let (stack) (loop for a upfrom 1 to 3 by 1 do (push a stack)) stack) + '(3 2 1)) +(equal (let (stack) (loop for a upfrom 1 by 1 to 3 do (push a stack)) stack) + '(3 2 1)) +(equal (let (stack) (loop for a to 3 by 1 upfrom 1 do (push a stack)) stack) + '(3 2 1)) +(equal (let (stack) (loop for a to 3 upfrom 1 by 1 do (push a stack)) stack) + '(3 2 1)) +(equal (let (stack) (loop for a by 1 to 3 upfrom 1 do (push a stack)) stack) + '(3 2 1)) +(equal (let (stack) (loop for a by 1 upfrom 1 to 3 do (push a stack)) stack) + '(3 2 1)) + + +(equal (let (stack) (loop for a from 1 upto 3 by 1 do (push a stack)) stack) + '(3 2 1)) +(equal (let (stack) (loop for a from 1 by 1 upto 3 do (push a stack)) stack) + '(3 2 1)) +(equal (let (stack) (loop for a upto 3 by 1 from 1 do (push a stack)) stack) + '(3 2 1)) +(equal (let (stack) (loop for a upto 3 from 1 by 1 do (push a stack)) stack) + '(3 2 1)) +(equal (let (stack) (loop for a by 1 upto 3 from 1 do (push a stack)) stack) + '(3 2 1)) +(equal (let (stack) (loop for a by 1 from 1 upto 3 do (push a stack)) stack) + '(3 2 1)) + +(equal (let (stack) (loop for a upfrom 1 upto 3 by 1 do (push a stack)) stack) + '(3 2 1)) +(equal (let (stack) (loop for a upfrom 1 by 1 upto 3 do (push a stack)) stack) + '(3 2 1)) +(equal (let (stack) (loop for a upto 3 by 1 upfrom 1 do (push a stack)) stack) + '(3 2 1)) +(equal (let (stack) (loop for a upto 3 upfrom 1 by 1 do (push a stack)) stack) + '(3 2 1)) +(equal (let (stack) (loop for a by 1 upto 3 upfrom 1 do (push a stack)) stack) + '(3 2 1)) +(equal (let (stack) (loop for a by 1 upfrom 1 upto 3 do (push a stack)) stack) + '(3 2 1)) + + +(equal (let (stack) (loop for a from 1 below 4 by 1 do (push a stack)) stack) + '(3 2 1)) +(equal (let (stack) (loop for a from 1 by 1 below 4 do (push a stack)) stack) + '(3 2 1)) +(equal (let (stack) (loop for a below 4 by 1 from 1 do (push a stack)) stack) + '(3 2 1)) +(equal (let (stack) (loop for a below 4 from 1 by 1 do (push a stack)) stack) + '(3 2 1)) +(equal (let (stack) (loop for a by 1 below 4 from 1 do (push a stack)) stack) + '(3 2 1)) +(equal (let (stack) (loop for a by 1 from 1 below 4 do (push a stack)) stack) + '(3 2 1)) + +(equal (let (stack) (loop for a upfrom 1 below 4 by 1 do (push a stack)) stack) + '(3 2 1)) +(equal (let (stack) (loop for a upfrom 1 by 1 below 4 do (push a stack)) stack) + '(3 2 1)) +(equal (let (stack) (loop for a below 4 by 1 upfrom 1 do (push a stack)) stack) + '(3 2 1)) +(equal (let (stack) (loop for a below 4 upfrom 1 by 1 do (push a stack)) stack) + '(3 2 1)) +(equal (let (stack) (loop for a by 1 below 4 upfrom 1 do (push a stack)) stack) + '(3 2 1)) +(equal (let (stack) (loop for a by 1 upfrom 1 below 4 do (push a stack)) stack) + '(3 2 1)) + + +;; for-as-arithmetic-up with 2 forms +(equal (let (stack) (loop for a from 1 to 3 do (push a stack)) stack) '(3 2 1)) +(equal (let (stack) (loop for a to 3 from 1 do (push a stack)) stack) '(3 2 1)) + +(equal (let (stack) (loop for a upfrom 1 to 3 do (push a stack)) stack) '(3 2 1)) +(equal (let (stack) (loop for a to 3 upfrom 1 do (push a stack)) stack) '(3 2 1)) + + +(equal (let (stack) (loop for a from 1 upto 3 do (push a stack)) stack) '(3 2 1)) +(equal (let (stack) (loop for a upto 3 from 1 do (push a stack)) stack) '(3 2 1)) + +(equal (let (stack) (loop for a upfrom 1 upto 3 do (push a stack)) stack) + '(3 2 1)) +(equal (let (stack) (loop for a upto 3 upfrom 1 do (push a stack)) stack) + '(3 2 1)) + + +(equal (let (stack) (loop for a from 1 below 4 do (push a stack)) stack) '(3 2 1)) +(equal (let (stack) (loop for a below 4 from 1 do (push a stack)) stack) '(3 2 1)) + +(equal (let (stack) (loop for a upfrom 1 below 4 do (push a stack)) stack) + '(3 2 1)) +(equal (let (stack) (loop for a below 4 upfrom 1 do (push a stack)) stack) + '(3 2 1)) + + +(equal (let (stack) (loop for a to 3 by 1 do (push a stack)) stack) '(3 2 1 0)) +(equal (let (stack) (loop for a by 1 to 3 do (push a stack)) stack) '(3 2 1 0)) + +(equal (let (stack) (loop for a upto 3 by 1 do (push a stack)) stack) '(3 2 1 0)) +(equal (let (stack) (loop for a by 1 upto 3 do (push a stack)) stack) '(3 2 1 0)) + +(equal (let (stack) (loop for a below 4 by 1 do (push a stack)) stack) + '(3 2 1 0)) +(equal (let (stack) (loop for a by 1 below 4 do (push a stack)) stack) + '(3 2 1 0)) + + +(= 4 (let ((stack '(1 2 3))) + (loop for a from 1 by 1 do (unless (pop stack) (return a))))) +(= 4 (let ((stack '(1 2 3))) + (loop for a by 1 from 1 do (unless (pop stack) (return a))))) + +(= 4 (let ((stack '(1 2 3))) + (loop for a upfrom 1 by 1 do (unless (pop stack) (return a))))) +(= 4 (let ((stack '(1 2 3))) + (loop for a by 1 upfrom 1 do (unless (pop stack) (return a))))) + + +;; for-as-arithmetic-up with 1 form +(= 4 (let ((stack '(1 2 3))) + (loop for a from 1 do (unless (pop stack) (return a))))) +(= 4 (let ((stack '(1 2 3))) + (loop for a upfrom 1 do (unless (pop stack) (return a))))) + +(equal (let (stack) (loop for a to 3 do (push a stack)) stack) + '(3 2 1 0)) +(equal (let (stack) (loop for a upto 3 do (push a stack)) stack) + '(3 2 1 0)) +(equal (let (stack) (loop for a below 4 do (push a stack)) stack) + '(3 2 1 0)) + +(= 3 (let ((stack '(1 2 3))) + (loop for a by 1 do (unless (pop stack) (return a))))) + + +;; for-as-arithmetic-downto with 3 forms +(equal (let (stack) (loop for a from 3 downto 1 by 1 do (push a stack)) stack) + '(1 2 3)) +(equal (let (stack) (loop for a from 3 by 1 downto 1 do (push a stack)) stack) + '(1 2 3)) +(equal (let (stack) (loop for a downto 1 by 1 from 3 do (push a stack)) stack) + '(1 2 3)) +(equal (let (stack) (loop for a downto 1 from 3 by 1 do (push a stack)) stack) + '(1 2 3)) +(equal (let (stack) (loop for a by 1 from 3 downto 1 do (push a stack)) stack) + '(1 2 3)) +(equal (let (stack) (loop for a by 1 downto 1 from 3 do (push a stack)) stack) + '(1 2 3)) + +(equal (let (stack) (loop for a from 3 above 0 by 1 do (push a stack)) stack) + '(1 2 3)) +(equal (let (stack) (loop for a from 3 by 1 above 0 do (push a stack)) stack) + '(1 2 3)) +(equal (let (stack) (loop for a above 0 by 1 from 3 do (push a stack)) stack) + '(1 2 3)) +(equal (let (stack) (loop for a above 0 from 3 by 1 do (push a stack)) stack) + '(1 2 3)) +(equal (let (stack) (loop for a by 1 from 3 above 0 do (push a stack)) stack) + '(1 2 3)) +(equal (let (stack) (loop for a by 1 above 0 from 3 do (push a stack)) stack) + '(1 2 3)) + + +;; for-as-arithmetic-downto with 2 forms +(equal (let (stack) (loop for a from 3 downto 1 do (push a stack)) stack) + '(1 2 3)) +(equal (let (stack) (loop for a downto 1 from 3 do (push a stack)) stack) + '(1 2 3)) + +(equal (let (stack) (loop for a from 3 above 0 do (push a stack)) stack) + '(1 2 3)) +(equal (let (stack) (loop for a above 0 from 3 do (push a stack)) stack) + '(1 2 3)) + + +;; for-as-arithmetic-downfrom with 3 forms +(equal (let (stack) (loop for a downfrom 3 to 1 by 1 do (push a stack)) stack) + '(1 2 3)) +(equal (let (stack) (loop for a downfrom 3 by 1 to 1 do (push a stack)) stack) + '(1 2 3)) + +(equal (let (stack) (loop for a to 1 by 1 downfrom 3 do (push a stack)) stack) + '(1 2 3)) +(equal (let (stack) (loop for a to 1 downfrom 3 by 1 do (push a stack)) stack) + '(1 2 3)) + +(equal (let (stack) (loop for a by 1 to 1 downfrom 3 do (push a stack)) stack) + '(1 2 3)) +(equal (let (stack) (loop for a by 1 downfrom 3 to 1 do (push a stack)) stack) + '(1 2 3)) + + +(equal (let (stack) (loop for a downfrom 3 downto 1 by 1 do (push a stack)) + stack) + '(1 2 3)) +(equal (let (stack) (loop for a downfrom 3 by 1 downto 1 do (push a stack)) + stack) + '(1 2 3)) + +(equal (let (stack) (loop for a downto 1 by 1 downfrom 3 do (push a stack)) + stack) + '(1 2 3)) +(equal (let (stack) (loop for a downto 1 downfrom 3 by 1 do (push a stack)) + stack) + '(1 2 3)) + +(equal (let (stack) (loop for a by 1 downto 1 downfrom 3 do (push a stack)) + stack) + '(1 2 3)) +(equal (let (stack) (loop for a by 1 downfrom 3 downto 1 do (push a stack)) + stack) + '(1 2 3)) + + +(equal (let (stack) (loop for a downfrom 3 above 0 by 1 do (push a stack)) + stack) + '(1 2 3)) +(equal (let (stack) (loop for a downfrom 3 by 1 above 0 do (push a stack)) + stack) + '(1 2 3)) + +(equal (let (stack) (loop for a above 0 by 1 downfrom 3 do (push a stack)) + stack) + '(1 2 3)) +(equal (let (stack) (loop for a above 0 downfrom 3 by 1 do (push a stack)) + stack) + '(1 2 3)) + +(equal (let (stack) (loop for a by 1 above 0 downfrom 3 do (push a stack)) + stack) + '(1 2 3)) +(equal (let (stack) (loop for a by 1 downfrom 3 above 0 do (push a stack)) + stack) + '(1 2 3)) + + +;; for-as-arithmetic-downfrom with 2 forms +(equal (let (stack) (loop for a downfrom 3 to 1 do (push a stack)) stack) + '(1 2 3)) +(equal (let (stack) (loop for a to 1 downfrom 3 do (push a stack)) stack) + '(1 2 3)) + +(equal (let (stack) (loop for a downfrom 3 downto 1 do (push a stack)) stack) + '(1 2 3)) +(equal (let (stack) (loop for a downto 1 downfrom 3 do (push a stack)) stack) + '(1 2 3)) + +(equal (let (stack) (loop for a downfrom 3 above 0 do (push a stack)) stack) + '(1 2 3)) +(equal (let (stack) (loop for a above 0 downfrom 3 do (push a stack)) stack) + '(1 2 3)) + + +(zerop (let ((stack '(0 1 2))) + (loop for a downfrom 3 by 1 do (unless (pop stack) (return a))))) +(zerop (let ((stack '(0 1 2))) + (loop for a by 1 downfrom 3 do (unless (pop stack) (return a))))) + +;; for-as-arithmetic-downfrom with 1 form +(zerop (let ((stack '(0 1 2))) + (loop for a downfrom 3 do (unless (pop stack) (return a))))) + +;; for-as-arithmetic form evaluation +(equal (let (stack) + (loop for a from (+ 1 1) upto (+ 4 6) by (1+ 1) do (push a stack)) + stack) + '(10 8 6 4 2)) + +;; for-as-arithmetic form evaluation order +(equal (let ((x 0) + stack) + (loop for a from (incf x) upto (+ (incf x) 10) by x do (push a stack)) + stack) + '(11 9 7 5 3 1)) + +(equal (let ((x 0) + stack) + (loop for a from (incf x) by (incf x) upto (+ x 10) do (push a stack)) + stack) + '(11 9 7 5 3 1)) + +(equal (let ((x 0) + stack) + (loop for a by (incf x) from (incf x) upto (+ x 10) do (push a stack)) + stack) + '(12 11 10 9 8 7 6 5 4 3 2)) + +(equal (let ((x 0) + stack) + (loop for a by (incf x) upto (+ (incf x) 10) from (incf x) + do (push a stack)) + stack) + '(12 11 10 9 8 7 6 5 4 3)) + +;; for-as-arithmetic type +(equal (let (stack) (loop for a t from 1 to 3 by 1 do (push a stack)) stack) + '(3 2 1)) + +(equal (let (stack) (loop for a fixnum from 1 to 3 by 1 do (push a stack)) stack) + '(3 2 1)) + +(equal (let (stack) (loop for a float from 1.0 to 3.0 by 1.0 do (push a stack)) + stack) + '(3.0 2.0 1.0)) + + +(equal (let (stack) (loop for a of-type t from 1 to 3 by 1 do (push a stack)) + stack) + '(3 2 1)) + +(equal (let (stack) + (loop for a of-type fixnum from 1 to 3 by 1 do (push a stack)) stack) + '(3 2 1)) + +(equal (let (stack) + (loop for a of-type float from 1.0 to 3.0 by 1.0 do (push a stack)) + stack) + '(3.0 2.0 1.0)) + +(equal (let (stack) + (loop for a of-type number from 1 to 3 by 1 do (push a stack)) stack) + '(3 2 1)) + +(equal (let (stack) + (loop for a of-type integer from 1 to 3 by 1 do (push a stack)) stack) + '(3 2 1)) + + + + +;; for-as-arithmetic misc +(equal (let ((stack)) (loop for a from 0 upto 10 by 5 do (push a stack)) stack) + '(10 5 0)) + +(equal (let ((stack)) (loop for a from 0 upto 10 by 3 do (push a stack)) stack) + '(9 6 3 0)) + +(equal (let ((stack)) (loop for a from -3 upto 0 do (push a stack)) stack) + '(0 -1 -2 -3)) + +(equal (let ((stack)) (loop for a downfrom 0 to -3 do (push a stack)) stack) + '(-3 -2 -1 0)) +(equal (let (stack) (loop as a from 1 to 3 by 1 do (push a stack)) stack) + '(3 2 1)) +(equal (let (stack) (loop as a upfrom 1 to 3 by 1 do (push a stack)) stack) + '(3 2 1)) +(equal (let (stack) (loop as a from 1 upto 3 by 1 do (push a stack)) stack) + '(3 2 1)) +(equal (let (stack) (loop as a upfrom 1 upto 3 by 1 do (push a stack)) stack) + '(3 2 1)) +(equal (let (stack) (loop as a from 1 below 4 by 1 do (push a stack)) stack) + '(3 2 1)) +(equal (let (stack) (loop as a upfrom 1 below 4 by 1 do (push a stack)) stack) + '(3 2 1)) +(equal (let (stack) (loop as a from 1 to 3 do (push a stack)) stack) '(3 2 1)) +(equal (let (stack) (loop as a upfrom 1 to 3 do (push a stack)) stack) '(3 2 1)) +(equal (let (stack) (loop as a from 1 upto 3 do (push a stack)) stack) '(3 2 1)) +(equal (let (stack) (loop as a upfrom 1 upto 3 do (push a stack)) stack) + '(3 2 1)) +(equal (let (stack) (loop as a from 1 below 4 do (push a stack)) stack) '(3 2 1)) +(equal (let (stack) (loop as a upfrom 1 below 4 do (push a stack)) stack) + '(3 2 1)) +(equal (let (stack) (loop as a to 3 by 1 do (push a stack)) stack) '(3 2 1 0)) +(equal (let (stack) (loop as a upto 3 by 1 do (push a stack)) stack) '(3 2 1 0)) +(equal (let (stack) (loop as a below 4 by 1 do (push a stack)) stack) + '(3 2 1 0)) +(= 4 (let ((stack '(1 2 3))) + (loop as a from 1 by 1 do (unless (pop stack) (return a))))) +(= 4 (let ((stack '(1 2 3))) + (loop as a upfrom 1 by 1 do (unless (pop stack) (return a))))) +(= 4 (let ((stack '(1 2 3))) + (loop as a from 1 do (unless (pop stack) (return a))))) +(equal (let (stack) (loop as a to 3 do (push a stack)) stack) '(3 2 1 0)) +(= 3 (let ((stack '(1 2 3))) + (loop as a by 1 do (unless (pop stack) (return a))))) +(equal (let (stack) (loop as a from 3 downto 1 by 1 do (push a stack)) stack) + '(1 2 3)) +(equal (let (stack) (loop as a from 3 above 0 by 1 do (push a stack)) stack) + '(1 2 3)) +(equal (let (stack) (loop as a from 3 downto 1 do (push a stack)) stack) + '(1 2 3)) +(equal (let (stack) (loop as a from 3 above 0 do (push a stack)) stack) + '(1 2 3)) +(equal (let (stack) (loop as a downfrom 3 to 1 by 1 do (push a stack)) stack) + '(1 2 3)) +(equal (let (stack) (loop as a to 1 by 1 downfrom 3 do (push a stack)) stack) + '(1 2 3)) +(equal (let (stack) (loop as a by 1 to 1 downfrom 3 do (push a stack)) stack) + '(1 2 3)) +(equal (let (stack) (loop as a downfrom 3 downto 1 by 1 do (push a stack)) + stack) + '(1 2 3)) +(equal (let (stack) (loop as a downto 1 by 1 downfrom 3 do (push a stack)) + stack) + '(1 2 3)) +(equal (let (stack) (loop as a by 1 downto 1 downfrom 3 do (push a stack)) + stack) + '(1 2 3)) +(equal (let (stack) (loop as a downfrom 3 above 0 by 1 do (push a stack)) + stack) + '(1 2 3)) +(equal (let (stack) (loop as a above 0 by 1 downfrom 3 do (push a stack)) + stack) + '(1 2 3)) +(equal (let (stack) (loop as a by 1 above 0 downfrom 3 do (push a stack)) + stack) + '(1 2 3)) +(equal (let (stack) (loop as a downfrom 3 to 1 do (push a stack)) stack) + '(1 2 3)) +(equal (let (stack) (loop as a downfrom 3 downto 1 do (push a stack)) stack) + '(1 2 3)) +(equal (let (stack) (loop as a downfrom 3 above 0 do (push a stack)) stack) + '(1 2 3)) +(zerop (let ((stack '(0 1 2))) + (loop as a downfrom 3 by 1 do (unless (pop stack) (return a))))) +(zerop (let ((stack '(0 1 2))) + (loop as a downfrom 3 do (unless (pop stack) (return a))))) +(equal (let (stack) (loop for a from 0 upto 0 do (push a stack)) stack) '(0)) +(null (loop for a upfrom 0 below 0)) +(null (loop for a upfrom 10 to -10 collect a)) +(equal (let (stack) + (loop for a from 1/3 upto 1 by 1/3 do (push a stack)) + stack) + '(1 2/3 1/3)) +(equal (let (stack) + (loop for a of-type rational from 1/3 upto 5/3 by 1/3 do (push a stack)) + stack) + '(5/3 4/3 1 2/3 1/3)) +(equal (let(stack) (loop for a fixnum below 3 do (push a stack)) stack) + '(2 1 0)) +(equal (let(stack) (loop for a of-type fixnum below 3 do (push a stack)) stack) + '(2 1 0)) +(equal (let(stack) (loop for a of-type (integer 0 2) + below 3 do (push a stack)) stack) + '(2 1 0)) + + +;; for-as-in-list +(null (loop for a in '())) +(equal (let (stack) (loop for a in '(0 1 2) do (push a stack)) stack) + '(2 1 0)) +(equal (let (stack) + (loop for a in (let ((i 0)) (list (incf i) (incf i) (incf i))) + do (push a stack)) + stack) + '(3 2 1)) +(handler-case (loop for a in '(0 1 . 2)) + (type-error () + t) + (error () nil) + (:no-error (&rest rest) + (declare (ignore rest)) + nil)) ; check must be done by endp +(equal (let (stack) + (loop for a in '(0 1 2 3) by #'cdr do (push a stack)) + stack) + '(3 2 1 0)) +(equal (let (stack) + (loop for a in '(0 1 2 3) by #'cddr do (push a stack)) + stack) + '(2 0)) +(equal (let (stack) + (loop for a in '(0 1 2 3) by #'cdddr do (push a stack)) + stack) + '(3 0)) +(equal (let (stack) + (loop for a in '(0 1 2 3) by #'cddddr do (push a stack)) + stack) + '(0)) +(equal (let (stack) (loop for a t in '(0 1 2) do (push a stack)) stack) '(2 1 0)) +(equal (let (stack) (loop for a of-type t in '(0 1 2) do (push a stack)) stack) + '(2 1 0)) +(equal (let (stack) (loop for a fixnum in '(0 1 2) do (push a stack)) + stack) '(2 1 0)) +(equal (let (stack) (loop for a of-type fixnum in '(0 1 2) do (push a stack)) + stack) '(2 1 0)) +(equal (let (stack) (loop for a of-type t in '(0 1 2) do (push a stack)) + stack) '(2 1 0)) +(equal (let (stack) (loop for a float in '(0.0 1.0 2.0) do (push a stack)) + stack) '(2.0 1.0 0.0)) +(equal (let (stack) (loop for a of-type float in '(0.0 1.0 2.0) + do (push a stack)) + stack) '(2.0 1.0 0.0)) + + + + + +;; for-as-on-list +(null (loop for a on '())) +(equal (let (stack) (loop for a on '(0 1 2) do (push a stack)) stack) + '((2) (1 2) (0 1 2))) +(equal (let (stack) + (loop for a on (let ((i 0)) (list (incf i) (incf i) (incf i))) + do (push (car a) stack)) + stack) + '(3 2 1)) +(equal (let (stack) (loop for a on '(0 1 . 2) do (push a stack)) stack) + '((1 . 2) (0 1 . 2))) ; check must be done by atom +(equal (let (stack) + (loop for a on '(0 1 2 3) by #'cdr do (push a stack)) + stack) + '((3) (2 3) (1 2 3) (0 1 2 3))) +(equal (let (stack) + (loop for a on '(0 1 2 3) by #'cddr do (push a stack)) + stack) + '((2 3) (0 1 2 3))) +(equal (let (stack) + (loop for a on '(0 1 2 3) by #'cdddr do (push a stack)) + stack) + '((3) (0 1 2 3))) +(equal (let (stack) + (loop for a on '(0 1 2 3) by #'cddddr do (push a stack)) + stack) + '((0 1 2 3))) +(equal (let (stack) (loop for a t on '(0 1 2) do (push a stack)) stack) + '((2) (1 2) (0 1 2))) +(equal (let (stack) (loop for a of-type t on '(0 1 2) do (push a stack)) stack) + '((2) (1 2) (0 1 2))) +(equal (let (stack) (loop for a of-type list on '(0 1 2) do (push a stack)) + stack) + '((2) (1 2) (0 1 2))) + +(equal (let (stack) + (loop for a on '(0 1 2 3) by #'(lambda (arg) (cddddr arg)) + do (push a stack)) + stack) + '((0 1 2 3))) + + +;; for-as-across +(null (loop for a across "")) +(null (let (stack) (loop for a across "" do (push a stack)) stack)) +(equal (let (stack) (loop for a across "abc" do (push a stack)) stack) + '(#\c #\b #\a)) +(equal (let (stack) (loop for a across #(x y z) do (push a stack)) stack) + '(z y x)) +(equal (let (stack) (loop for a across #*0101 do (push a stack)) stack) + '(1 0 1 0)) +(equal (let (stack) (loop for a t across "abc" do (push a stack)) stack) + '(#\c #\b #\a)) +(equal (let (stack) (loop for a of-type t across "abc" do (push a stack)) stack) + '(#\c #\b #\a)) +(equal (let (stack) (loop for a of-type character across "abc" + do (push a stack)) stack) + '(#\c #\b #\a)) +(equal (let (stack) (loop for a of-type base-char across "abc" + do (push a stack)) stack) + '(#\c #\b #\a)) +(equal (let (stack) (loop for a float across #(0.0 1.0 2.0) + do (push a stack)) stack) + '(2.0 1.0 0.0)) +(equal (let (stack) (loop for a of-type float across #(0.0 1.0 2.0) + do (push a stack)) stack) + '(2.0 1.0 0.0)) +(equal (let (stack) (loop for a fixnum across #(0 1 2) + do (push a stack)) stack) + '(2 1 0)) +(equal (let (stack) (loop for a of-type fixnum across #(0 1 2) + do (push a stack)) stack) + '(2 1 0)) + + + + + + +;; for-as-equals-then +(= (let ((i 3)) (loop for a = 0 then (1+ a) + do (when (zerop (decf i)) (return a)))) + 2) +(equal (let (stack) (loop for a = '(0 1 2) then (cdr a) + do (if a (push (car a) stack) (return stack)))) + '(2 1 0)) +(equal (let (stack) (loop with i = 0 for x = i + do (when (= i 3) (return)) + (push x stack) (incf i)) stack) + '(2 1 0)) +(equal (let (stack) + (loop for i = 0 then (1+ i) do (push i stack) when (= i 3) return t) + stack) + '(3 2 1 0)) +(equal (let (stack) + (loop for i fixnum = 0 then (1+ i) do (push i stack) + when (= i 3) return t) + stack) + '(3 2 1 0)) +(equal (let (stack) + (loop for i of-type fixnum = 0 then (1+ i) do (push i stack) + when (= i 3) return t) + stack) + '(3 2 1 0)) +(equal (let (stack) + (loop for i float = 0.0 then (1+ i) do (push i stack) + when (= i 3.0) return t) + stack) + '(3.0 2.0 1.0 0.0)) +(equal (let (stack) + (loop for i of-type float = 0.0 then (1+ i) do (push i stack) + when (= i 3.0) return t) + stack) + '(3.0 2.0 1.0 0.0)) +(equal (let (stack) + (loop for i t = 0.0 then (1+ i) do (push i stack) + when (= i 3.0) return t) + stack) + '(3.0 2.0 1.0 0.0)) +(equal (let (stack) + (loop for i of-type t = 0.0 then (1+ i) do (push i stack) + when (= i 3.0) return t) + stack) + '(3.0 2.0 1.0 0.0)) +(let ((chars '(#\a #\b #\c #\d))) + (eq t (loop for c = (pop chars) unless chars return t))) +(let ((chars '(#\a #\b #\c #\d))) + (eq t (loop for c of-type character = (pop chars) unless chars return t))) +(let ((chars '(#\a #\b #\c #\d))) + (eq t (loop for c of-type base-char = (pop chars) unless chars return t))) +(equal (let (stack) + (loop for i of-type (integer 0 3) = 0 then (1+ i) do (push i stack) + when (= i 3) return t) + stack) + '(3 2 1 0)) + +(flet ((triple (n) (values n (+ n 1) (+ n 2)))) + (equal (loop for i from 0 upto 2 + for (a b c) = (multiple-value-list (triple i)) + append `(,a ,b ,c)) + '(0 1 2 1 2 3 2 3 4))) +(flet ((triple (n) (values n `(,(+ n 1)) `((,(+ n 2)))))) + (equal (loop for i from 0 upto 2 + for (a (b) ((c))) = (multiple-value-list (triple i)) + append `(,a ,b ,c)) + '(0 1 2 1 2 3 2 3 4))) +(flet ((triple (n) (values n + `(,(+ n 10) ,(+ n 11) ,(+ n 12) ,(+ n 13)) + `(,(+ n 20) ,(+ n 21) ,(+ n 22))))) + (equal (loop for i from 0 upto 2 + for (a (b0 b1 b2 b3) (c0 c1 c2)) = (multiple-value-list (triple i)) + append `(,a ,b0 ,b1 ,b2 ,b3 ,c0 ,c1 ,c2)) + '(0 10 11 12 13 20 21 22 1 11 12 13 14 21 22 23 2 12 13 14 15 22 23 24))) + +(flet ((triple (n) (values n + `(,(+ n 10) ,(+ n 11) ,(+ n 12) ,(+ n 13)) + `(,(+ n 200) + (,(+ n 210) ,(+ n 211) ,(+ n 212) ,(+ n 213)) + ,(+ n 220))))) + (equal (loop for i from 0 upto 2 + for (a (b0 b1 b2 b3) (c0 (c10 c11 c12) c2)) = + (multiple-value-list (triple i)) + append `(,a ,b0 ,b1 ,b2 ,b3 ,c0 ,c10 ,c11 ,c12 ,c2)) + '(0 10 11 12 13 200 210 211 212 220 + 1 11 12 13 14 201 211 212 213 221 + 2 12 13 14 15 202 212 213 214 222))) + + + + + + + +;; for-as-hash +(let ((table (make-hash-table)) + stack) + (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2)) + (loop for k being each hash-key of table do (push k stack)) + (null (set-difference stack '(k0 k1 k2)))) +(let ((table (make-hash-table)) + stack) + (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2)) + (loop for k being the hash-key of table do (push k stack)) + (null (set-difference stack '(k0 k1 k2)))) +(let ((table (make-hash-table)) + stack) + (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2)) + (loop for k being each hash-keys of table do (push k stack)) + (null (set-difference stack '(k0 k1 k2)))) +(let ((table (make-hash-table)) + stack) + (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2)) + (loop for k being the hash-keys of table do (push k stack)) + (null (set-difference stack '(k0 k1 k2)))) + +(let ((table (make-hash-table)) + stack) + (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2)) + (loop for k being each hash-key in table do (push k stack)) + (null (set-difference stack '(k0 k1 k2)))) +(let ((table (make-hash-table)) + stack) + (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2)) + (loop for k being the hash-key in table do (push k stack)) + (null (set-difference stack '(k0 k1 k2)))) +(let ((table (make-hash-table)) + stack) + (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2)) + (loop for k being each hash-keys in table do (push k stack)) + (null (set-difference stack '(k0 k1 k2)))) +(let ((table (make-hash-table)) + stack) + (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2)) + (loop for k being the hash-keys in table do (push k stack)) + (null (set-difference stack '(k0 k1 k2)))) + +(let ((table (make-hash-table)) + stack) + (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2)) + (loop for k being each hash-key of table using (hash-value v) + do (push (list k v) stack)) + (null (set-difference stack '((k0 v0) (k1 v1) (k2 v2)) :test #'equal))) +(let ((table (make-hash-table)) + stack) + (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2)) + (loop for k being the hash-key of table using (hash-value v) + do (push (list k v) stack)) + (null (set-difference stack '((k0 v0) (k1 v1) (k2 v2)) :test #'equal))) +(let ((table (make-hash-table)) + stack) + (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2)) + (loop for k being each hash-keys of table using (hash-value v) + do (push (list k v) stack)) + (null (set-difference stack '((k0 v0) (k1 v1) (k2 v2)) :test #'equal))) +(let ((table (make-hash-table)) + stack) + (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2)) + (loop for k being the hash-keys of table using (hash-value v) + do (push (list k v) stack)) + (null (set-difference stack '((k0 v0) (k1 v1) (k2 v2)) :test #'equal))) +(let ((table (make-hash-table)) + stack) + (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2)) + (loop for k being each hash-key in table using (hash-value v) + do (push (list k v) stack)) + (null (set-difference stack '((k0 v0) (k1 v1) (k2 v2)) :test #'equal))) +(let ((table (make-hash-table)) + stack) + (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2)) + (loop for k being the hash-key in table using (hash-value v) + do (push (list k v) stack)) + (null (set-difference stack '((k0 v0) (k1 v1) (k2 v2)) :test #'equal))) +(let ((table (make-hash-table)) + stack) + (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2)) + (loop for k being each hash-keys in table using (hash-value v) + do (push (list k v) stack)) + (null (set-difference stack '((k0 v0) (k1 v1) (k2 v2)) :test #'equal))) +(let ((table (make-hash-table)) + stack) + (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2)) + (loop for k being the hash-keys in table using (hash-value v) + do (push (list k v) stack)) + (null (set-difference stack '((k0 v0) (k1 v1) (k2 v2)) :test #'equal))) + + + +(let ((table (make-hash-table)) + stack) + (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2)) + (loop for v being each hash-value of table do (push v stack)) + (null (set-exclusive-or stack '(v0 v1 v2)))) +(let ((table (make-hash-table)) + stack) + (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2)) + (loop for v being the hash-value of table do (push v stack)) + (null (set-exclusive-or stack '(v0 v1 v2)))) +(let ((table (make-hash-table)) + stack) + (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2)) + (loop for v being each hash-values of table do (push v stack)) + (null (set-exclusive-or stack '(v0 v1 v2)))) +(let ((table (make-hash-table)) + stack) + (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2)) + (loop for v being the hash-values of table do (push v stack)) + (null (set-exclusive-or stack '(v0 v1 v2)))) +(let ((table (make-hash-table)) + stack) + (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2)) + (loop for v being each hash-value in table do (push v stack)) + (null (set-exclusive-or stack '(v0 v1 v2)))) +(let ((table (make-hash-table)) + stack) + (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2)) + (loop for v being the hash-value in table do (push v stack)) + (null (set-exclusive-or stack '(v0 v1 v2)))) +(let ((table (make-hash-table)) + stack) + (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2)) + (loop for v being each hash-values in table do (push v stack)) + (null (set-exclusive-or stack '(v0 v1 v2)))) +(let ((table (make-hash-table)) + stack) + (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2)) + (loop for v being the hash-values in table do (push v stack)) + (null (set-exclusive-or stack '(v0 v1 v2)))) + +(let ((table (make-hash-table)) + stack) + (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2)) + (loop for v being each hash-value of table using (hash-key k) + do (push (list k v) stack)) + (null (set-exclusive-or stack '((k0 v0) (k1 v1) (k2 v2)) :test #'equal))) +(let ((table (make-hash-table)) + stack) + (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2)) + (loop for v being the hash-value of table using (hash-key k) + do (push (list k v) stack)) + (null (set-exclusive-or stack '((k0 v0) (k1 v1) (k2 v2)) :test #'equal))) +(let ((table (make-hash-table)) + stack) + (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2)) + (loop for v being each hash-values of table using (hash-key k) + do (push (list k v) stack)) + (null (set-exclusive-or stack '((k0 v0) (k1 v1) (k2 v2)) :test #'equal))) +(let ((table (make-hash-table)) + stack) + (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2)) + (loop for v being the hash-values of table using (hash-key k) + do (push (list k v) stack)) + (null (set-exclusive-or stack '((k0 v0) (k1 v1) (k2 v2)) :test #'equal))) +(let ((table (make-hash-table)) + stack) + (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2)) + (loop for v being each hash-value in table using (hash-key k) + do (push (list k v) stack)) + (null (set-exclusive-or stack '((k0 v0) (k1 v1) (k2 v2)) :test #'equal))) +(let ((table (make-hash-table)) + stack) + (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2)) + (loop for v being the hash-value in table using (hash-key k) + do (push (list k v) stack)) + (null (set-exclusive-or stack '((k0 v0) (k1 v1) (k2 v2)) :test #'equal))) +(let ((table (make-hash-table)) + stack) + (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2)) + (loop for v being each hash-values in table using (hash-key k) + do (push (list k v) stack)) + (null (set-exclusive-or stack '((k0 v0) (k1 v1) (k2 v2)) :test #'equal))) +(let ((table (make-hash-table)) + stack) + (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2)) + (loop for v being the hash-values in table using (hash-key k) + do (push (list k v) stack)) + (null (set-exclusive-or stack '((k0 v0) (k1 v1) (k2 v2)) :test #'equal))) + +(let ((table (make-hash-table :test 'equal)) + stack) + (mapc #'(lambda (k v) (setf (gethash k table) v)) + '((k0 k00) (k1 k11) (k2 k22)) '((v0 v00) (v1 v11) (v2 v22))) + (loop for (k kk) being each hash-key of table do (push (list k kk) stack)) + (null (set-exclusive-or stack '((k0 k00) (k1 k11) (k2 k22)) :test #'equal))) + +(let ((table (make-hash-table :test 'equal)) + stack) + (mapc #'(lambda (k v) (setf (gethash k table) v)) + '((k0 k00) (k1 k11) (k2 k22)) '((v0 v00) (v1 v11) (v2 v22))) + (loop :for (k kk) :being :each :hash-key :of table :using (hash-value (v vv)) + do (push (list k kk v vv) stack)) + (null (set-exclusive-or stack + '((k0 k00 v0 v00) (k1 k11 v1 v11) (k2 k22 v2 v22)) + :test #'equal))) + +(let ((table (make-hash-table :test 'equal)) + stack) + (mapc #'(lambda (k v) (setf (gethash k table) v)) + '((k0 k00) (k1 k11) (k2 k22)) '((v0 v00) (v1 v11) (v2 v22))) + (loop :for (v vv) :being :each :hash-value :of table :using (hash-key (k kk)) + do (push (list k kk v vv) stack)) + (null (set-exclusive-or stack + '((k0 k00 v0 v00) (k1 k11 v1 v11) (k2 k22 v2 v22)) + :test #'equal))) + +(let ((table (make-hash-table)) + stack) + (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2)) + (loop for k of-type symbol being each hash-key of table do (push k stack)) + (null (set-exclusive-or stack '(k0 k1 k2)))) + +(let ((table (make-hash-table :test 'equal)) + stack) + (mapc #'(lambda (k v) (setf (gethash k table) v)) + '((k0 k00) (k1 k11) (k2 k22)) '((v0 v00) (v1 v11) (v2 v22))) + (loop for (k kk) of-type symbol being each hash-key of table + do (push (list k kk) stack)) + (null (set-exclusive-or stack '((k0 k00) (k1 k11) (k2 k22)) :test #'equal))) + +(let ((table (make-hash-table :test 'equal)) + stack) + (mapc #'(lambda (k v) (setf (gethash k table) v)) + '((k0 k00) (k1 k11) (k2 k22)) '((v0 v00) (v1 v11) (v2 v22))) + (loop for (k kk) of-type (symbol symbol) being each hash-key of table + do (push (list k kk) stack)) + (null (set-exclusive-or stack '((k0 k00) (k1 k11) (k2 k22)) :test #'equal))) + +(let ((table (make-hash-table)) + stack) + (mapc #'(lambda (k v) (setf (gethash k table) v)) '(0 1 2) '(v0 v1 v2)) + (loop for k fixnum being each hash-key of table do (push k stack)) + (null (set-exclusive-or stack '(0 1 2)))) +(let ((table (make-hash-table)) + stack) + (mapc #'(lambda (k v) (setf (gethash k table) v)) '(0 1 2) '(v0 v1 v2)) + (loop for k of-type fixnum being each hash-key of table do (push k stack)) + (null (set-exclusive-or stack '(0 1 2)))) +(let ((table (make-hash-table)) + stack) + (mapc #'(lambda (k v) (setf (gethash k table) v)) '(0.0 1.0 2.0) '(v0 v1 v2)) + (loop for k float being each hash-key of table do (push k stack)) + (null (set-exclusive-or stack '(0.0 1.0 2.0)))) +(let ((table (make-hash-table)) + stack) + (mapc #'(lambda (k v) (setf (gethash k table) v)) '(0.0 1.0 2.0) '(v0 v1 v2)) + (loop for k of-type float being each hash-key of table do (push k stack)) + (null (set-exclusive-or stack '(0.0 1.0 2.0)))) +(let ((table (make-hash-table)) + stack) + (mapc #'(lambda (k v) (setf (gethash k table) v)) '(0.0 1.0 2.0) '(v0 v1 v2)) + (loop for k t being each hash-key of table do (push k stack)) + (null (set-exclusive-or stack '(0.0 1.0 2.0)))) +(let ((table (make-hash-table)) + stack) + (mapc #'(lambda (k v) (setf (gethash k table) v)) '(0.0 1.0 2.0) '(v0 v1 v2)) + (loop for k of-type t being each hash-key of table do (push k stack)) + (null (set-exclusive-or stack '(0.0 1.0 2.0)))) +(let ((table (make-hash-table)) + stack) + (mapc #'(lambda (k v) (setf (gethash k table) v)) '(#\a #\b #\c) '(v0 v1 v2)) + (loop for k of-type character being each hash-key of table do (push k stack)) + (null (set-exclusive-or stack '(#\a #\b #\c)))) +(let ((table (make-hash-table)) + stack) + (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2)) + (loop for v t being each hash-value of table do (push v stack)) + (null (set-exclusive-or stack '(v0 v1 v2)))) +(let ((table (make-hash-table)) + stack) + (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2)) + (loop for v of-type t being each hash-value of table do (push v stack)) + (null (set-exclusive-or stack '(v0 v1 v2)))) +(let ((table (make-hash-table)) + stack) + (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(v0 v1 v2)) + (loop for v of-type symbol being each hash-value of table do (push v stack)) + (null (set-exclusive-or stack '(v0 v1 v2)))) +(let ((table (make-hash-table)) + stack) + (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(0 1 2)) + (loop for v fixnum being each hash-value of table do (push v stack)) + (null (set-exclusive-or stack '(0 1 2)))) +(let ((table (make-hash-table)) + stack) + (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(0 1 2)) + (loop for v of-type (integer 0 2) being each hash-value of table + do (push v stack)) + (null (set-exclusive-or stack '(0 1 2)))) +(let ((table (make-hash-table)) + stack) + (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(0.0 1.0 2.0)) + (loop for v float being each hash-value of table do (push v stack)) + (null (set-exclusive-or stack '(0.0 1.0 2.0)))) +(let ((table (make-hash-table)) + stack) + (mapc #'(lambda (k v) (setf (gethash k table) v)) '(k0 k1 k2) '(#\a #\b #\c)) + (loop for v of-type base-char being each hash-value of table do (push v stack)) + (null (set-exclusive-or stack '(#\a #\b #\c)))) + + + + +;; for-as and preposition +(equal (let (stack) + (loop for a from 1 upto 3 and x = 0 then a + do (push x stack)) + stack) + '(2 1 0)) +(equal (let (stack) + (loop for a from 0 upto 3 + for x = 0 then a + do (push x stack)) + stack) + '(3 2 1 0)) +(equal (let ((i 4) + stack) + (loop for a = 0 then (1+ a) + for b = 0 then a + for c = 0 then b + do (when (zerop (decf i)) (return)) + (push (list a b c) stack)) + stack) + '((2 2 2) (1 1 1) (0 0 0))) +(equal (let ((i 5) + stack) + (loop for a = 0 then (1+ a) and b = 0 then a and c = 0 then b + do (when (zerop (decf i)) (return)) + (push (list a b c) stack)) + stack) + '((3 2 1) (2 1 0) (1 0 0) (0 0 0))) +(equal (let (stack) (loop for a in '(0 1 2 3) for x = a do (push x stack)) stack) + '(3 2 1 0)) +(equal (let (stack) (loop for a in '(0 1 2 3) and x = 100 then a + do (push x stack)) stack) + '(2 1 0 100)) +(equal (let (stack) (loop for a on '(0 1 2 3) for x = (car a) + do (push x stack)) stack) + '(3 2 1 0)) +(equal (let (stack) (loop for a on '(0 1 2 3) and x = 100 then (car a) + do (push x stack)) stack) + '(2 1 0 100)) +(equal (let (stack) (loop for a across #(0 1 2 3) for x = a + do (push x stack)) stack) + '(3 2 1 0)) +(equal (let (stack) (loop for a across #(0 1 2 3) and x = 100 then a + do (push x stack)) stack) + '(2 1 0 100)) +(equal (loop for x from 1 to 10 + for y = nil then x + collect (list x y)) + '((1 NIL) (2 2) (3 3) (4 4) (5 5) (6 6) (7 7) (8 8) (9 9) (10 10))) +(equal (loop for x from 1 to 10 + and y = nil then x + collect (list x y)) + '((1 NIL) (2 1) (3 2) (4 3) (5 4) (6 5) (7 6) (8 7) (9 8) (10 9))) +(= 280 (loop for a upfrom 0 upto 9 + and b downfrom 9 downto 0 + and c from 0 to 9 + and d from 10 above 0 + and e below 10 + and f to 9 + summing (+ a b c d e f))) +(equal (loop for a from 1 upto 9 + as b = 0 then a + as c = -1 then b + as d = -2 then c + as e = -3 then d + as f = -4 then e + collecting (list a b c d e f)) + '((1 0 -1 -2 -3 -4) (2 2 2 2 2 2) (3 3 3 3 3 3) (4 4 4 4 4 4) + (5 5 5 5 5 5) (6 6 6 6 6 6) (7 7 7 7 7 7) (8 8 8 8 8 8) (9 9 9 9 9 9))) +(equal (loop for a from 1 upto 9 + and b = 0 then a + and c = -1 then b + and d = -2 then c + and e = -3 then d + and f = -4 then e + collecting (list a b c d e f)) + '((1 0 -1 -2 -3 -4) (2 1 0 -1 -2 -3) (3 2 1 0 -1 -2) (4 3 2 1 0 -1) + (5 4 3 2 1 0) (6 5 4 3 2 1) (7 6 5 4 3 2) (8 7 6 5 4 3) (9 8 7 6 5 4))) +(equal (loop for a from 1 upto 9 + and b = 0 then a + and c = -1 then b + and d = -2 then c + and e = -3 then d + and f = -4 then e + for i from 9 downto 1 + and j = 8 then i + and k = 7 then j + and l = 6 then k + and m = 5 then l + and n = 4 then m + collecting (list a b c d e f) + collecting (list i j k l m n)) + '((1 0 -1 -2 -3 -4) (9 8 7 6 5 4) (2 1 0 -1 -2 -3) (8 9 8 7 6 5) + (3 2 1 0 -1 -2) + (7 8 9 8 7 6) (4 3 2 1 0 -1) (6 7 8 9 8 7) (5 4 3 2 1 0) (5 6 7 8 9 8) + (6 5 4 3 2 1) (4 5 6 7 8 9) (7 6 5 4 3 2) (3 4 5 6 7 8) (8 7 6 5 4 3) + (2 3 4 5 6 7) (9 8 7 6 5 4) (1 2 3 4 5 6))) + +(let (stack) + (loop for a on (progn (push 1 stack) '(0 1 2)) + and b across (progn (push 2 stack) "abc")) + (equal '(2 1) stack)) + + + +;; ambiguous cases +(equal (let ((a 5)) + (loop for a from 0 upto 5 + and b from a downto 0 + collect (list a b))) + '((0 5) (1 4) (2 3) (3 2) (4 1) (5 0))) +(equal (let ((a :outer)) + (loop for a from 0 upto 5 + and b in (list a) + collect (list a b))) + '((0 :outer))) +(equal (let ((b 0)) + (loop for a from b upto 5 + and b in '(a b c) + collecting (list a b))) + '((0 a) (1 b) (2 c))) + + +;; with-clause +(zerop (loop with x = 0 do (return x))) +(equal (let (stack) + (loop with x = 1 for a from x to 3 by 1 do (push a stack)) stack) + '(3 2 1)) +(equal (loop with a = 1 + with b = (+ a 2) + with c = (+ b 3) + return (list a b c)) + '(1 3 6)) +(equal (loop with a = 1 + and b = 2 + and c = 3 + return (list a b c)) + '(1 2 3)) +(let ((a 5) + (b 10)) + (equal (loop with a = 1 + and b = (+ a 2) + and c = (+ b 3) + return (list a b c)) + '(1 7 13))) +(equal (loop with (a b c) of-type (float integer float) + return (list a b c)) + '(0.0 0 0.0)) +(equal (loop with (a b c) of-type float + return (list a b c)) + '(0.0 0.0 0.0)) +(flet ((triple () (values 0 1 2))) + (equal (loop with (a b c) = (multiple-value-list (triple)) + do (return (list a b c))) + '(0 1 2))) +(flet ((triple () (values 0 '(1) 2))) + (equal (loop with (a (b) c) = (multiple-value-list (triple)) + do (return (list a b c))) + '(0 1 2))) +(flet ((triple () (values 0 '(0 1 2) 2))) + (equal (loop with (a (nil b) c d) = (multiple-value-list (triple)) + do (return (list a b c d))) + '(0 1 2 nil))) + +(flet ((triple () (values 0 1 2))) + (equal (loop with (a b c) fixnum = (multiple-value-list (triple)) + do (return (list a b c))) + '(0 1 2))) +(flet ((triple () (values 0 '(1) 2))) + (equal (loop with (a (b) c) of-type (fixnum (fixnum) fixnum) = + (multiple-value-list (triple)) + do (return (list a b c))) + '(0 1 2))) + + + +;; binding (preferable) +(equal (loop for a from 0 upto 5 + for b from a downto -5 + collect (list a b)) + '((0 0) (1 -1) (2 -2) (3 -3) (4 -4) (5 -5))) +(equal (loop for a from 0 upto 5 + with x = a + collect (list a x)) + '((0 0) (1 0) (2 0) (3 0) (4 0) (5 0))) + + +;; initial-final-clause +(zerop (loop initially (return 0))) +(zerop (loop repeat 2 finally (return 0))) +(= (loop with x = 0 initially (incf x) return x) 1) +(= (loop with x = 0 for a from 0 below 3 + initially (incf x) finally (return (incf x))) + 2) +(= (loop with x = 0 for a from 0 below 3 + initially (incf x) (incf x) finally (return (incf x))) + 3) +(= (loop with x = 0 for a from 0 upto 3 + initially (incf x) finally (incf x) (return (incf x))) + 3) +(= (loop with x = 0 for a from 0 upto 3 + initially (incf x) (incf x) finally (incf x) (return (incf x))) + 4) +(= (loop with x = 0 for a from 0 below 3 + do (incf x) + initially (incf x) (incf x) finally (incf x) (return (incf x))) + 7) + +; #-CLISP +; ;;Bruno: unfounded expectations about the value of for-as iteration +; ;;variables in INITIALLY and FINALLY clauses +; ;;(See http://www.cliki.net/Proposed%20ANSI%20Revisions%20and%20Clarifications +; ;;for a discussion of this spec weakness.) +; (equal (let (val) (loop for a downto 3 from 100 +; for b in '(x y z) and c = 50 then (1+ c) +; initially (setq val (list a b c)) +; finally (setq val (append (list a b c) val))) +; val) +; '(97 z 52 100 x 50)) +(= 33 (loop with x = 2 + initially (setq x (* x 3)) + for i below 3 + initially (setq x (* x 5)) + do (incf x i) + finally (return x))) +(equal (loop with x = nil + repeat 2 + initially (push 'initially0 x) + finally (push 'finally0 x) + initially (push 'initially1 x) + finally (push 'finally1 x) + do (push 'body0 x) + finally (push 'finally2 x) (push 'finally3 x) + finally (return (reverse x)) + initially (push 'initially2 x) (push 'initially3 x) + do (push 'body1 x)) + '(initially0 initially1 initially2 initially3 + body0 body1 body0 body1 + finally0 finally1 finally2 finally3)) + + + +;; do-clause +(equal (loop with i = 3 + with stack = nil + do (when (zerop i) (loop-finish)) + (decf i) + (push i stack) + finally (return stack)) + '(0 1 2)) +(equal (loop with i = 3 + with stack = nil + doing (when (zerop i) (loop-finish)) + (decf i) + (push i stack) + finally (return stack)) + '(0 1 2)) +(= (loop with x = 10 do (return x)) 10) +(= (loop with x = 10 doing (return x)) 10) +(= (loop with x = 0 do (incf x) doing (incf x) (return x)) 2) +(= (loop with x = 0 do (incf x) doing (incf x) do (return x)) 2) +(= (loop with x = 0 do (incf x) (incf x) doing (return x)) 2) +(= (loop with x = 0 do (incf x) (incf x) (incf x) doing (incf x) (return x)) 4) + + + +;; conditional-clauses +(let ((odd 0) + (even 0)) + (and (null (loop for a from 1 upto 10 + if (oddp a) do (incf odd) else do (incf even) end)) + (= 5 odd even))) +(let ((odd+ 0) (even+ 0) (odd- 0) (even- 0)) + (and (null (loop for a from -10 upto 10 + if (oddp a) if (> a 0) do (incf odd+) else do (incf odd-) end + else if (> a 0) do (incf even+) else do (incf even-))) + (= 5 odd+ even+ odd-) + (= even- 6))) +(let ((odd+ 0) (even+ 0) (odd- 0) (even- 0)) + (and (null (loop for a from -10 upto 10 + unless (zerop a) + if (oddp a) + if (> a 0) do (incf odd+) else do (incf odd-) end + else + if (> a 0) do (incf even+) else do (incf even-))) + (= 5 odd+ even+ odd- even-))) +(let ((odd+ 0) (even+ 0) (odd- 0) (even- 0)) + (and (null (loop for a from -10 upto 10 + if (not (zerop a)) + when (oddp a) + unless (< a 0) do (incf odd+) else do (incf odd-) end + else + unless (<= a 0) do (incf even+) else do (incf even-))) + (= 5 odd+ even+ odd- even-))) +(handler-bind ((simple-error #'(lambda (c) (declare (ignore c)) (continue)))) + (eq 'continued + (loop for item in '(1 2 3 a 4 5) + when (not (numberp item)) + return (or (cerror "ignore this error" "non-numeric value: ~s" item) + 'continued)))) +(equal (loop for i in '(1 324 2345 323 2 4 235 252) + when (oddp i) collect i into odd-numbers + else ; I is even. + collect i into even-numbers + finally + (return (list odd-numbers even-numbers))) + '((1 2345 323 235) (324 2 4 252))) +(equal (loop for i in '(1 2 3 4 5 6) + when (and (> i 3) i) + collect it) + '(4 5 6)) +(= 4 (loop for i in '(1 2 3 4 5 6) + when (and (> i 3) i) + return it)) +(equal (let ((list '(0 3.0 apple 4 5 9.8 orange banana))) + (loop for i in list + when (numberp i) + when (floatp i) + collect i into float-numbers + else ; Not (floatp i) + collect i into other-numbers + else ; Not (numberp i) + when (symbolp i) + collect i into symbol-list + else ; Not (symbolp i) + do (error "found a funny value in list ~S, value ~S~%" list i) + finally (return (list float-numbers other-numbers symbol-list)))) + '((3.0 9.8) (0 4 5) (APPLE ORANGE BANANA))) +(equal (loop for i below 5 if (oddp i) collecting i) '(1 3)) +(equal (loop for i below 5 when (oddp i) collecting i) '(1 3)) +(equal (loop for i below 5 + if (oddp i) collecting i else collecting (list i)) + '((0) 1 (2) 3 (4))) +(equal (loop for i below 5 + when (oddp i) collecting i else collecting (list i)) + '((0) 1 (2) 3 (4))) +(equal (loop for i below 5 unless (evenp i) collecting i) '(1 3)) +(equal (loop for i below 5 + unless (evenp i) collecting i else collecting (list i)) + '((0) 1 (2) 3 (4))) + +(equal (loop for i below 5 if (oddp i) collecting i end) '(1 3)) +(equal (loop for i below 5 when (oddp i) collecting i end) '(1 3)) +(equal (loop for i below 5 + if (oddp i) collecting i else collecting (list i) end) + '((0) 1 (2) 3 (4))) +(equal (loop for i below 5 + when (oddp i) collecting i else collecting (list i) end) + '((0) 1 (2) 3 (4))) +(equal (loop for i below 5 unless (evenp i) collecting i end) '(1 3)) +(equal (loop for i below 5 + unless (evenp i) collecting i else collecting (list i) end) + '((0) 1 (2) 3 (4))) + +(equal (loop for (a b) in '((0 0) (0 1)) + if (zerop a) if (zerop b) collect '0-0 else collect '0-1) + '(|0-0| |0-1|)) +(equal (loop for (a b) in '((0 0) (0 1)) + when (zerop a) if (zerop b) collect '0-0 else collect '0-1) + '(|0-0| |0-1|)) +(equal (loop for (a b) in '((0 0) (0 1) (1 0) (1 1)) + if (zerop a) if (= b 1) collect '0-1 end + else collect '1-X) + '(|0-1| |1-X| |1-X|)) +(equal (loop for (a b) in '((0 0) (0 1) (1 0) (1 1)) + when (zerop a) if (= b 1) collect '0-1 end + else collect '1-X) + '(|0-1| |1-X| |1-X|)) +(equal (loop for (a b) in '((0 0) (0 1)) + unless (not (zerop a)) if (zerop b) collect '0-0 else collect '0-1) + '(|0-0| |0-1|)) +(equal (loop for (a b) in '((0 0) (0 1) (1 0) (1 1)) + unless (not (zerop a)) if (= b 1) collect '0-1 end + else collect '1-X) + '(|0-1| |1-X| |1-X|)) + +(equal (loop for (a b c) in '((0 0 0) (0 0 1) + (0 1 0) (0 1 1) + (1 0 0) (1 0 1) + (1 1 0) (1 1 1)) + if (zerop a) + if (zerop b) + if (zerop c) collect 'x0-0-0 else collect 'x0-0-1 + else if (zerop c) collect 'x0-1-0 else collect 'x0-1-1 + else if (zerop b) + if (zerop c) collect 'x1-0-0 else collect 'x1-0-1 + else if (zerop c) collect 'x1-1-0 else collect 'x1-1-1) + '(x0-0-0 x0-0-1 x0-1-0 x0-1-1 x1-0-0 x1-0-1 x1-1-0 x1-1-1)) + +(equal (loop for a below 10 + if (oddp a) collect a into bag and sum a into odd + else collect (list a) into bag and sum a into even + finally (return (list bag odd even))) + '(((0) 1 (2) 3 (4) 5 (6) 7 (8) 9) 25 20)) + +(equal (loop for a below 10 + if (oddp a) + collect a and collect (list a) and collect (list (list a)) + else collect a) + '(0 1 (1) ((1)) 2 3 (3) ((3)) 4 5 (5) ((5)) 6 7 (7) ((7)) 8 9 (9) ((9)))) + +(let ((c0 0) (c1 0)) + (and (equal (loop for a below 10 + when (oddp a) + collect a and do (incf c0) (decf c1) and collect (list a)) + '(1 (1) 3 (3) 5 (5) 7 (7) 9 (9))) + (= c0 5) + (= c1 -5))) + + + + + + +;; return-clause +(zerop (loop return 0)) +(= (loop for a from 0 below 3 when (and (oddp a) a) return it) 1) +(eq (loop for a in '(nil nil ok nil ok2) when a return it) 'ok) +(eq 'ok (loop with a = 'ok if a return it else return it)) +(equal (multiple-value-list (loop return (values 0 1 2))) '(0 1 2)) +(let ((flag nil)) + (and (eq t (loop for a below 3 when (oddp a) return t finally (setq flag t))) + (not flag))) +(equal (loop for a in '(0 1 2 3) and b in '(3 2 1 0) + if (and (oddp a) a) + if (and (evenp b) b) + when (and (= (* a b) 0) (list a b)) return it) + '(3 0)) + + +;;; list-accumulation-clauses + +;; collect +(equal (loop for a from 0 below 3 collect a) '(0 1 2)) +(equal (loop for a from 0 below 3 collecting a) '(0 1 2)) +(equal (loop for a in '(nil 0 nil nil 1 2 nil 3 nil 4) + when a collect it) '(0 1 2 3 4)) +(equal (loop for a in '(nil 0 nil nil 1 2 nil 3 nil 4) + when a collecting it) '(0 1 2 3 4)) +(equal (loop for a in '(nil 0 nil nil 1 2 nil 3 nil 4) + when a collect it into bag + finally (return bag)) + '(0 1 2 3 4)) +(equal (loop for a in '(nil 0 nil nil 1 2 nil 3 nil 4) + when a collecting it into bag + finally (return bag)) + '(0 1 2 3 4)) +(equal (loop for a below 10 + if (oddp a) collect a into odd else collect a into even end + finally (return (list odd even))) + '((1 3 5 7 9) (0 2 4 6 8))) +(equal (loop for a below 3 + for b on '(2 1 0) + collecting a + appending b) + '(0 2 1 0 1 1 0 2 0)) + + + +(= 15 (loop for i of-type fixnum in '(1 2 3 4 5) sum i)) +(= 22.4 (let ((series '(1.2 4.3 5.7))) (loop for v in series sum (* 2.0 v)))) +(equal (loop for a below 10 + if (oddp a) collect a into odd and sum a into sum + finally (return (list odd sum))) + '((1 3 5 7 9) 25)) + +(equal (loop for a below 10 + if (oddp a) collect a into odd and sum a into odd-sum + else collect a into even and sum a into even-sum + end + finally (return (list odd odd-sum even even-sum))) + '((1 3 5 7 9) 25 (0 2 4 6 8) 20)) +(equal (loop for i in '(bird 3 4 turtle (1 . 4) horse cat) + when (symbolp i) collect i) + '(BIRD TURTLE HORSE CAT)) +(equal (loop for i below 3 + for j upto 2 + collecting i + collecting j) + '(0 0 1 1 2 2)) +(equal (loop for a from -10 upto 0 + collecting a) + '(-10 -9 -8 -7 -6 -5 -4 -3 -2 -1 0)) +(null (loop for a from -10 upto 0 + collecting a into list)) ;; not return automatically + + +;; append +(let* ((zero (list 0)) + (one (list 1)) + (two (list 2)) + (list (list zero one two))) + (and (equal (loop for a in list append a) '(0 1 2)) + (equal zero '(0)) + (equal one '(1)) + (equal two '(2)))) +(equal (loop for a in '(nil (1) nil (2)) when a append a) '(1 2)) +(equal (loop for a in '(nil (1) nil (2)) when a appending a) '(1 2)) +(null (loop for a in '(nil (1) nil (2)) when a append a into x)) +(null (loop for a in '(nil (1) nil (2)) when a appending a into x)) +(equal (loop for a in '(nil (1) nil (2)) when a append a into x + finally (return x)) '(1 2)) +(equal (loop for a in '(nil (1) nil (2)) when a appending a into x + finally (return x)) '(1 2)) +(equal (loop for a in '(nil (1) nil (2)) when a append it) '(1 2)) +(equal (loop for a in '(nil (1) nil (2)) when a appending it) '(1 2)) +(equal (loop for a on (list 0 1 2 3 4) when (oddp (car a)) append a) + '(1 2 3 4 3 4)) +(equal (loop for a on (list 0 1 2 3 4) when (oddp (car a)) appending a) + '(1 2 3 4 3 4)) +(equal (loop for x in '((a) (b) ((c))) append x) '(A B (C))) + +;; nconc +(let ((list (list (list 0) (list 1) (list 2) (list 3)))) + (and (equal (loop for a in list nconc a) '(0 1 2 3)) + (equal list '((0 1 2 3) (1 2 3) (2 3) (3))))) +(let ((list (list (list 0) (list 1) (list 2) (list 3)))) + (and (equal (loop for a in list nconcing a) '(0 1 2 3)) + (equal list '((0 1 2 3) (1 2 3) (2 3) (3))))) +(let ((list (list nil (list 0) nil nil (list 1) (list 2) nil (list 3) nil))) + (and (equal (loop for a in list when a nconc it) '(0 1 2 3)) + (equal list '(nil (0 1 2 3) nil nil (1 2 3) (2 3) nil (3) nil)))) +(let ((list (list nil (list 0) nil nil (list 1) (list 2) nil (list 3) nil))) + (and (equal (loop for a in list when a nconcing it) '(0 1 2 3)) + (equal list '(nil (0 1 2 3) nil nil (1 2 3) (2 3) nil (3) nil)))) +(null (loop for a in (list (list (list 0) (list 1) (list 2) (list 3))) + nconc a into x)) +(null (loop for a in (list (list (list 0) (list 1) (list 2) (list 3))) + nconcing a into x)) +(let ((list (list (list 0) (list 1) (list 2) (list 3)))) + (and (equal (loop for a in list nconc a into x finally (return x)) '(0 1 2 3)) + (equal list '((0 1 2 3) (1 2 3) (2 3) (3))))) +(let ((list (list (list 0) (list 1) (list 2) (list 3)))) + (and (equal (loop for a in list nconcing a into x finally (return x)) '(0 1 2 3)) + (equal list '((0 1 2 3) (1 2 3) (2 3) (3))))) +(equal (loop for i upfrom 0 as x in '(a b (c)) + nconc (if (evenp i) (list x) nil)) + '(A (C))) + + +(equal (loop for a in '(0 3 6) + for b in '((1) (4) (7)) + for c in (copy-tree '((2) (5) (8))) + collecting a + appending b + nconcing c) + '(0 1 2 3 4 5 6 7 8)) +(equal (loop for a in '(0 3 6) + for b in (copy-tree '((1) (4) (7))) + for c in (list (list 2) (list 5) (list 8)) + collecting a + nconcing b + appending c) + '(0 1 2 3 4 5 6 7 8)) +(equal (loop for a in '((0) (3) (6)) + for b in (copy-tree '((1) (4) (7))) + for c in '(2 5 8) + appending a + nconcing b + collecting c) + '(0 1 2 3 4 5 6 7 8)) +(equal (loop for a in '((0) (3) (6)) + for b in '(1 4 7) + for c in (copy-tree '((2) (5) (8))) + appending a + collecting b + nconcing c) + '(0 1 2 3 4 5 6 7 8)) +(equal (loop for a in (copy-tree '((0) (3) (6))) + for b in '(1 4 7) + for c in '((2) (5) (8)) + nconcing a + collecting b + appending c) + '(0 1 2 3 4 5 6 7 8)) +(equal (loop for a in (copy-tree '((0) (3) (6))) + for b in '((1) (4) (7)) + for c in '(2 5 8) + nconcing a + appending b + collecting c) + '(0 1 2 3 4 5 6 7 8)) +(equal (loop for a in '(0 6) + for b in '((1 2 3) (7 8 9)) + for c in (copy-tree '((4 5) (10))) + collect a + append b + nconc c) + '(0 1 2 3 4 5 6 7 8 9 10)) +(null (loop for a in '() + for b in '((1 2 3) (7 8 9)) + for c in (copy-tree '((4 5) (10))) + collect a + append b + nconc c)) +(equal (loop for a in '(0 3 6) + for b in '((1) (4) (7)) + for c in (copy-tree '((2) (5) (8))) + collecting a into list + appending b into list + nconcing c into list + finally (return list)) + '(0 1 2 3 4 5 6 7 8)) +(equal (loop for a in '(0 3 6) + for b in '(1 4 7) + for c in (copy-tree '((2) (5) (8))) + collect a collect b nconc c) + '(0 1 2 3 4 5 6 7 8)) + +(= 60 (loop for a upto 10 summing a when (oddp a) counting it)) +(= 220 (loop for a upto 10 + for b downfrom 20 + sum a + summing b)) +(= 60 (loop for a upto 10 + summing a into sum + when (oddp a) counting it into sum + finally (return sum))) +(= 21 (loop for a in '(a 1 b 3 c 4 5 x 2 y z) + if (and (numberp a) a) summing it + else counting 1)) + + +(= 5 (loop for a from 3 to 5 maximizing a minimizing a)) +(= 3 (loop for a upto 3 for b from 6 downto 3 maximize a minimize b)) +(equal (loop for a in '(0 -1 1 -2 2 -3 3) + maximize a into plus + minimize a into minus + finally (return (list minus plus))) + '(-3 3)) + +(equal (let (val) + (list (loop for a below 10 + collecting a + summing a into sum + counting a into count + maximizing a into max + minimizing a into min + finally (setq val (list sum count max min))) + val)) + '((0 1 2 3 4 5 6 7 8 9) (45 10 9 0))) +(eq 'ok (loop for a below 3 collecting a + finally (return 'ok))) +(let ((flag nil)) + (and (equal (loop for a below 3 collecting a + finally (setq flag t)) + '(0 1 2)) + flag)) +(eq 'ok (loop for a below 3 appending (list a) + finally (return 'ok))) +(eq 'ok (loop for a below 3 nconcing (list a) + finally (return 'ok))) + + + + + + + +;; numeric-accumulation-clauses +;; count +(= 5 (loop for a from 1 upto 10 + counting (evenp a))) +(= (loop for a downfrom 10 above 0 count a) 10) +(= (loop for a downfrom 10 above 0 counting a) 10) +(null (loop for a downfrom 10 above 0 count a into x)) +(null (loop for a downfrom 10 above 0 counting a into x)) +(= (loop for a downfrom 10 above 0 count a into x finally (return x)) 10) +(= (loop for a downfrom 10 above 0 counting a into x finally (return x)) 10) +(= (loop for a in '(nil a nil nil b nil c d e nil nil nil nil f) + when a count it) 6) +(= (loop for a in '(nil a nil nil b nil c d e nil nil nil nil f) + when a counting it) 6) +(null (loop for a in '(nil a nil nil b nil c d e nil nil nil nil f) + when a count it into x)) +(null (loop for a in '(nil a nil nil b nil c d e nil nil nil nil f) + when a counting it into x)) +(= (loop for a in '(nil a nil nil b nil c d e nil nil nil nil f) + when a count it into x finally (return x)) 6) +(= (loop for a in '(nil a nil nil b nil c d e nil nil nil nil f) + when a counting it into x finally (return x)) 6) +(= 5 (loop for i in '(a b nil c nil d e) count i)) + +;; sum +(= (loop for a to 10 sum a) 55) +(= (loop for a to 10 summing a) 55) +(= (loop for a in '(0 nil 1 nil 2 3 nil 4 5 6 7 nil 8 9 10 nil) + if a sum it) 55) +(= (loop for a in '(0 nil 1 nil 2 3 nil 4 5 6 7 nil 8 9 10 nil) + if a summing it) 55) +(loop for a to 10 + sum a into sum + if (oddp a) sum a into odd + else sum a into even + finally (return (= sum (+ odd even)))) +(loop for a to 10 + summing a into sum + if (oddp a) sum a into odd + else summing a into even + finally (return (= sum (+ odd even)))) +(= 15 (loop for a downfrom 5 to 1 + summing a)) +(null (loop for a downfrom 5 to 1 + summing a into n)) ;; not return automatically + +(= (loop for i from 1 to 4 + sum i fixnum + count t fixnum) + 14) + + +;; maximize +(= 5 (loop for i in '(2 1 5 3 4) maximize i)) +(= (loop for a in '(0 5 9) maximize a) 9) +(= (loop for a in '(0 5 9) maximizing a) 9) +(= (loop for a in '(0 9 5) maximize a) 9) +(= (loop for a in '(0 9 5) maximizing a) 9) +(= (loop for a in '(9 0 5) maximize a) 9) +(= (loop for a in '(9 0 5) maximizing a) 9) +(= (loop for a in '(9 0 9 5) maximize a) 9) +(= (loop for a in '(9 0 9 5) maximizing a) 9) +(let (list) + (loop (when (= (first (push (random 10) list)) 9) (return))) + (= (loop for a in list maximize a) 9)) +(let (list) + (loop (when (= (first (push (random 10) list)) 9) (return))) + (= (loop for a in list maximizing a) 9)) +(let (list) + (loop (when (= (first (push (random 100) list)) 99) (return))) + (= (loop for a in list maximize a) 99)) +(let (list) + (loop (when (= (first (push (random 100) list)) 99) (return))) + (= (loop for a in list maximizing a) 99)) +(let (list) + (loop (when (= (first (push (random 1000) list)) 999) (return))) + (= (loop for a in list maximize a) 999)) +(let (list) + (loop (when (= (first (push (random 1000) list)) 999) (return))) + (= (loop for a in list maximizing a) 999)) +(null (loop for a in '(0 5 9) maximize a into max)) +(null (loop for a in '(0 5 9) maximizing a into max)) +(= (loop for a in '(0 5 9) maximize a into max finally (return max)) 9) +(= (loop for a in '(0 5 9) maximizing a into max finally (return max)) 9) +(= (loop for a in '(0 5 9) maximize a into max of-type integer + finally (return max)) 9) +(= (loop for a in '(0 5 9) maximizing a into max of-type integer + finally (return max)) 9) +(= (loop for a in '(0.0 5.0 9.0) maximize a into max float + finally (return max)) 9.0) +(= (loop for a in '(0.0 5.0 9.0) maximizing a into max float + finally (return max)) 9.0) +(let ((series '(1.2 4.3 5.7))) + (= 6 (loop for v in series maximize (round v) of-type fixnum))) + +;; minimize +(= 1 (loop for i in '(2 1 5 3 4) minimize i)) +(= (loop for a in '(0 5 9) minimize a) 0) +(= (loop for a in '(0 5 9) minimizing a) 0) +(= (loop for a in '(9 5 0) minimize a) 0) +(= (loop for a in '(9 5 0) minimizing a) 0) +(= (loop for a in '(9 0 5) minimize a) 0) +(= (loop for a in '(9 0 5) minimizing a) 0) +(= (loop for a in '(9 0 9 0 5 0) minimizing a) 0) +(= (loop for a in '(9 0 9 0 5 0) minimizing a) 0) +(= (loop for a in '(1 5 9) minimize a) 1) +(= (loop for a in '(1 5 9) minimizing a) 1) +(= (loop for a in '(9 5 1) minimize a) 1) +(= (loop for a in '(9 5 1) minimizing a) 1) +(= (loop for a in '(9 1 5) minimize a) 1) +(= (loop for a in '(9 1 5) minimizing a) 1) +(= (loop for a in '(9 1 9 1 5 1) minimizing a) 1) +(= (loop for a in '(9 1 9 1 5 1) minimizing a) 1) +(let (list) + (loop (when (zerop (first (push (random 10) list))) (return))) + (zerop (loop for a in list minimize a))) +(let (list) + (loop (when (zerop (first (push (random 10) list))) (return))) + (zerop (loop for a in list minimizing a))) +(let (list) + (loop (when (zerop (first (push (random 100) list))) (return))) + (zerop (loop for a in list minimize a))) +(let (list) + (loop (when (zerop (first (push (random 100) list))) (return))) + (zerop (loop for a in list minimizing a))) +(let (list) + (loop (when (zerop (first (push (random 1000) list))) (return))) + (zerop (loop for a in list minimize a))) +(let (list) + (loop (when (zerop (first (push (random 1000) list))) (return))) + (zerop (loop for a in list minimizing a))) +(null (loop for a in '(0 5 9) minimize a into min)) +(null (loop for a in '(0 5 9) minimizing a into min)) +(zerop (loop for a in '(0 5 9) minimize a into min finally (return min))) +(zerop (loop for a in '(0 5 9) minimizing a into min finally (return min))) +(zerop (loop for a in '(0 5 9) minimize a into min of-type integer + finally (return min))) +(zerop (loop for a in '(0 5 9) minimizing a into min of-type integer + finally (return min))) +(= (loop for a in '(0.0 5.0 9.0) minimize a into min float + finally (return min)) 0.0) +(= (loop for a in '(0.0 5.0 9.0) minimizing a into min float + finally (return min)) 0.0) +(= 1 (let ((series '(1.2 4.3 5.7))) + (loop for v of-type float in series + minimize (round v) into result of-type fixnum + finally (return result)))) +(= 10 (loop for a in '(nil 1 nil 2 nil 3 nil 4) + when a summing it fixnum)) +(= 10 (loop for a in '(nil 1 nil 2 nil 3 nil 4) + when a summing it of-type fixnum)) +(= 10.0 (loop for a in '(nil 1.0 nil 2.0 nil 3.0 nil 4.0) + when a summing it float)) +(= 10.0 (loop for a in '(nil 1.0 nil 2.0 nil 3.0 nil 4.0) + when a summing it of-type float)) +(= 10 (loop for a in '(nil 1 nil 2 nil 3 nil 4) + when a summing it of-type number)) +(= 10 (loop for a in '(nil 1 nil 2 nil 3 nil 4) + when a summing it of-type (integer 0))) + +(= 10 (loop for a in '(nil 1 nil 2 nil 3 nil 4) + when a summing a fixnum)) +(= 10 (loop for a in '(nil 1 nil 2 nil 3 nil 4) + when a summing a of-type fixnum)) +(= 10.0 (loop for a in '(nil 1.0 nil 2.0 nil 3.0 nil 4.0) + when a summing a float)) +(= 10.0 (loop for a in '(nil 1.0 nil 2.0 nil 3.0 nil 4.0) + when a summing a of-type float)) +(= 10 (loop for a in '(nil 1 nil 2 nil 3 nil 4) + when a summing a of-type number)) +(= 10 (loop for a in '(nil 1 nil 2 nil 3 nil 4) + when a summing a of-type (integer 0))) + +(= 10 (loop for a in '(nil 1 nil 2 nil 3 nil 4) + when a summing a into sum fixnum finally (return sum))) +(= 10 (loop for a in '(nil 1 nil 2 nil 3 nil 4) + when a summing a into sum of-type fixnum finally (return sum))) +(= 10.0 (loop for a in '(nil 1.0 nil 2.0 nil 3.0 nil 4.0) + when a summing a into sum float finally (return sum))) +(= 10.0 (loop for a in '(nil 1.0 nil 2.0 nil 3.0 nil 4.0) + when a summing a into sum of-type float finally (return sum))) +(= 10 (loop for a in '(nil 1 nil 2 nil 3 nil 4) + when a summing a into sum of-type number finally (return sum))) +(= 10 (loop for a in '(nil 1 nil 2 nil 3 nil 4) + when a summing a into sum of-type (integer 0) finally (return sum))) + + +(= 10 (loop for a in '(nil 1 nil 2 nil 3 nil 4) + when a sum it fixnum)) +(= 10 (loop for a in '(nil 1 nil 2 nil 3 nil 4) + when a sum it of-type fixnum)) +(= 10.0 (loop for a in '(nil 1.0 nil 2.0 nil 3.0 nil 4.0) + when a sum it float)) +(= 10.0 (loop for a in '(nil 1.0 nil 2.0 nil 3.0 nil 4.0) + when a sum it of-type float)) +(= 10 (loop for a in '(nil 1 nil 2 nil 3 nil 4) + when a sum it of-type number)) +(= 10 (loop for a in '(nil 1 nil 2 nil 3 nil 4) + when a sum it of-type (integer 0))) + +(= 10 (loop for a in '(nil 1 nil 2 nil 3 nil 4) + when a sum a fixnum)) +(= 10 (loop for a in '(nil 1 nil 2 nil 3 nil 4) + when a sum a of-type fixnum)) +(= 10.0 (loop for a in '(nil 1.0 nil 2.0 nil 3.0 nil 4.0) + when a sum a float)) +(= 10.0 (loop for a in '(nil 1.0 nil 2.0 nil 3.0 nil 4.0) + when a sum a of-type float)) +(= 10 (loop for a in '(nil 1 nil 2 nil 3 nil 4) + when a sum a of-type number)) +(= 10 (loop for a in '(nil 1 nil 2 nil 3 nil 4) + when a sum a of-type (integer 0))) + +(= 10 (loop for a in '(nil 1 nil 2 nil 3 nil 4) + when a sum a into sum fixnum finally (return sum))) +(= 10 (loop for a in '(nil 1 nil 2 nil 3 nil 4) + when a sum a into sum of-type fixnum finally (return sum))) +(= 10.0 (loop for a in '(nil 1.0 nil 2.0 nil 3.0 nil 4.0) + when a sum a into sum float finally (return sum))) +(= 10.0 (loop for a in '(nil 1.0 nil 2.0 nil 3.0 nil 4.0) + when a sum a into sum of-type float finally (return sum))) +(= 10 (loop for a in '(nil 1 nil 2 nil 3 nil 4) + when a sum a into sum of-type number finally (return sum))) +(= 10 (loop for a in '(nil 1 nil 2 nil 3 nil 4) + when a sum a into sum of-type (integer 0) finally (return sum))) + +(= 7 (loop for a in '(nil a nil b nil c nil d e nil f g nil nil nil nil) + counting a fixnum)) +(= 7 (loop for a in '(nil a nil b nil c nil d e nil f g nil nil nil nil) + counting a of-type fixnum)) +(= 7 (loop for a in '(nil a nil b nil c nil d e nil f g nil nil nil nil) + counting a of-type integer)) +(= 7 (loop for a in '(nil a nil b nil c nil d e nil f g nil nil nil nil) + counting a of-type (integer 0))) +(= 7 (loop for a in '(nil a nil b nil c nil d e nil f g nil nil nil nil) + counting a of-type number)) + +(= 7 (loop for a in '(nil a nil b nil c nil d e nil f g nil nil nil nil) + counting a into x fixnum finally (return x))) +(= 7 (loop for a in '(nil a nil b nil c nil d e nil f g nil nil nil nil) + counting a into x of-type fixnum finally (return x))) +(= 7 (loop for a in '(nil a nil b nil c nil d e nil f g nil nil nil nil) + counting a into x of-type integer finally (return x))) +(= 7 (loop for a in '(nil a nil b nil c nil d e nil f g nil nil nil nil) + counting a into x of-type (integer 0) finally (return x))) +(= 7 (loop for a in '(nil a nil b nil c nil d e nil f g nil nil nil nil) + counting a into x of-type number finally (return x))) + +(= 99 (loop for a in '(3 5 8 0 7 7 99 3) maximize a fixnum)) +(= 99 (loop for a in '(3 5 8 0 7 7 99 3) maximize a of-type fixnum)) +(= 99.0 (loop for a in '(3.0 5.0 8.0 0.0 7.0 7.0 99.0 3.0) + maximize a float)) +(= 99.0 (loop for a in '(3.0 5.0 8.0 0.0 7.0 7.0 99.0 3.0) + maximize a of-type float)) +(= 99.0 (loop for a in '(3.0 5.0 2.2 8.0 0 3/5 7.0 7 99 3.0) + maximize a of-type real)) +(= 99 (loop for a in '(3 5 8 0 7 7 99 3) maximize a of-type (integer 0))) + + +(= 99 (loop for a in '(3 5 8 0 7 7 99 3) maximize a into max fixnum + finally (return max))) +(= 99 (loop for a in '(3 5 8 0 7 7 99 3) maximize a into max of-type fixnum + finally (return max))) +(= 99.0 (loop for a in '(3.0 5.0 8.0 0.0 7.0 7.0 99.0 3.0) + maximize a into max float finally (return max))) +(= 99.0 (loop for a in '(3.0 5.0 8.0 0.0 7.0 7.0 99.0 3.0) + maximize a into max of-type float finally (return max))) +(= 99.0 (loop for a in '(3.0 5.0 2.2 8.0 0 3/5 7.0 7 99 3.0) + maximize a into max of-type real finally (return max))) +(= 99 (loop for a in '(3 5 8 0 7 7 99 3) + maximize a into max of-type (integer 0) + finally (return max))) + +(= 99 (loop for a in '(3 nil 5 8 nil 0 nil 7 7 99 3) when a maximize it fixnum)) +(= 99 (loop for a in '(nil 3 nil 5 nil 8 0 7 7 nil 99 nil 3) + when a maximize it of-type fixnum)) +(= 99.0 (loop for a in '(3.0 nil 5.0 8.0 0.0 nil nil nil nil 7.0 nil 7.0 99.0 + nil 3.0 nil nil nil) + when a maximize it float)) +(= 99.0 (loop for a in '(nil nil nil nil nil 3.0 nil 5.0 8.0 0.0 + nil nil nil 7.0 7.0 nil nil 99.0 3.0) + when a maximize it of-type float)) +(= 99.0 (loop for a in '(3.0 5.0 nil nil 2.2 nil nil 8.0 0 + nil nil 3/5 nil nil 7.0 7 99 3.0) + when a maximize it of-type real)) +(= 99 (loop for a in '(3 nil nil 5 8 0 nil nil 7 7 99 nil nil 3) + when a maximize a of-type (integer 0))) + +(= 99 (loop for a in '(3 nil 5 8 nil 0 nil 7 7 99 3) + when a maximize it into max fixnum + finally (return max))) +(= 99 (loop for a in '(nil 3 nil 5 nil 8 0 7 7 nil 99 nil 3) + when a maximize it into max of-type fixnum finally (return max))) +(= 99.0 (loop for a in '(3.0 nil 5.0 8.0 0.0 nil nil nil nil 7.0 nil 7.0 99.0 + nil 3.0 nil nil nil) + when a maximize it into max float finally (return max))) +(= 99.0 (loop for a in '(nil nil nil nil nil 3.0 nil 5.0 8.0 0.0 + nil nil nil 7.0 7.0 nil nil 99.0 3.0) + when a maximize it into max of-type float finally (return max))) +(= 99.0 (loop for a in '(3.0 5.0 nil nil 2.2 nil nil 8.0 0 + nil nil 3/5 nil nil 7.0 7 99 3.0) + when a maximize it into max of-type real finally (return max))) +(= 99 (loop for a in '(3 nil nil 5 8 0 nil nil 7 7 99 nil nil 3) + when a maximize it into max of-type (integer 0) + finally (return max))) + + + +(= 99 (loop for a in '(3 5 8 0 7 7 99 3) maximizing a fixnum)) +(= 99 (loop for a in '(3 5 8 0 7 7 99 3) maximizing a of-type fixnum)) +(= 99.0 (loop for a in '(3.0 5.0 8.0 0.0 7.0 7.0 99.0 3.0) + maximizing a float)) +(= 99.0 (loop for a in '(3.0 5.0 8.0 0.0 7.0 7.0 99.0 3.0) + maximizing a of-type float)) +(= 99.0 (loop for a in '(3.0 5.0 2.2 8.0 0 3/5 7.0 7 99 3.0) + maximizing a of-type real)) +(= 99 (loop for a in '(3 5 8 0 7 7 99 3) maximizing a of-type (integer 0))) + + +(= 99 (loop for a in '(3 5 8 0 7 7 99 3) maximizing a into max fixnum + finally (return max))) +(= 99 (loop for a in '(3 5 8 0 7 7 99 3) maximizing a into max of-type fixnum + finally (return max))) +(= 99.0 (loop for a in '(3.0 5.0 8.0 0.0 7.0 7.0 99.0 3.0) + maximizing a into max float finally (return max))) +(= 99.0 (loop for a in '(3.0 5.0 8.0 0.0 7.0 7.0 99.0 3.0) + maximizing a into max of-type float finally (return max))) +(= 99.0 (loop for a in '(3.0 5.0 2.2 8.0 0 3/5 7.0 7 99 3.0) + maximizing a into max of-type real finally (return max))) +(= 99 (loop for a in '(3 5 8 0 7 7 99 3) + maximizing a into max of-type (integer 0) + finally (return max))) + +(= 99 (loop for a in '(3 nil 5 8 nil 0 nil 7 7 99 3) when a maximizing it fixnum)) +(= 99 (loop for a in '(nil 3 nil 5 nil 8 0 7 7 nil 99 nil 3) + when a maximizing it of-type fixnum)) +(= 99.0 (loop for a in '(3.0 nil 5.0 8.0 0.0 nil nil nil nil 7.0 nil 7.0 99.0 + nil 3.0 nil nil nil) + when a maximizing it float)) +(= 99.0 (loop for a in '(nil nil nil nil nil 3.0 nil 5.0 8.0 0.0 + nil nil nil 7.0 7.0 nil nil 99.0 3.0) + when a maximizing it of-type float)) +(= 99.0 (loop for a in '(3.0 5.0 nil nil 2.2 nil nil 8.0 0 + nil nil 3/5 nil nil 7.0 7 99 3.0) + when a maximizing it of-type real)) +(= 99 (loop for a in '(3 nil nil 5 8 0 nil nil 7 7 99 nil nil 3) + when a maximizing a of-type (integer 0))) + +(= 99 (loop for a in '(3 nil 5 8 nil 0 nil 7 7 99 3) + when a maximizing it into max fixnum + finally (return max))) +(= 99 (loop for a in '(nil 3 nil 5 nil 8 0 7 7 nil 99 nil 3) + when a maximizing it into max of-type fixnum finally (return max))) +(= 99.0 (loop for a in '(3.0 nil 5.0 8.0 0.0 nil nil nil nil 7.0 nil 7.0 99.0 + nil 3.0 nil nil nil) + when a maximizing it into max float finally (return max))) +(= 99.0 (loop for a in '(nil nil nil nil nil 3.0 nil 5.0 8.0 0.0 + nil nil nil 7.0 7.0 nil nil 99.0 3.0) + when a maximizing it into max of-type float finally (return max))) +(= 99.0 (loop for a in '(3.0 5.0 nil nil 2.2 nil nil 8.0 0 + nil nil 3/5 nil nil 7.0 7 99 3.0) + when a maximizing it into max of-type real finally (return max))) +(= 99 (loop for a in '(3 nil nil 5 8 0 nil nil 7 7 99 nil nil 3) + when a maximizing it into max of-type (integer 0) + finally (return max))) + + +(= 3 (loop for a in '(3 5 8 4 7 7 99 3) minimize a fixnum)) +(= 3 (loop for a in '(3 5 8 4 7 7 99 3) minimize a of-type fixnum)) +(= 3.0 (loop for a in '(5.0 8.0 7.0 3.0 7.0 99.0) minimize a float)) +(= 3.0 (loop for a in '(5.0 8.0 7.0 3.0 7.0 99.0) minimize a of-type float)) +(= 3.0 (loop for a in '(5.0 8 7 3 7.0 3.0 99.0 1000) minimize a of-type real)) +(= 5 (loop for a in '(6 5 8 7 7 99) minimize a of-type (integer 0))) + +(= 3 (loop for a in '(5 8 4 7 7 99 3) minimize a into min fixnum + finally (return min))) +(= 3 (loop for a in '(5 8 4 7 7 99 3) minimize a into min of-type fixnum + finally (return min))) +(= 3.0 (loop for a in '(5.0 8.0 4.0 7.0 7.0 99.0 3.0) minimize a into min float + finally (return min))) +(= 3.0 (loop for a in '(5.0 8.0 4.0 7.0 7.0 99.0 3.0) + minimize a into min of-type float finally (return min))) +(= 3.0 (loop for a in '(5.0 8 4.0 31/3 7.0 7 99.0 3.0) + minimize a into min of-type real finally (return min))) +(= 5 (loop for a in '(6 5 8 7 7 99) minimize a into min of-type (integer 0) + finally (return min))) + +(= 3 (loop for a in '(nil 5 8 nil nil 7 7 nil 99 3) when a minimize it fixnum)) +(= 3 (loop for a in '(nil 5 8 nil nil 7 7 nil 99 3) + when a minimize it of-type fixnum)) +(= 3.0 (loop for a in '(nil 5.0 8.0 nil nil 7.0 7.0 nil 99.0 3.0) + when a minimize it float)) +(= 3.0 (loop for a in '(nil 5.0 8.0 nil nil 7.0 7.0 nil 99.0 3.0) + when a minimize it of-type float)) +(= 3 (loop for a in '(nil 5.0 8.0 nil nil 7.0 7.0 nil 99.0 3.0) + when a minimize it of-type real)) +(= 3 (loop for a in '(nil 5 8 nil nil 7 7 nil 99 3) + when a minimize it of-type (integer 0))) +(= -99 (loop for a in '(nil -5 8 nil nil 7 7 nil -99 3) + when a minimize it of-type (integer))) + + +(= 3 (loop for a in '(3 5 8 4 7 7 99 3) minimizing a fixnum)) +(= 3 (loop for a in '(3 5 8 4 7 7 99 3) minimizing a of-type fixnum)) +(= 3.0 (loop for a in '(5.0 8.0 7.0 3.0 7.0 99.0) minimizing a float)) +(= 3.0 (loop for a in '(5.0 8.0 7.0 3.0 7.0 99.0) minimizing a of-type float)) +(= 3.0 (loop for a in '(5.0 8 7 3 7.0 3.0 99.0 1000) minimizing a of-type real)) +(= 5 (loop for a in '(6 5 8 7 7 99) minimizing a of-type (integer 0))) + +(= 3 (loop for a in '(5 8 4 7 7 99 3) minimizing a into min fixnum + finally (return min))) +(= 3 (loop for a in '(5 8 4 7 7 99 3) minimizing a into min of-type fixnum + finally (return min))) +(= 3.0 (loop for a in '(5.0 8.0 4.0 7.0 7.0 99.0 3.0) minimizing a into min float + finally (return min))) +(= 3.0 (loop for a in '(5.0 8.0 4.0 7.0 7.0 99.0 3.0) + minimizing a into min of-type float finally (return min))) +(= 3.0 (loop for a in '(5.0 8 4.0 31/3 7.0 7 99.0 3.0) + minimizing a into min of-type real finally (return min))) +(= 5 (loop for a in '(6 5 8 7 7 99) minimizing a into min of-type (integer 0) + finally (return min))) + +(= 3 (loop for a in '(nil 5 8 nil nil 7 7 nil 99 3) when a minimizing it fixnum)) +(= 3 (loop for a in '(nil 5 8 nil nil 7 7 nil 99 3) + when a minimizing it of-type fixnum)) +(= 3.0 (loop for a in '(nil 5.0 8.0 nil nil 7.0 7.0 nil 99.0 3.0) + when a minimizing it float)) +(= 3.0 (loop for a in '(nil 5.0 8.0 nil nil 7.0 7.0 nil 99.0 3.0) + when a minimizing it of-type float)) +(= 3 (loop for a in '(nil 5.0 8.0 nil nil 7.0 7.0 nil 99.0 3.0) + when a minimizing it of-type real)) +(= 3 (loop for a in '(nil 5 8 nil nil 7 7 nil 99 3) + when a minimizing it of-type (integer 0))) +(= -99 (loop for a in '(nil -5 8 nil nil 7 7 nil -99 3) + when a minimizing it of-type (integer))) +(eq 'ok (loop for i from 0 upto 10 summing i finally (return 'ok))) +(eq 'ok (loop for i in '(nil nil 3 nil 5 nil 6) + counting i finally (return 'ok))) +(eq 'ok (loop for i in '(nil nil 3 nil 5 nil 6) + when i maximizing it finally (return 'ok))) +(eq 'ok (loop for i in '(nil nil 3 nil 5 nil 6) + when i minimizing it finally (return 'ok))) + + + + +;; termination-test-clauses +(null (loop with x = '(a b c d) while x do (pop x))) +(equal (loop with stack = nil and x = '(0 1 2 3) + while x do (push (pop x) stack) finally (return stack)) + '(3 2 1 0)) +(equal (loop with stack = nil and x = '(0 1 2 3) + until (null x) do (push (pop x) stack) finally (return stack)) + '(3 2 1 0)) +(equal (let ((stack '(a b c d e f))) + (loop for item = (length stack) then (pop stack) + collect item + while stack)) + '(6 A B C D E F)) +(equal (loop for i fixnum from 3 + when (oddp i) collect i + while (< i 5)) + '(3 5)) +(equal (loop for a below 10 + when (and (evenp a) a) collect it + while (< a 6) + collect a) + '(0 0 1 2 2 3 4 4 5 6)) +(equal (loop for a below 10 + when (and (evenp a) a) collect it + until (>= a 6) + collect a) + '(0 0 1 2 2 3 4 4 5 6)) +(equal (loop for a below 10 + when (and (evenp a) a) collect it + while (< a 6) + collect a + until (>= a 4) + collect a) + '(0 0 0 1 1 2 2 2 3 3 4 4)) + +;; repeat +(= 3 (loop with x = 0 repeat 3 do (incf x) finally (return x))) +(= 1000 (loop repeat 1000 counting 1)) +(null (loop repeat 3)) +(null (loop repeat 0)) +(let ((body-flag nil)) + (and (null (loop repeat 0 do (setq body-flag t))) (null body-flag))) +(= 1 (let ((x 0)) (loop repeat (incf x) sum x))) +(= 4 (let ((x 1)) (loop repeat (incf x) sum x))) +(= 9 (let ((x 2)) (loop repeat (incf x) sum x))) +(= 16 (let ((x 3)) (loop repeat (incf x) sum x))) +(null (loop repeat -15 return t)) +(let ((body-flag nil)) + (and (null (loop repeat -10 do (setq body-flag t))) (null body-flag))) +(let ((eval-count 0) + (loop-count 0)) + (loop repeat (progn (incf eval-count) 2) do (incf loop-count)) + (and (= 1 eval-count) + (= 2 loop-count))) +(let ((eval-count 0) + (loop-count 0)) + (loop repeat (progn (incf eval-count) 0) do (incf loop-count)) + (and (= 1 eval-count) + (zerop loop-count))) +(let ((eval-count 0) + (loop-count 0)) + (loop repeat (progn (incf eval-count) -100) do (incf loop-count)) + (and (= 1 eval-count) + (zerop loop-count))) + +;; always +(eq t (loop for i from 0 to 10 always (< i 11))) +(eq t (loop for a in '() always (oddp a))) +(null (loop for a in '(0 1 2) always (oddp a))) +(eq t (loop for a in '(1 3 5) always (oddp a))) +(let ((flag nil)) + (and (null (loop for i from 0 to 10 always (< i 5) + finally (setq flag t) (return t))) + (not flag))) +(eq 'ok (loop for i below 3 always (numberp i) finally (return 'ok))) +(eq t (loop repeat 3 always t)) +(handler-case (macroexpand '(loop for i from 0 upto 10 + always (integerp i) + collect i)) + (program-error () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)) + +;; never +(eq t (loop for i from 0 to 10 never (> i 11))) +(eq t (loop for a in '() never (oddp a))) +(null (loop for a in '(0 1 2) never (oddp a))) +(eq t (loop for a in '(1 3 5) never (evenp a))) +(null (loop never t finally (return t))) +(let ((flag nil)) + (and (null (loop for a below 3 never (oddp a) + finally (setq flag t) (return t))) + (null flag))) +(eq 'ok (loop for i below 3 never (consp i) finally (return 'ok))) +(eq t (loop repeat 3 never nil)) +(handler-case (macroexpand '(loop for i from 0 upto 10 + never (integerp i) + append (list i))) + (program-error () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)) + +;; thereis +(null (loop for a in '(0 2 4) thereis (oddp a))) +(= 11 (loop for i from 0 thereis (when (> i 10) i))) +(eq (loop thereis 'someone) 'someone) +(eq (loop for i from 1 to 10 + thereis (> i 11) + finally (return 'got-here)) + 'got-here) +(let ((count 0)) + (and (null (loop for a below 10 for b in '(nil nil nil nil c) + always (< a 8) + never b + do (incf count))) + (= count 4))) +(eq (loop for a in '(nil nil nil found-it! nil nil) + for b from 10 downto 0 + never (< b 0) + thereis a) 'found-it!) +(= 4 (loop for i in '(1 2 3 4 5 6) + thereis (and (> i 3) i))) +(let ((flag nil)) + (loop for a below 3 + thereis (and (oddp a) a) + finally (setq flag t)) + (null flag)) +(eq 'ok (loop for i below 3 thereis (consp i) finally (return 'ok))) +(null (loop repeat 3 thereis nil)) +(handler-case (macroexpand '(loop for i from 0 upto 10 + thereis (integerp i) + nconc (list i))) + (program-error () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)) + + + +;; name-clause +(loop named bar do (return-from bar t)) +(eq t (loop named outer do (loop named inner do (return-from outer t)))) + + + + + + +;; destructuring +(equal (loop for (a b c) of-type (integer integer float) in + '((1 2 4.0) (5 6 8.3) (8 9 10.4)) + collect (list c b a)) + '((4.0 2 1) (8.3 6 5) (10.4 9 8))) + +(equal (loop for (a b c) of-type float in + '((1.0 2.0 4.0) (5.0 6.0 8.3) (8.0 9.0 10.4)) + collect (list c b a)) + '((4.0 2.0 1.0) (8.3 6.0 5.0) (10.4 9.0 8.0))) + +(equal (loop with (a b) of-type float = '(1.0 2.0) + and (c d) of-type integer = '(3 4) + and (e f) + return (list a b c d e f)) + '(1.0 2.0 3 4 NIL NIL)) +(equal (let (stack) + (loop for (a (b) ((c))) in '((0 (1) ((2))) (3 (4) ((5))) (6 (7) ((8)))) + do (push (list a b c) stack)) + stack) + '((6 7 8) (3 4 5) (0 1 2))) +(equal (let (stack) + (loop for (a nil ((b))) in '((0 (1) ((2))) (3 (4) ((5))) (6 (7) ((8)))) + do (push (list a b) stack)) + stack) + '((6 8) (3 5) (0 2))) +(equal (let (stack) + (loop for (a nil ((((b))))) in + '((0 (1) ((((2))))) (3 (4) ((((5))))) (6 (7) ((((8)))))) + do (push (list a b) stack)) + stack) + '((6 8) (3 5) (0 2))) +(equal (let (stack) + (loop for (a . b) in '((0 . 1) (2 . 3)) do (push (cons a b) stack)) + stack) + '((2 . 3) (0 . 1))) +(equal (let (stack) + (loop for (a . (b)) in '((0 1) (2 3)) do (push (list a b) stack)) + stack) + '((2 3) (0 1))) +(equal (let (stack) + (loop for (a) on '(0 1 2 3) do (push a stack)) stack) + '(3 2 1 0)) +(equal (let (stack) + (loop for (a . b) on '(0 1 2 3 4) do (push (list a b) stack)) + stack) + '((4 nil) (3 (4)) (2 (3 4)) (1 (2 3 4)) (0 (1 2 3 4)))) +(equal (let (stack) (loop for (a b) across #((0 1) (2 3) (4 5)) + do (push (list a b) stack)) + stack) + '((4 5) (2 3) (0 1))) +(equal (let (stack) (loop for (a ((b))) across #((0 ((1))) (2 ((3))) (4 ((5)))) + do (push (list a b) stack)) + stack) + '((4 5) (2 3) (0 1))) +(equal (loop with (a b) = '(0 1) return (list a b)) '(0 1)) +(equal (loop with (a b c) = '(0) return (list a b c)) '(0 nil nil)) +(= 2 (loop with (nil nil x) = '(0 1 2) return x)) +(equal (loop for (a b c) in '((0) (1) (2)) + collect (list a b c)) + '((0 nil nil) (1 nil nil) (2 nil nil))) +(equal (loop for (a nil b) in '((0 1 2) (1 2 3) (2 3 4)) + collect (list a b)) + '((0 2) (1 3) (2 4))) + +(equal (loop for (a . b) t in '((0 . x) (1 . y) (2 . z)) collecting (cons a b)) + '((0 . x) (1 . y) (2 . z))) +(equal (loop for (a . b) of-type t in '((0 . x) (1 . y) (2 . z)) + collecting (cons a b)) + '((0 . x) (1 . y) (2 . z))) +(equal (loop for (a . b) of-type (fixnum . symbol) in '((0 . x) (1 . y) (2 . z)) + collecting (cons a b)) + '((0 . x) (1 . y) (2 . z))) +(equal (loop for (a ((b))) of-type (fixnum ((symbol))) in + '((0 ((x))) (1 ((y))) (2 ((z)))) + collecting (cons a b)) + '((0 . x) (1 . y) (2 . z))) +(equal (loop for (a ((b))) of-type (fixnum symbol) in + '((0 ((x))) (1 ((y))) (2 ((z)))) + collecting (cons a b)) + '((0 . x) (1 . y) (2 . z))) +(equal (loop for (a ((b))) fixnum in '((0 ((10))) (1 ((11))) (2 ((12)))) + collecting (cons a b)) + '((0 . 10) (1 . 11) (2 . 12))) +(equal (loop for (a ((b)) c (((d)))) fixnum in + '((0 ((10)) 20 (((30)))) + (1 ((11)) 21 (((31)))) + (2 ((12)) 22 (((32))))) + collecting (list a b c d)) + '((0 10 20 30) (1 11 21 31) (2 12 22 32))) +(equal (loop for (a ((b)) c (((d)))) + of-type (fixnum ((fixnum)) fixnum (((fixnum)))) in + '((0 ((10)) 20 (((30)))) + (1 ((11)) 21 (((31)))) + (2 ((12)) 22 (((32))))) + collecting (list a b c d)) + '((0 10 20 30) (1 11 21 31) (2 12 22 32))) +(equal (loop for (a nil nil (((b)))) of-type (fixnum nil nil (((fixnum)))) in + '((0 ((10)) 20 (((30)))) + (1 ((11)) 21 (((31)))) + (2 ((12)) 22 (((32))))) + collecting (list a b)) + '((0 30) (1 31) (2 32))) + +(equal (loop for (a) fixnum on '(0 1 2) collecting a) '(0 1 2)) +(equal (loop for (a) of-type fixnum on '(0 1 2) collecting a) '(0 1 2)) +(equal (loop for (a) float on '(0.3 1.3 2.3) collecting a) '(0.3 1.3 2.3)) +(equal (loop for (a) of-type float on '(0.3 1.3 2.3) collecting a) + '(0.3 1.3 2.3)) +(equal (loop for (a) t on '(0 1 2) collecting a) '(0 1 2)) +(equal (loop for (a) of-type t on '(0 1 2) collecting a) '(0 1 2)) +(equal (loop for (a) of-type real on '(0 1.0 2/3) collecting a) '(0 1.0 2/3)) +(equal (loop for (a nil b) fixnum on '(0 1 2) collecting (list a b)) + '((0 2) (1 nil) (2 nil))) +(equal (loop for (a nil b) of-type (fixnum nil fixnum) on '(0 1 2) + collecting (list a b)) + '((0 2) (1 nil) (2 nil))) +(equal (loop for (nil . tail) t on '(0 1 2 3) append tail) + '(1 2 3 2 3 3)) +(equal (loop for (nil . tail) of-type t on '(0 1 2 3) append tail) + '(1 2 3 2 3 3)) +(equal (loop for (nil . tail) of-type list on '(0 1 2 3) append tail) + '(1 2 3 2 3 3)) + +(equal (loop for (a b) t across #((x 0) (y 1) (z 2)) collecting (list b a)) + '((0 x) (1 y) (2 z))) +(equal (loop for (a b) of-type t across #((x 0) (y 1) (z 2)) + collecting (list b a)) + '((0 x) (1 y) (2 z))) +(equal (loop for (a b) of-type ((member x y z) (member 0 1 2)) + across #((x 0) (y 1) (z 2)) + collecting (list b a)) + '((0 x) (1 y) (2 z))) + + +(eq t (loop for (a) t := '(0) then (list (1+ a)) + when (= a 3) return t)) +(eq t (loop for (a) of-type t := '(0) then (list (1+ a)) + when (= a 3) return t)) +(eq t (loop for (a) of-type (t) := '(0) then (list (1+ a)) + when (= a 3) return t)) +(eq t (loop for (a) fixnum := '(0) then (list (1+ a)) + when (= a 3) return t)) +(eq t (loop for (a) of-type fixnum := '(0) then (list (1+ a)) + when (= a 3) return t)) +(eq t (loop for (a) of-type (fixnum) := '(0) then (list (1+ a)) + when (= a 3) return t)) +(eq t (loop for (a) float := '(0.0) then (list (1+ a)) + when (= a 3.0) return t)) +(eq t (loop for (a) of-type float := '(0.0) then (list (1+ a)) + when (= a 3.0) return t)) +(eq t (loop for (a) of-type (float) := '(0.0) then (list (1+ a)) + when (= a 3.0) return t)) +(equal (loop for (a b) t := '(0 1) then (list (1+ b) (+ b 2)) + when (> a 5) do (loop-finish) + collect (list a b)) + '((0 1) (2 3) (4 5))) +(equal (loop for (a b) of-type t := '(0 1) then (list (1+ b) (+ b 2)) + when (> a 5) do (loop-finish) + collect (list a b)) + '((0 1) (2 3) (4 5))) +(equal (loop for (a b) of-type (t t) := '(0 1) then (list (1+ b) (+ b 2)) + when (> a 5) do (loop-finish) + collect (list a b)) + '((0 1) (2 3) (4 5))) +(equal (loop for (a b) fixnum := '(0 1) then (list (1+ b) (+ b 2)) + when (> a 5) do (loop-finish) + collect (list a b)) + '((0 1) (2 3) (4 5))) +(equal (loop for (a b) of-type fixnum := '(0 1) then (list (1+ b) (+ b 2)) + when (> a 5) do (loop-finish) + collect (list a b)) + '((0 1) (2 3) (4 5))) +(equal (loop for (a b) of-type (fixnum fixnum) := '(0 1) + then (list (1+ b) (+ b 2)) + when (> a 5) do (loop-finish) + collect (list a b)) + '((0 1) (2 3) (4 5))) +(equal (loop for (a b) float := '(0.0 1.0) then (list (1+ b) (+ b 2.0)) + when (> a 5) do (loop-finish) + collect (list a b)) + '((0.0 1.0) (2.0 3.0) (4.0 5.0))) +(equal (loop for (a b) of-type float := '(0.0 1.0) then (list (1+ b) (+ b 2.0)) + when (> a 5) do (loop-finish) + collect (list a b)) + '((0.0 1.0) (2.0 3.0) (4.0 5.0))) +(equal (loop for (a b) of-type (float float) := '(0.0 1.0) + then (list (1+ b) (+ b 2.0)) + when (> a 5) do (loop-finish) + collect (list a b)) + '((0.0 1.0) (2.0 3.0) (4.0 5.0))) +(equal (loop for (a b) of-type (fixnum float) := '(0 1.0) + then (list (+ a 2) (+ b 2.0)) + when (> a 5) do (loop-finish) + collect (list a b)) + '((0 1.0) (2 3.0) (4 5.0))) + +(let ((table (make-hash-table :test 'equal)) + stack) + (mapc #'(lambda (k v) (setf (gethash k table) v)) + '((k0 0) (k1 1) (k2 2)) '(v0 v1 v2)) + (loop for (k kn) t being each hash-key of table do (push (list k kn) stack)) + (null (set-exclusive-or stack '((k0 0) (k1 1) (k2 2)) :test #'equal))) +(let ((table (make-hash-table :test 'equal)) + stack) + (mapc #'(lambda (k v) (setf (gethash k table) v)) + '((k0 0) (k1 1) (k2 2)) '(v0 v1 v2)) + (loop for (k kn) of-type t being each hash-key of table + do (push (list k kn) stack)) + (null (set-exclusive-or stack '((k0 0) (k1 1) (k2 2)) :test #'equal))) +(let ((table (make-hash-table :test 'equal)) + stack) + (mapc #'(lambda (k v) (setf (gethash k table) v)) + '((k0 0) (k1 1) (k2 2)) '(v0 v1 v2)) + (loop for (k kn) of-type (symbol fixnum) being each hash-key of table + do (push (list k kn) stack)) + (null (set-exclusive-or stack '((k0 0) (k1 1) (k2 2)) :test #'equal))) +(let ((table (make-hash-table :test 'equal)) + stack) + (mapc #'(lambda (k v) (setf (gethash k table) v)) + '((k0 0) (k1 1) (k2 2)) '(v0 v1 v2)) + (loop for (k kn) of-type t being each hash-key of table + do (push (list k kn) stack)) + (null (set-exclusive-or stack '((k0 0) (k1 1) (k2 2)) :test #'equal))) +(let ((table (make-hash-table :test 'equal)) + stack) + (mapc #'(lambda (k v) (setf (gethash k table) v)) + '((k0 0) (k1 1) (k2 2)) '(v0 v1 v2)) + (loop for (k kn) of-type (t t) being each hash-key of table + do (push (list k kn) stack)) + (null (set-exclusive-or stack '((k0 0) (k1 1) (k2 2)) :test #'equal))) + + + + +;; double binding +(handler-case + (macroexpand '(loop with a = 0 for a downfrom 10 to 0 do (print a))) + (program-error () t) + (error () nil) + (:no-error (&rest rest) + (declare (ignore rest)) + nil)) +(handler-case + (macroexpand '(loop for a from 0 upto 10 collect t into a)) + (program-error () t) + (error () nil) + (:no-error (&rest rest) + (declare (ignore rest)) + nil)) + + + + +;; misc +(= 4 (loop for (item . x) of-type (t . fixnum) in '((A . 1) (B . 2) (C . 3)) + unless (eq item 'B) sum x)) +(equal (loop for sublist on '(a b c d) collect sublist) + '((A B C D) (B C D) (C D) (D))) +(equal (loop for (item) on '(1 2 3) collect item) '(1 2 3)) +(equal (loop for item = 1 then (+ item 10) + for iteration from 1 to 5 + collect item) + '(1 11 21 31 41)) +(equal (loop for i below 3 collecting (loop for j below 2 collecting (list i j))) + '(((0 0) (0 1)) ((1 0) (1 1)) ((2 0) (2 1)))) +(zerop (loop for i from -10 upto 0 maximizing i)) +(equal (loop for i from -10 upto 0 maximizing i into max minimizing i into min + finally (return (list max min))) + '(0 -10)) +(equal (loop for c across "aBcDeFg" when (and (upper-case-p c) c) collecting it) + '(#\B #\D #\F)) +(equal (loop named my-loop for i below 3 collect i into x + finally (return-from my-loop x)) + '(0 1 2)) +(equal (loop named nil for i below 3 collect i into x + finally (return-from nil x)) + '(0 1 2)) +(equal (loop for i below 3 collect i into x + finally (return-from nil x)) + '(0 1 2)) +(equal (loop for i below 3 collect i into x + finally (return x)) + '(0 1 2)) +(equal (loop for a from 10 above 0 + for b in '(1 2 3 4 5 6 7 8 9 10) + for c on '(j k l m n o p q r s) + for d = 100 then (1- d) + collect (list a b (first c) d)) + '((10 1 j 100) (9 2 k 99) (8 3 l 98) (7 4 m 97) (6 5 n 96) + (5 6 o 95) (4 7 p 94) (3 8 q 93) (2 9 r 92) (1 10 s 91))) + +(equal (loop with e = 0 + for a from 10 above 0 + for b in '(1 2 3 4 5 6 7 8 9 10) + for c on '(j k l m n o p q r s) + for d = 100 then (1- d) + append (list a b (first c) d) into values + initially (setq e 1000) + repeat 1 + finally (return (cons e values))) + '(1000 10 1 j 100)) +(equal (loop with e = 0 + for a from 10 above 0 + for b in '(1 2 3 4 5 6 7 8 9 10) + for c on '(j k l m n o p q r s) + for d = 100 then (1- d) + append (list a b (first c) d) into values + initially (setq e 1000) + repeat 2 + finally (return (cons e values))) + '(1000 10 1 j 100 9 2 k 99)) + +(equal (loop for a from 0 upto 100 by 2 + repeat 1000 + when (zerop (mod a 10)) collect a) + '(0 10 20 30 40 50 60 70 80 90 100)) + + +;; it +(let ((it '0)) + (equal (loop for a in '(nil x y nil z) when a collect it and collect it) + '(x 0 y 0 z 0))) + +(let ((it '0)) + (equal (loop for a in '(x nil y nil z nil) + if a collect it end + collect it) + '(X 0 0 Y 0 0 Z 0 0))) + + + +;; for-as-package +(subsetp '(cl:car cl:cdr cl:list) + (let (bag) + (loop for sym being the external-symbols of 'common-lisp + do (push sym bag)) + bag)) + +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((pkg (make-package "TB-FOO" :use nil)) + bag) + (and (null (loop for sym being the symbols of pkg do (push sym bag))) + (null bag)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((pkg (make-package "TB-FOO" :use nil)) + bag) + (and (null (loop for sym being the external-symbols of pkg + do (push sym bag))) + (null bag)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((pkg (make-package "TB-FOO" :use nil)) + bag) + (and (null (loop for sym being the present-symbols of pkg + do (push sym bag))) + (null bag)))) + + +(progn + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE") + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE"))) + bag0 bag) + (mapc #'(lambda (name) + (push (intern name "TB-BAR-TO-USE") bag0) + (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE")) + '("J" "K" "L")) + (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C")) + (mapc #'(lambda (name) + (push (intern name pkg) bag0) + (export (intern name pkg) pkg)) '("X" "Y" "Z")) + (loop for sym being the symbols of pkg do (push sym bag)) + (null (set-exclusive-or bag0 bag)))) +(progn + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE") + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE"))) + bag0 bag) + (mapc #'(lambda (name) + (push (intern name "TB-BAR-TO-USE") bag0) + (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE")) + '("J" "K" "L")) + (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C")) + (mapc #'(lambda (name) + (push (intern name pkg) bag0) + (export (intern name pkg) pkg)) '("X" "Y" "Z")) + (loop for sym being each symbols of pkg do (push sym bag)) + (null (set-exclusive-or bag0 bag)))) + + +(progn + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE") + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE"))) + bag0 bag) + (mapc #'(lambda (name) + (push (intern name "TB-BAR-TO-USE") bag0) + (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE")) + '("J" "K" "L")) + (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C")) + (mapc #'(lambda (name) + (push (intern name pkg) bag0) + (export (intern name pkg) pkg)) '("X" "Y" "Z")) + (loop for sym being the symbol of pkg do (push sym bag)) + (null (set-exclusive-or bag0 bag)))) +(progn + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE") + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE"))) + bag0 bag) + (mapc #'(lambda (name) + (push (intern name "TB-BAR-TO-USE") bag0) + (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE")) + '("J" "K" "L")) + (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C")) + (mapc #'(lambda (name) + (push (intern name pkg) bag0) + (export (intern name pkg) pkg)) '("X" "Y" "Z")) + (loop for sym being each symbol of pkg do (push sym bag)) + (null (set-exclusive-or bag0 bag)))) + + +(progn + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE") + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE"))) + bag0 bag) + (mapc #'(lambda (name) + (push (intern name "TB-BAR-TO-USE") bag0) + (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE")) + '("J" "K" "L")) + (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C")) + (mapc #'(lambda (name) + (push (intern name pkg) bag0) + (export (intern name pkg) pkg)) '("X" "Y" "Z")) + (loop for sym being the symbols in pkg do (push sym bag)) + (null (set-exclusive-or bag0 bag)))) +(progn + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE") + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE"))) + bag0 bag) + (mapc #'(lambda (name) + (push (intern name "TB-BAR-TO-USE") bag0) + (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE")) + '("J" "K" "L")) + (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C")) + (mapc #'(lambda (name) + (push (intern name pkg) bag0) + (export (intern name pkg) pkg)) '("X" "Y" "Z")) + (loop for sym being each symbols in pkg do (push sym bag)) + (null (set-exclusive-or bag0 bag)))) + + +(progn + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE") + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE"))) + bag0 bag) + (mapc #'(lambda (name) + (push (intern name "TB-BAR-TO-USE") bag0) + (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE")) + '("J" "K" "L")) + (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C")) + (mapc #'(lambda (name) + (push (intern name pkg) bag0) + (export (intern name pkg) pkg)) '("X" "Y" "Z")) + (loop for sym being the symbol in pkg do (push sym bag)) + (null (set-exclusive-or bag0 bag)))) +(progn + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE") + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE"))) + bag0 bag) + (mapc #'(lambda (name) + (push (intern name "TB-BAR-TO-USE") bag0) + (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE")) + '("J" "K" "L")) + (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C")) + (mapc #'(lambda (name) + (push (intern name pkg) bag0) + (export (intern name pkg) pkg)) '("X" "Y" "Z")) + (loop for sym being each symbol in pkg do (push sym bag)) + (null (set-exclusive-or bag0 bag)))) + + + +(progn + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE") + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE"))) + bag0 bag) + (mapc #'(lambda (name) + (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE")) + '("J" "K" "L")) + (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C")) + (mapc #'(lambda (name) + (push (intern name pkg) bag0) + (export (intern name pkg) pkg)) '("X" "Y" "Z")) + (loop for sym being the present-symbols of pkg do (push sym bag)) + (null (set-exclusive-or bag0 bag)))) +(progn + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE") + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE"))) + bag0 bag) + (mapc #'(lambda (name) + (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE")) + '("J" "K" "L")) + (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C")) + (mapc #'(lambda (name) + (push (intern name pkg) bag0) + (export (intern name pkg) pkg)) '("X" "Y" "Z")) + (loop for sym being each present-symbols of pkg do (push sym bag)) + (null (set-exclusive-or bag0 bag)))) + + +(progn + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE") + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE"))) + bag0 bag) + (mapc #'(lambda (name) + (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE")) + '("J" "K" "L")) + (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C")) + (mapc #'(lambda (name) + (push (intern name pkg) bag0) + (export (intern name pkg) pkg)) '("X" "Y" "Z")) + (loop for sym being the present-symbol of pkg do (push sym bag)) + (null (set-exclusive-or bag0 bag)))) +(progn + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE") + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE"))) + bag0 bag) + (mapc #'(lambda (name) + (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE")) + '("J" "K" "L")) + (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C")) + (mapc #'(lambda (name) + (push (intern name pkg) bag0) + (export (intern name pkg) pkg)) '("X" "Y" "Z")) + (loop for sym being each present-symbol of pkg do (push sym bag)) + (null (set-exclusive-or bag0 bag)))) + + +(progn + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE") + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE"))) + bag0 bag) + (mapc #'(lambda (name) + (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE")) + '("J" "K" "L")) + (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C")) + (mapc #'(lambda (name) + (push (intern name pkg) bag0) + (export (intern name pkg) pkg)) '("X" "Y" "Z")) + (loop for sym being the present-symbols in pkg do (push sym bag)) + (null (set-exclusive-or bag0 bag)))) +(progn + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE") + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE"))) + bag0 bag) + (mapc #'(lambda (name) + (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE")) + '("J" "K" "L")) + (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C")) + (mapc #'(lambda (name) + (push (intern name pkg) bag0) + (export (intern name pkg) pkg)) '("X" "Y" "Z")) + (loop for sym being each present-symbols in pkg do (push sym bag)) + (null (set-exclusive-or bag0 bag)))) + + +(progn + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE") + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE"))) + bag0 bag) + (mapc #'(lambda (name) + (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE")) + '("J" "K" "L")) + (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C")) + (mapc #'(lambda (name) + (push (intern name pkg) bag0) + (export (intern name pkg) pkg)) '("X" "Y" "Z")) + (loop for sym being the present-symbol in pkg do (push sym bag)) + (null (set-exclusive-or bag0 bag)))) +(progn + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE") + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE"))) + bag0 bag) + (mapc #'(lambda (name) + (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE")) + '("J" "K" "L")) + (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C")) + (mapc #'(lambda (name) + (push (intern name pkg) bag0) + (export (intern name pkg) pkg)) '("X" "Y" "Z")) + (loop for sym being each present-symbol in pkg do (push sym bag)) + (null (set-exclusive-or bag0 bag)))) + + + +(progn + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE") + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE"))) + bag0 bag) + (mapc #'(lambda (name) + (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE")) + '("J" "K" "L")) + (mapc #'(lambda (name) (intern name pkg)) '("A" "B" "C")) + (mapc #'(lambda (name) + (push (intern name pkg) bag0) + (export (intern name pkg) pkg)) '("X" "Y" "Z")) + (loop for sym being the external-symbols of pkg do (push sym bag)) + (null (set-exclusive-or bag0 bag)))) +(progn + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE") + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE"))) + bag0 bag) + (mapc #'(lambda (name) + (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE")) + '("J" "K" "L")) + (mapc #'(lambda (name) (intern name pkg)) '("A" "B" "C")) + (mapc #'(lambda (name) + (push (intern name pkg) bag0) + (export (intern name pkg) pkg)) '("X" "Y" "Z")) + (loop for sym being each external-symbols of pkg do (push sym bag)) + (null (set-exclusive-or bag0 bag)))) +(progn + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE") + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE"))) + bag0 bag) + (mapc #'(lambda (name) + (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE")) + '("J" "K" "L")) + (mapc #'(lambda (name) (intern name pkg)) '("A" "B" "C")) + (mapc #'(lambda (name) + (push (intern name pkg) bag0) + (export (intern name pkg) pkg)) '("X" "Y" "Z")) + (loop for sym being the external-symbol of pkg do (push sym bag)) + (null (set-exclusive-or bag0 bag)))) +(progn + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE") + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE"))) + bag0 bag) + (mapc #'(lambda (name) + (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE")) + '("J" "K" "L")) + (mapc #'(lambda (name) (intern name pkg)) '("A" "B" "C")) + (mapc #'(lambda (name) + (push (intern name pkg) bag0) + (export (intern name pkg) pkg)) '("X" "Y" "Z")) + (loop for sym being each external-symbol of pkg do (push sym bag)) + (null (set-exclusive-or bag0 bag)))) +(progn + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE") + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE"))) + bag0 bag) + (mapc #'(lambda (name) + (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE")) + '("J" "K" "L")) + (mapc #'(lambda (name) (intern name pkg)) '("A" "B" "C")) + (mapc #'(lambda (name) + (push (intern name pkg) bag0) + (export (intern name pkg) pkg)) '("X" "Y" "Z")) + (loop for sym being the external-symbols in pkg do (push sym bag)) + (null (set-exclusive-or bag0 bag)))) +(progn + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE") + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE"))) + bag0 bag) + (mapc #'(lambda (name) + (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE")) + '("J" "K" "L")) + (mapc #'(lambda (name) (intern name pkg)) '("A" "B" "C")) + (mapc #'(lambda (name) + (push (intern name pkg) bag0) + (export (intern name pkg) pkg)) '("X" "Y" "Z")) + (loop for sym being each external-symbols in pkg do (push sym bag)) + (null (set-exclusive-or bag0 bag)))) +(progn + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE") + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE"))) + bag0 bag) + (mapc #'(lambda (name) + (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE")) + '("J" "K" "L")) + (mapc #'(lambda (name) (intern name pkg)) '("A" "B" "C")) + (mapc #'(lambda (name) + (push (intern name pkg) bag0) + (export (intern name pkg) pkg)) '("X" "Y" "Z")) + (loop for sym being the external-symbol in pkg do (push sym bag)) + (null (set-exclusive-or bag0 bag)))) +(progn + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE") + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE"))) + bag0 bag) + (mapc #'(lambda (name) + (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE")) + '("J" "K" "L")) + (mapc #'(lambda (name) (intern name pkg)) '("A" "B" "C")) + (mapc #'(lambda (name) + (push (intern name pkg) bag0) + (export (intern name pkg) pkg)) '("X" "Y" "Z")) + (loop for sym being each external-symbol in pkg do (push sym bag)) + (null (set-exclusive-or bag0 bag)))) + +(progn + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE") + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE"))) + bag0 bag) + (mapc #'(lambda (name) + (push (intern name "TB-BAR-TO-USE") bag0) + (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE")) + '("J" "K" "L")) + (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C")) + (mapc #'(lambda (name) + (push (intern name pkg) bag0) + (export (intern name pkg) pkg)) '("X" "Y" "Z")) + (loop as sym being the symbols of pkg do (push sym bag)) + (null (set-exclusive-or bag0 bag)))) +(progn + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE") + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE"))) + bag0 bag) + (mapc #'(lambda (name) + (push (intern name "TB-BAR-TO-USE") bag0) + (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE")) + '("J" "K" "L")) + (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C")) + (mapc #'(lambda (name) + (push (intern name pkg) bag0) + (export (intern name pkg) pkg)) '("X" "Y" "Z")) + (loop as sym being each symbols of pkg do (push sym bag)) + (null (set-exclusive-or bag0 bag)))) + + +(progn + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE") + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE"))) + bag0 bag) + (mapc #'(lambda (name) + (push (intern name "TB-BAR-TO-USE") bag0) + (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE")) + '("J" "K" "L")) + (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C")) + (mapc #'(lambda (name) + (push (intern name pkg) bag0) + (export (intern name pkg) pkg)) '("X" "Y" "Z")) + (loop as sym being the symbol of pkg do (push sym bag)) + (null (set-exclusive-or bag0 bag)))) +(progn + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE") + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE"))) + bag0 bag) + (mapc #'(lambda (name) + (push (intern name "TB-BAR-TO-USE") bag0) + (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE")) + '("J" "K" "L")) + (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C")) + (mapc #'(lambda (name) + (push (intern name pkg) bag0) + (export (intern name pkg) pkg)) '("X" "Y" "Z")) + (loop as sym being each symbol of pkg do (push sym bag)) + (null (set-exclusive-or bag0 bag)))) + + +(progn + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE") + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE"))) + bag0 bag) + (mapc #'(lambda (name) + (push (intern name "TB-BAR-TO-USE") bag0) + (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE")) + '("J" "K" "L")) + (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C")) + (mapc #'(lambda (name) + (push (intern name pkg) bag0) + (export (intern name pkg) pkg)) '("X" "Y" "Z")) + (loop as sym being the symbols in pkg do (push sym bag)) + (null (set-exclusive-or bag0 bag)))) +(progn + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE") + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE"))) + bag0 bag) + (mapc #'(lambda (name) + (push (intern name "TB-BAR-TO-USE") bag0) + (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE")) + '("J" "K" "L")) + (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C")) + (mapc #'(lambda (name) + (push (intern name pkg) bag0) + (export (intern name pkg) pkg)) '("X" "Y" "Z")) + (loop as sym being each symbols in pkg do (push sym bag)) + (null (set-exclusive-or bag0 bag)))) + + +(progn + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE") + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE"))) + bag0 bag) + (mapc #'(lambda (name) + (push (intern name "TB-BAR-TO-USE") bag0) + (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE")) + '("J" "K" "L")) + (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C")) + (mapc #'(lambda (name) + (push (intern name pkg) bag0) + (export (intern name pkg) pkg)) '("X" "Y" "Z")) + (loop as sym being the symbol in pkg do (push sym bag)) + (null (set-exclusive-or bag0 bag)))) +(progn + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE") + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE"))) + bag0 bag) + (mapc #'(lambda (name) + (push (intern name "TB-BAR-TO-USE") bag0) + (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE")) + '("J" "K" "L")) + (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C")) + (mapc #'(lambda (name) + (push (intern name pkg) bag0) + (export (intern name pkg) pkg)) '("X" "Y" "Z")) + (loop as sym being each symbol in pkg do (push sym bag)) + (null (set-exclusive-or bag0 bag)))) + + + +(progn + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE") + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE"))) + bag0 bag) + (mapc #'(lambda (name) + (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE")) + '("J" "K" "L")) + (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C")) + (mapc #'(lambda (name) + (push (intern name pkg) bag0) + (export (intern name pkg) pkg)) '("X" "Y" "Z")) + (loop as sym being the present-symbols of pkg do (push sym bag)) + (null (set-exclusive-or bag0 bag)))) +(progn + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE") + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE"))) + bag0 bag) + (mapc #'(lambda (name) + (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE")) + '("J" "K" "L")) + (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C")) + (mapc #'(lambda (name) + (push (intern name pkg) bag0) + (export (intern name pkg) pkg)) '("X" "Y" "Z")) + (loop as sym being each present-symbols of pkg do (push sym bag)) + (null (set-exclusive-or bag0 bag)))) + + +(progn + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE") + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE"))) + bag0 bag) + (mapc #'(lambda (name) + (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE")) + '("J" "K" "L")) + (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C")) + (mapc #'(lambda (name) + (push (intern name pkg) bag0) + (export (intern name pkg) pkg)) '("X" "Y" "Z")) + (loop as sym being the present-symbol of pkg do (push sym bag)) + (null (set-exclusive-or bag0 bag)))) +(progn + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE") + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE"))) + bag0 bag) + (mapc #'(lambda (name) + (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE")) + '("J" "K" "L")) + (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C")) + (mapc #'(lambda (name) + (push (intern name pkg) bag0) + (export (intern name pkg) pkg)) '("X" "Y" "Z")) + (loop as sym being each present-symbol of pkg do (push sym bag)) + (null (set-exclusive-or bag0 bag)))) + + +(progn + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE") + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE"))) + bag0 bag) + (mapc #'(lambda (name) + (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE")) + '("J" "K" "L")) + (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C")) + (mapc #'(lambda (name) + (push (intern name pkg) bag0) + (export (intern name pkg) pkg)) '("X" "Y" "Z")) + (loop as sym being the present-symbols in pkg do (push sym bag)) + (null (set-exclusive-or bag0 bag)))) +(progn + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE") + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE"))) + bag0 bag) + (mapc #'(lambda (name) + (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE")) + '("J" "K" "L")) + (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C")) + (mapc #'(lambda (name) + (push (intern name pkg) bag0) + (export (intern name pkg) pkg)) '("X" "Y" "Z")) + (loop as sym being each present-symbols in pkg do (push sym bag)) + (null (set-exclusive-or bag0 bag)))) + + +(progn + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE") + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE"))) + bag0 bag) + (mapc #'(lambda (name) + (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE")) + '("J" "K" "L")) + (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C")) + (mapc #'(lambda (name) + (push (intern name pkg) bag0) + (export (intern name pkg) pkg)) '("X" "Y" "Z")) + (loop as sym being the present-symbol in pkg do (push sym bag)) + (null (set-exclusive-or bag0 bag)))) +(progn + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE") + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE"))) + bag0 bag) + (mapc #'(lambda (name) + (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE")) + '("J" "K" "L")) + (mapc #'(lambda (name) (push (intern name pkg) bag0)) '("A" "B" "C")) + (mapc #'(lambda (name) + (push (intern name pkg) bag0) + (export (intern name pkg) pkg)) '("X" "Y" "Z")) + (loop as sym being each present-symbol in pkg do (push sym bag)) + (null (set-exclusive-or bag0 bag)))) + + + +(progn + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE") + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE"))) + bag0 bag) + (mapc #'(lambda (name) + (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE")) + '("J" "K" "L")) + (mapc #'(lambda (name) (intern name pkg)) '("A" "B" "C")) + (mapc #'(lambda (name) + (push (intern name pkg) bag0) + (export (intern name pkg) pkg)) '("X" "Y" "Z")) + (loop as sym being the external-symbols of pkg do (push sym bag)) + (null (set-exclusive-or bag0 bag)))) +(progn + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE") + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE"))) + bag0 bag) + (mapc #'(lambda (name) + (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE")) + '("J" "K" "L")) + (mapc #'(lambda (name) (intern name pkg)) '("A" "B" "C")) + (mapc #'(lambda (name) + (push (intern name pkg) bag0) + (export (intern name pkg) pkg)) '("X" "Y" "Z")) + (loop as sym being each external-symbols of pkg do (push sym bag)) + (null (set-exclusive-or bag0 bag)))) +(progn + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE") + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE"))) + bag0 bag) + (mapc #'(lambda (name) + (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE")) + '("J" "K" "L")) + (mapc #'(lambda (name) (intern name pkg)) '("A" "B" "C")) + (mapc #'(lambda (name) + (push (intern name pkg) bag0) + (export (intern name pkg) pkg)) '("X" "Y" "Z")) + (loop as sym being the external-symbol of pkg do (push sym bag)) + (null (set-exclusive-or bag0 bag)))) +(progn + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE") + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE"))) + bag0 bag) + (mapc #'(lambda (name) + (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE")) + '("J" "K" "L")) + (mapc #'(lambda (name) (intern name pkg)) '("A" "B" "C")) + (mapc #'(lambda (name) + (push (intern name pkg) bag0) + (export (intern name pkg) pkg)) '("X" "Y" "Z")) + (loop as sym being each external-symbol of pkg do (push sym bag)) + (null (set-exclusive-or bag0 bag)))) +(progn + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE") + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE"))) + bag0 bag) + (mapc #'(lambda (name) + (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE")) + '("J" "K" "L")) + (mapc #'(lambda (name) (intern name pkg)) '("A" "B" "C")) + (mapc #'(lambda (name) + (push (intern name pkg) bag0) + (export (intern name pkg) pkg)) '("X" "Y" "Z")) + (loop as sym being the external-symbols in pkg do (push sym bag)) + (null (set-exclusive-or bag0 bag)))) +(progn + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE") + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE"))) + bag0 bag) + (mapc #'(lambda (name) + (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE")) + '("J" "K" "L")) + (mapc #'(lambda (name) (intern name pkg)) '("A" "B" "C")) + (mapc #'(lambda (name) + (push (intern name pkg) bag0) + (export (intern name pkg) pkg)) '("X" "Y" "Z")) + (loop as sym being each external-symbols in pkg do (push sym bag)) + (null (set-exclusive-or bag0 bag)))) +(progn + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE") + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE"))) + bag0 bag) + (mapc #'(lambda (name) + (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE")) + '("J" "K" "L")) + (mapc #'(lambda (name) (intern name pkg)) '("A" "B" "C")) + (mapc #'(lambda (name) + (push (intern name pkg) bag0) + (export (intern name pkg) pkg)) '("X" "Y" "Z")) + (loop as sym being the external-symbol in pkg do (push sym bag)) + (null (set-exclusive-or bag0 bag)))) +(progn + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE") + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE"))) + bag0 bag) + (mapc #'(lambda (name) + (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE")) + '("J" "K" "L")) + (mapc #'(lambda (name) (intern name pkg)) '("A" "B" "C")) + (mapc #'(lambda (name) + (push (intern name pkg) bag0) + (export (intern name pkg) pkg)) '("X" "Y" "Z")) + (loop as sym being each external-symbol in pkg do (push sym bag)) + (null (set-exclusive-or bag0 bag)))) +(eq t (loop for symbol being the symbols of 'cl finally (return t))) +(progn + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE") + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE"))) + bag0 bag) + (mapc #'(lambda (name) + (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE")) + '("J" "K" "L")) + (mapc #'(lambda (name) (intern name pkg)) '("A" "B" "C")) + (mapc #'(lambda (name) + (push (intern name pkg) bag0) + (export (intern name pkg) pkg)) '("X" "Y" "Z")) + (loop as sym of-type symbol being the external-symbols of pkg + do (push sym bag)) + (null (set-exclusive-or bag0 bag)))) +(progn + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE") + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE"))) + bag0 bag) + (mapc #'(lambda (name) + (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE")) + '("J" "K" "L")) + (mapc #'(lambda (name) (intern name pkg)) '("A" "B" "C")) + (mapc #'(lambda (name) + (push (intern name pkg) bag0) + (export (intern name pkg) pkg)) '("X" "Y" "Z")) + (loop as sym t being the external-symbols of pkg + do (push sym bag)) + (null (set-exclusive-or bag0 bag)))) +(progn + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE") + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((pkg (make-package "TB-FOO" :use '("TB-BAR-TO-USE"))) + bag0 bag) + (mapc #'(lambda (name) + (export (intern name "TB-BAR-TO-USE") "TB-BAR-TO-USE")) + '("J" "K" "L")) + (mapc #'(lambda (name) (intern name pkg)) '("A" "B" "C")) + (mapc #'(lambda (name) + (push (intern name pkg) bag0) + (export (intern name pkg) pkg)) '("X" "Y" "Z")) + (loop as sym of-type t being the external-symbols of pkg + do (push sym bag)) + (null (set-exclusive-or bag0 bag)))) + +(eq t (loop for c in '(#\A #\S #\Z #\a) + always (eq t (loop for s in + (loop for s being the external-symbols of 'cl + when (char= c (char (symbol-name s) 0)) + collect s) + always (char= c (char (symbol-name s) 0)))))) + diff --git a/Sacla/tests/must-loop.patch b/Sacla/tests/must-loop.patch new file mode 100644 index 0000000..51b53b8 --- /dev/null +++ b/Sacla/tests/must-loop.patch @@ -0,0 +1,13 @@ +*** sacla/lisp/test/must-loop.lisp 2004-08-03 08:34:55.000000000 +0200 +--- CLISP/clisp-20040712/sacla-tests/must-loop.lisp 2004-08-06 02:49:13.000000000 +0200 +*************** +*** 1195,1200 **** +--- 1195,1202 ---- + do (incf x) + initially (incf x) (incf x) finally (incf x) (return (incf x))) + 7) ++ #-CLISP ; unfounded expectations about the value of for-as iteration variables ++ ; in INITIALLY and FINALLY clauses + (equal (let (val) (loop for a downto 3 from 100 + for b in '(x y z) and c = 50 then (1+ c) + initially (setq val (list a b c)) diff --git a/Sacla/tests/must-package.lisp b/Sacla/tests/must-package.lisp new file mode 100644 index 0000000..192c570 --- /dev/null +++ b/Sacla/tests/must-package.lisp @@ -0,0 +1,2266 @@ +;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp> +;; ALL RIGHTS RESERVED. +;; +;; $Id: must-package.lisp,v 1.12 2004/08/09 02:49:54 yuji Exp $ +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; * Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; * Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + +;; list-all-packages +(listp (list-all-packages)) +(find "COMMON-LISP" (mapcar #'package-name (list-all-packages)) :test #'string=) +(find "COMMON-LISP-USER" (mapcar #'package-name (list-all-packages)) :test #'string=) +(find "KEYWORD" (mapcar #'package-name (list-all-packages)) :test #'string=) +(every #'packagep (list-all-packages)) + + +;; find-package +(packagep (find-package "COMMON-LISP")) +(packagep (find-package "CL")) +(packagep (find-package "COMMON-LISP-USER")) +(packagep (find-package "CL-USER")) +(packagep (find-package "KEYWORD")) +(let ((cl (find-package "COMMON-LISP"))) + (eq cl (find-package cl))) +(eq (find-package "CL") (find-package "COMMON-LISP")) +(eq (find-package 'cl) (find-package "COMMON-LISP")) +(eq (find-package 'cl) (find-package 'common-lisp)) +(let ((name "NO-SUCH-PACKAGE")) + (when (find-package name) + (delete-package name)) + (not (find-package name))) +(= (length (multiple-value-list (find-package "CL"))) 1) +(= (length (multiple-value-list (find-package "NO-SUCH-PACKAGE"))) 1) +(packagep (find-package (find-package (find-package "KEYWORD")))) + + +;; packagep +(every (complement #'packagep) '(nil a b "CL" "KEYWORD" (a) cl common-lisp-user)) + +;; make-package +(progn (when (find-package "a") (delete-package "a")) + (and (packagep (make-package #\a)) (delete-package "a"))) +(progn (when (find-package "a") (delete-package "a")) + (and (packagep (make-package '|a|)) (delete-package "a"))) +(progn (when (find-package "a") (delete-package "a")) + (and (packagep (make-package "a")) (delete-package "a"))) +(progn (when (find-package "a") (delete-package "a")) + (and (packagep (make-package "a" :use nil)) (delete-package "a"))) +(progn (when (find-package "a") (delete-package "a")) + (and (packagep (make-package "a" :use '(cl))) (delete-package "a"))) +(progn (when (find-package "a") (delete-package "a")) + (and (packagep (make-package "a" :use '(cl) :nicknames '("b"))) + (delete-package "b"))) +(progn (when (find-package "a") (delete-package "a")) + (and (packagep (make-package "a" :use '(cl) :nicknames '("b" "c"))) + (delete-package "c"))) +(progn (when (find-package "a") (delete-package "a")) + (and (packagep (make-package "a" :use '(cl) :nicknames '(#\b "c"))) + (delete-package "b"))) +(progn (when (find-package "a") (delete-package "a")) + (and (packagep (make-package "a" :use '(cl) :nicknames '(|b| "c"))) + (delete-package "b"))) +(HANDLER-CASE + (PROGN + (WHEN (FIND-PACKAGE "a") (DELETE-PACKAGE "a")) + (WHEN (FIND-PACKAGE "b") (DELETE-PACKAGE "b")) + (AND (PACKAGEP (MAKE-PACKAGE "b" :USE '(CL))) + (PACKAGEP (MAKE-PACKAGE "a" :USE '(CL) :NICKNAMES '(|b| "c"))))) + (ERROR NIL T) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE + (PROGN + (WHEN (FIND-PACKAGE "a") (DELETE-PACKAGE "a")) + (WHEN (FIND-PACKAGE "b") (DELETE-PACKAGE "b")) + (AND (PACKAGEP (MAKE-PACKAGE "a" :USE '(CL))) + (PACKAGEP (MAKE-PACKAGE "a" :USE '(CL) :NICKNAMES '(|b| "c"))))) + (ERROR NIL T) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE + (PROGN + (WHEN (FIND-PACKAGE "a") (DELETE-PACKAGE "a")) + (WHEN (FIND-PACKAGE "d") (DELETE-PACKAGE "b")) + (AND (PACKAGEP (MAKE-PACKAGE "a" :USE '(CL) :NICKNAMES '("b" "c"))) + (PACKAGEP (MAKE-PACKAGE "d" :USE '(CL) :NICKNAMES '("c"))))) + (ERROR NIL T) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE + (PROGN + (WHEN (FIND-PACKAGE "TB-FOO") (DELETE-PACKAGE "TB-FOO")) + (WHEN (FIND-PACKAGE "TB-BAR-TO-USE") + (MAPCAN #'DELETE-PACKAGE (PACKAGE-USED-BY-LIST "TB-BAR-TO-USE")) + (DELETE-PACKAGE "TB-BAR-TO-USE")) + (AND (PACKAGEP (MAKE-PACKAGE "TB-BAR-TO-USE" :USE NIL)) + (EXPORT (INTERN "CAR" 'TB-BAR-TO-USE) 'TB-BAR-TO-USE) + (MAKE-PACKAGE "TB-FOO" :USE '(CL "TB-BAR-TO-USE")))) + (ERROR NIL T) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + + + +;; package-name +(string= (package-name "COMMON-LISP") "COMMON-LISP") +(string= (package-name 'common-lisp) "COMMON-LISP") +(string= (package-name (find-package 'common-lisp)) "COMMON-LISP") +(string= (package-name "CL") "COMMON-LISP") +(string= (package-name 'cl) "COMMON-LISP") +(string= (package-name (find-package 'cl)) "COMMON-LISP") +(let ((designator-list + (list 'cl 'common-lisp "CL" "COMMON-LISP" (find-package 'cl) + 'cl-user 'common-lisp-user "CL-USER" "COMMON-LISP-USER" + (find-package 'cl-user) + 'keyword "KEYWORD" (find-package 'keyword)))) + (every #'stringp (mapcar #'package-name designator-list))) +(every #'stringp (mapcar #'package-name (list-all-packages))) +(let* ((name "TB-FOO") + (package (or (find-package name) (make-package name :use nil)))) + (and (delete-package name) + (not (find-package name)) + (null (package-name package)))) + + +;; package-nicknames +(member "CL" (package-nicknames "COMMON-LISP") :test #'string=) +(member "CL" (package-nicknames 'common-lisp) :test #'string=) +(member "CL" (package-nicknames (find-package 'common-lisp)) :test #'string=) +(member "CL" (package-nicknames "CL") :test #'string=) +(member "CL" (package-nicknames 'cl) :test #'string=) +(member "CL" (package-nicknames (find-package 'cl)) :test #'string=) +(let ((name 'test-foo) + (nicknames '(test-foo-nickname1 test-foo-nickname2 test-foo-nickname3))) + (dolist (name (cons name nicknames)) + (when (find-package name) (delete-package name))) + (every #'stringp (package-nicknames (make-package name :nicknames nicknames)))) +(every #'stringp (mapcan #'(lambda (package) + (copy-list (package-nicknames package))) + (list-all-packages))) +(progn + (when (find-package 'test-foo) (delete-package 'test-foo)) + (null (set-difference + (package-nicknames (make-package 'test-foo + :nicknames '("TB-FOO" "test-foo"))) + '("TB-FOO" "test-foo") + :test #'string=))) +(let ((designator-list + (list 'cl 'common-lisp "CL" "COMMON-LISP" (find-package 'cl) + 'cl-user 'common-lisp-user "CL-USER" "COMMON-LISP-USER" + (find-package 'cl-user) + 'keyword "KEYWORD" (find-package 'keyword)))) + (every #'stringp (mapcan #'(lambda (designator) + (copy-list (package-nicknames designator))) + designator-list))) + + +;; package-shadowing-symbols +(every #'listp (mapcar #'package-shadowing-symbols (list-all-packages))) +(every #'symbolp (mapcan #'(lambda (package) + (copy-list (package-shadowing-symbols package))) + (list-all-packages))) +(listp (package-shadowing-symbols 'cl)) +(listp (package-shadowing-symbols "CL-USER")) +(listp (package-shadowing-symbols "COMMON-LISP")) +(listp (package-shadowing-symbols (find-package 'keyword))) +(let ((designator-list + (list 'cl 'common-lisp "CL" "COMMON-LISP" (find-package 'cl) + 'cl-user 'common-lisp-user "CL-USER" "COMMON-LISP-USER" + (find-package 'cl-user) + 'keyword "KEYWORD" (find-package 'keyword)))) + (every #'symbolp (mapcan #'(lambda (designator) + (copy-list (package-shadowing-symbols designator))) + designator-list))) + + +;; package-use-list +(every #'listp (mapcar #'package-use-list (list-all-packages))) +(every #'packagep (mapcan #'(lambda (package) + (copy-list (package-use-list package))) + (list-all-packages))) +(listp (package-use-list 'cl)) +(listp (package-use-list "CL-USER")) +(listp (package-use-list "COMMON-LISP")) +(listp (package-use-list (find-package 'keyword))) +(let ((designator-list + (list 'cl 'common-lisp "CL" "COMMON-LISP" (find-package 'cl) + 'cl-user 'common-lisp-user "CL-USER" "COMMON-LISP-USER" + (find-package 'cl-user) + 'keyword "KEYWORD" (find-package 'keyword)))) + (every #'packagep (mapcan #'(lambda (designator) + (copy-list (package-use-list designator))) + designator-list))) + + +;; package-used-by-list +(every #'listp (mapcar #'package-used-by-list (list-all-packages))) +(every #'packagep (mapcan #'(lambda (package) + (copy-list (package-used-by-list package))) + (list-all-packages))) +(listp (package-used-by-list 'cl)) +(listp (package-used-by-list "CL-USER")) +(listp (package-used-by-list "COMMON-LISP")) +(listp (package-used-by-list (find-package 'keyword))) +(let ((designator-list + (list 'cl 'common-lisp "CL" "COMMON-LISP" (find-package 'cl) + 'cl-user 'common-lisp-user "CL-USER" "COMMON-LISP-USER" + (find-package 'cl-user) + 'keyword "KEYWORD" (find-package 'keyword)))) + (every #'packagep (mapcan #'(lambda (designator) + (copy-list (package-used-by-list designator))) + designator-list))) + + +;; rename-package +(progn + (mapcar #'(lambda (package) + (when (find-package package) (delete-package package))) + '("TB-FOO" "TB-FOO-RENAMED")) + (let* ((package (make-package "TB-FOO" :use nil))) + (and (eq (rename-package "TB-FOO" "TB-FOO-RENAMED") package) + (eq (find-package "TB-FOO-RENAMED") package)))) +(progn + (mapcar #'(lambda (package) + (when (find-package package) (delete-package package))) + '("TB-FOO-0" "TB-FOO-1" "TB-FOO-2" "TB-FOO-3" "TB-FOO-4")) + (let* ((package (make-package "TB-FOO-0" :use nil))) + (and (eq (rename-package "TB-FOO-0" "TB-FOO-1") package) + (eq (rename-package "TB-FOO-1" "TB-FOO-2") package) + (eq (rename-package "TB-FOO-2" "TB-FOO-3") package) + (eq (rename-package "TB-FOO-3" "TB-FOO-4") package) + (eq (find-package "TB-FOO-4") package)))) +(progn + (mapcar #'(lambda (package) + (when (find-package package) (delete-package package))) + '("TB-FOO-0" "TB-FOO-1" "TB-FOO-2" "TB-FOO-3" "TB-FOO-4")) + (let* ((package (make-package "TB-FOO-0" :use nil))) + (and (eq (rename-package (find-package "TB-FOO-0") "TB-FOO-1") package) + (eq (rename-package (find-package "TB-FOO-1") "TB-FOO-2") package) + (eq (rename-package (find-package "TB-FOO-2") "TB-FOO-3") package) + (eq (rename-package (find-package "TB-FOO-3") "TB-FOO-4") package) + (eq (find-package "TB-FOO-4") package)))) +(progn + (mapcar #'(lambda (package) + (when (find-package package) (delete-package package))) + '(#\a #\b)) + (let ((package (make-package #\a :use nil))) + (and (eq (rename-package #\a #\b) package) + (eq (find-package #\b) package) + (string= (package-name package) #\b)))) +(let ((name-list (list #\a 'b "TB-FOO-0" "TB-FOO-1" 'test-foo-2))) + (mapcar #'(lambda (package) + (when (find-package package) (delete-package package))) + name-list) + (let* ((old (pop name-list)) + (package (make-package old :use nil))) + (dolist (new name-list t) + (unless (eq (rename-package old new) package) + (return nil)) + (setq old new)))) +(progn + (mapcar #'(lambda (package) + (when (find-package package) (delete-package package))) + '("TB-FOO" "TB-FOO-RENAMED" + "TB-FOO-NICKNAME-0" "TB-FOO-NICKNAME-1")) + (let* ((package (make-package "TB-FOO" + :use nil + :nicknames '("TB-FOO-NICKNAME-0" + "TB-FOO-NICKNAME-1")))) + (and (eq (rename-package "TB-FOO" "TB-FOO-RENAMED") package) + (eq (find-package "TB-FOO-RENAMED") package) + (null (set-difference (package-nicknames "TB-FOO-RENAMED") + '("TB-FOO-NICKNAME-0" "TB-FOO-NICKNAME-1") + :test #'string=))))) +(progn + (mapcar #'(lambda (package) + (when (find-package package) (delete-package package))) + '("TB-FOO-0" "TB-FOO-1" "TB-FOO-2" + "TB-FOO-3" "TB-FOO-4" "TB-FOO-5")) + (let* ((package (make-package "TB-FOO-0" + :use nil + :nicknames '("TB-FOO-1" "TB-FOO-2")))) + (and (eq (rename-package package "TB-FOO-3" '("TB-FOO-4" "TB-FOO-5")) + package) + (eq (find-package "TB-FOO-3") package) + (eq (find-package "TB-FOO-4") package) + (eq (find-package "TB-FOO-5") package) + (not (every #'find-package + '("TB-FOO-0" "TB-FOO-1" "TB-FOO-2")))))) +(progn + (mapcar #'(lambda (package) + (when (find-package package) (delete-package package))) + '("TB-FOO-0" "TB-FOO-1" "TB-FOO-2")) + (let* ((package (make-package "TB-FOO-0" :use nil :nicknames '("TB-FOO-1")))) + (eq (rename-package package "TB-FOO-1" '("TB-FOO-2")) package))) +(progn + (mapcar #'(lambda (package) + (when (find-package package) (delete-package package))) + '("TB-FOO-0" "TB-FOO-1" "TB-FOO-2" + "TB-FOO-3" "TB-FOO-4" "TB-FOO-5")) + (let* ((package (make-package "TB-FOO-0" :use nil :nicknames '("TB-FOO-1")))) + (and (eq (rename-package package "TB-FOO-1" '("TB-FOO-2")) package) + (eq (rename-package package "TB-FOO-2" '("TB-FOO-3")) package) + (eq (rename-package package "TB-FOO-3" '("TB-FOO-4")) package) + (eq (rename-package package "TB-FOO-4" '("TB-FOO-5")) package) + (eq (rename-package package "TB-FOO-5" '("TB-FOO-0")) package) + (eq (find-package 'test-foo-5) (find-package 'test-foo-0))))) +(progn + (mapcar #'(lambda (package) + (when (find-package package) (delete-package package))) + '("TB-FOO-0" "TB-FOO-1" "TB-FOO-2")) + (let* ((package (make-package "TB-FOO-0" :use nil + :nicknames '("TB-FOO-1" "TB-FOO-2")))) + (and (eq (rename-package package "TB-FOO-2" '("TB-FOO-3" "TB-FOO-1")) + package) + (string= (package-name package) "TB-FOO-2") + (null (set-difference (package-nicknames package) + '("TB-FOO-3" "TB-FOO-1") + :test #'string=))))) +(progn + (mapcar #'(lambda (package) + (when (find-package package) (delete-package package))) + '("TB-FOO-0" "TB-FOO-1" "TB-FOO-2")) + (let* ((package (make-package "TB-FOO-0" :use nil + :nicknames '("TB-FOO-1" "TB-FOO-2")))) + (and (eq (rename-package package "TB-FOO-3") package) + (string= (package-name package) "TB-FOO-3") + (null (package-nicknames package))))) + + +;; find-symbol +(equal (multiple-value-list (find-symbol "CAR" "CL")) '(cl:car :EXTERNAL)) +(equal (multiple-value-list (find-symbol "CDR" "CL")) '(cl:cdr :EXTERNAL)) +(equal (multiple-value-list (find-symbol "CDR" 'cl)) '(cl:cdr :EXTERNAL)) +(equal (multiple-value-list (find-symbol "CDR" (find-package 'cl))) + '(cl:cdr :EXTERNAL)) +(equal (multiple-value-list (find-symbol "NIL" "CL")) '(nil :EXTERNAL)) +(let ((*package* (find-package 'cl))) + (equal (multiple-value-list (find-symbol "CDR")) '(cl:cdr :EXTERNAL))) +(progn + (when (find-package "A") (delete-package "A")) + (make-package "A" :use nil) + (equal (multiple-value-list (find-symbol "A" #\A)) '(nil nil))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (make-package "TB-FOO" :use nil) + (equal (multiple-value-list (find-symbol "A" "TB-FOO")) '(nil nil))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (make-package "TB-FOO" :use nil) + (multiple-value-bind (symbol0 status0) (intern "A" "TB-FOO") + (multiple-value-bind (symbol1 status1) (find-symbol "A" "TB-FOO") + (and (eq symbol0 symbol1) + (null status0) + (eq status1 :internal))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (make-package "TB-FOO" :use '("CL")) + (equal (multiple-value-list (find-symbol "CAR" "TB-FOO")) + '(cl:car :inherited))) +(do-external-symbols (symbol "CL" t) + (multiple-value-bind (symbol-found status) + (find-symbol (symbol-name symbol) "COMMON-LISP-USER") + (unless (and (eq symbol symbol-found) (eq status :inherited)) + (error "Symbol ~S is ~S" symbol-found status)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use '("COMMON-LISP")))) + (and (equal (multiple-value-list (find-symbol "APPEND")) + '(cl:append :inherited)) + (equal (multiple-value-list (find-symbol "FIND")) + '(cl:find :inherited)) + (equal (multiple-value-list (find-symbol "CAR")) + '(cl:car :inherited))))) +(equal (multiple-value-list (find-symbol "NIL" 'cl)) '(nil :external)) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let* ((*package* (make-package "TB-FOO" :use (list 'cl))) + (symbol (intern "car" *package*))) + (and (equal (multiple-value-list (find-symbol "car")) + (list symbol :internal)) + (equal (multiple-value-list (find-symbol "CAR")) + (list 'cl:car :inherited))))) + + +;; find-all-symbols +(member 'cl:car (find-all-symbols 'car)) +(member 'cl:cdr (find-all-symbols "CDR")) +(every #'symbolp (find-all-symbols "LOOP")) +(every #'(lambda (name) (string= name "FIND")) + (mapcar #'symbol-name (find-all-symbols "FIND"))) +(dolist (name (list "CAR" "CDR" #\a #\A 'common-lisp 'join "" "XXX" "aA" + "LONGLONGLONGLONGLONGLONGLONGLONGLONGLONG" + 'long-long-long-long-long-long-name) t) + (unless (every #'(lambda (symbol-name) (string= symbol-name name)) + (mapcar #'symbol-name (find-all-symbols name))) + (return nil))) + + +;; intern +(symbolp (intern "SYMBOL")) +(symbolp (intern "long-long-name-in-lower-case")) +(equal (multiple-value-list (intern "NIL" 'cl)) '(nil :external)) +(multiple-value-bind (boo status) (intern "BOO") + (and (symbolp boo) + (member status '(nil :internal :external :inherited)) + (string= (symbol-name boo) "BOO"))) +(let ((*package* (find-package "CL"))) + (equal (multiple-value-list (intern "CAR")) '(cl:car :external))) +(let ((*package* (find-package "KEYWORD"))) + (equal (multiple-value-list (intern "TEST")) '(:test :external))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (make-package "TB-FOO" :use nil) + (and (multiple-value-list (intern "BOO" 'tb-foo)) + (list (find-symbol "BOO" 'tb-foo) nil) + (eq (symbol-package (find-symbol "BOO" 'tb-foo)) (find-package 'tb-foo)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use '(cl)))) + (and (eq (intern "CAR") 'cl:car) + (equal (multiple-value-list (intern "ZZZ")) + (list (find-symbol "ZZZ") nil)) + (equal (multiple-value-list (intern "ZZZ")) + (list (find-symbol "ZZZ") :internal)) + (export (find-symbol "ZZZ")) + (equal (multiple-value-list (intern "ZZZ")) + (list (find-symbol "ZZZ") :external))))) + +;; export +(eq (export ()) t) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use nil)) + buz) + (and (setq buz (intern "BUZ")) + (equal (multiple-value-list (find-symbol "BUZ")) (list buz :internal)) + (eq (export buz) t) + (equal (multiple-value-list (find-symbol "BUZ")) + (list buz :external))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use '(cl)))) + (and (equal (multiple-value-list (find-symbol "CAR")) '(cl:car :inherited)) + (eq (export 'cl:car) t) + (equal (multiple-value-list (find-symbol "CAR")) '(cl:car :external))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use '(cl)))) + (and (equal (multiple-value-list (find-symbol "CAR")) '(cl:car :inherited)) + (eq (export '(cl:car)) t) + (equal (multiple-value-list (find-symbol "CAR")) '(cl:car :external))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use '(cl)))) + (and (equal (multiple-value-list (find-symbol "CAR")) '(cl:car :inherited)) + (equal (multiple-value-list (find-symbol "CDR")) '(cl:cdr :inherited)) + (eq (export '(cl:car cl:cdr)) t) + (equal (multiple-value-list (find-symbol "CAR")) '(cl:car :external)) + (equal (multiple-value-list (find-symbol "CDR")) '(cl:cdr :external))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use '(cl))) + (buz (make-symbol "BUZ"))) + (import buz) + (and (equal (multiple-value-list (find-symbol "CAR")) '(cl:car :inherited)) + (equal (multiple-value-list (find-symbol "CDR")) '(cl:cdr :inherited)) + (equal (multiple-value-list (find-symbol "BUZ")) (list buz :internal)) + (eq (export (list 'cl:car buz 'cl:cdr)) t) + (equal (multiple-value-list (find-symbol "CAR")) '(cl:car :external)) + (equal (multiple-value-list (find-symbol "CDR")) '(cl:cdr :external)) + (equal (multiple-value-list (find-symbol "BUZ")) + (list buz :external))))) +(progn + (when (find-package "A") (delete-package "A")) + (make-package "A" :use nil) + (import 'cl:car "A") + (and (eq (export 'cl:car "A") t) + (equal (multiple-value-list (find-symbol "CAR" "A")) + '(cl:car :external)))) +(progn + (when (find-package "A") (delete-package "A")) + (make-package "A" :use nil) + (import 'cl:car "A") + (and (eq (export 'cl:car #\A) t) + (equal (multiple-value-list (find-symbol "CAR" "A")) + '(cl:car :external)))) +(progn + (when (find-package "A") (delete-package "A")) + (make-package "A" :use nil) + (import 'cl:car "A") + (and (eq (export 'cl:car 'a) t) + (equal (multiple-value-list (find-symbol "CAR" "A")) + '(cl:car :external)))) +(progn + (when (find-package "A") (delete-package "A")) + (make-package "A" :use nil) + (import 'cl:car "A") + (and (eq (export 'cl:car (find-package 'a)) t) + (equal (multiple-value-list (find-symbol "CAR" "A")) + '(cl:car :external)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use '(cl)))) + (and (equal (multiple-value-list (find-symbol "CAR")) '(cl:car :inherited)) + (eq (export 'cl:car) t) + (equal (multiple-value-list (find-symbol "CAR")) '(cl:car :external)) + (unuse-package 'cl) + (equal (multiple-value-list (find-symbol "CAR")) '(cl:car :external))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE" :use nil) + (make-package "TB-FOO" :use '("TB-BAR-TO-USE")) + (let ((buz (intern "BUZ" 'tb-bar-to-use))) + (and (equal (multiple-value-list (find-symbol "BUZ" 'tb-foo)) '(nil nil)) + (export buz 'tb-bar-to-use) + (equal (multiple-value-list (find-symbol "BUZ" 'tb-foo)) + (list buz :inherited))))) +(HANDLER-CASE + (PROGN + (WHEN (FIND-PACKAGE "TB-FOO") (DELETE-PACKAGE "TB-FOO")) + (MAKE-PACKAGE "TB-FOO" :USE NIL) + (EXPORT 'CAR "TB-FOO")) + (PACKAGE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE + (PROGN + (WHEN (FIND-PACKAGE "TB-FOO") (DELETE-PACKAGE "TB-FOO")) + (WHEN (FIND-PACKAGE "TB-BAR-TO-USE") + (MAPCAN #'DELETE-PACKAGE (PACKAGE-USED-BY-LIST "TB-BAR-TO-USE")) + (DELETE-PACKAGE "TB-BAR-TO-USE")) + (MAKE-PACKAGE "TB-BAR-TO-USE" :USE NIL) + (MAKE-PACKAGE "TB-FOO" :USE '("TB-BAR-TO-USE")) + (INTERN "BUZ" 'TB-FOO) + (LET ((BUZ (INTERN "BUZ" 'TB-BAR-TO-USE))) + (EXPORT BUZ 'TB-BAR-TO-USE))) + (PACKAGE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + + +;; unexport +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use nil)) + buz) + (and (export (setq buz (intern "BUZ"))) + (equal (multiple-value-list (find-symbol "BUZ")) (list buz :external)) + (eq (unexport buz) t) + (equal (multiple-value-list (find-symbol "BUZ")) + (list buz :internal))))) +(progn + (when (find-package "A") (delete-package "A")) + (make-package "A" :use nil) + (let (buz) + (and (export (setq buz (intern "BUZ" 'a)) 'a) + (equal (multiple-value-list (find-symbol "BUZ" 'a)) + (list buz :external)) + (eq (unexport buz 'a) t) + (equal (multiple-value-list (find-symbol "BUZ" 'a)) + (list buz :internal))))) +(progn + (when (find-package "A") (delete-package "A")) + (make-package "A" :use nil) + (let (buz) + (and (export (setq buz (intern "BUZ" 'a)) 'a) + (equal (multiple-value-list (find-symbol "BUZ" 'a)) + (list buz :external)) + (eq (unexport buz #\A) t) + (equal (multiple-value-list (find-symbol "BUZ" 'a)) + (list buz :internal))))) +(progn + (when (find-package "A") (delete-package "A")) + (make-package "A" :use nil) + (let (buz) + (and (export (setq buz (intern "BUZ" 'a)) 'a) + (equal (multiple-value-list (find-symbol "BUZ" 'a)) + (list buz :external)) + (eq (unexport buz "A") t) + (equal (multiple-value-list (find-symbol "BUZ" 'a)) + (list buz :internal))))) +(progn + (when (find-package "A") (delete-package "A")) + (make-package "A" :use nil) + (let (buz) + (and (export (setq buz (intern "BUZ" 'a)) 'a) + (equal (multiple-value-list (find-symbol "BUZ" 'a)) + (list buz :external)) + (eq (unexport buz (find-package "A")) t) + (equal (multiple-value-list (find-symbol "BUZ" 'a)) + (list buz :internal))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (make-package "TB-FOO" :use nil) + (let (buz) + (and (export (setq buz (intern "BUZ" 'tb-foo)) 'tb-foo) + (equal (multiple-value-list (find-symbol "BUZ" 'tb-foo)) + (list buz :external)) + (eq (unexport buz 'tb-foo) t) + (equal (multiple-value-list (find-symbol "BUZ" 'tb-foo)) + (list buz :internal))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let* ((*package* (make-package "TB-FOO" :use nil)) + (names '("A" "BC" "DEF" "GHIJ")) + (symbols (mapcar #'intern names))) + (and (export symbols) + (eq (unexport symbols) t) + (every #'(lambda (status) (eq status :internal)) + (mapcar #'(lambda (name) + (cadr (multiple-value-list (find-symbol name)))) + names))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let* ((*package* (make-package "TB-FOO" :use nil))) + (import '(cl:nil)) + (export '(cl:nil)) + (and (eq (unexport 'cl:nil) t) + (equal (multiple-value-list (find-symbol "NIL")) '(cl:nil :external))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let* ((*package* (make-package "TB-FOO" :use nil))) + (import '(cl:nil)) + (export '(cl:nil)) + (and (eq (unexport '(cl:nil)) t) + (equal (multiple-value-list (find-symbol "NIL")) '(nil :internal))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let* ((*package* (make-package "TB-FOO" :use nil)) + (baz (intern "BAZ" *package*))) + (and + (equal (multiple-value-list (find-symbol "BAZ")) (list baz :internal)) + (eq (unexport (list baz) *package*) t) + (equal (multiple-value-list (find-symbol "BAZ")) (list baz :internal))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let* ((*package* (make-package "TB-FOO" :use nil)) + (baz (intern "BAZ" *package*)) + (woo (intern "WOO" *package*))) + (export woo) + (and + (equal (multiple-value-list (find-symbol "BAZ")) (list baz :internal)) + (equal (multiple-value-list (find-symbol "WOO")) (list woo :external)) + (eq (unexport (list baz woo) *package*) t) + (equal (multiple-value-list (find-symbol "BAZ")) (list baz :internal)) + (equal (multiple-value-list (find-symbol "WOO")) (list woo :internal))))) +(HANDLER-CASE + (PROGN + (WHEN (FIND-PACKAGE "TB-FOO") (DELETE-PACKAGE "TB-FOO")) + (LET* ((*PACKAGE* (MAKE-PACKAGE "TB-FOO" :USE NIL))) + (UNEXPORT 'CAR))) + (PACKAGE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE + (PROGN + (WHEN (FIND-PACKAGE "TB-FOO") (DELETE-PACKAGE "TB-FOO")) + (LET* ((*PACKAGE* (MAKE-PACKAGE "TB-FOO" :USE NIL)) + (BAZ (INTERN "BAZ" *PACKAGE*)) + (WOO (INTERN "WOO" *PACKAGE*))) + (EXPORT WOO) + (UNEXPORT (LIST BAZ 'NIL WOO) *PACKAGE*))) + (PACKAGE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + + + + +;; shadow +(eq (shadow '()) t) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (make-package "TB-FOO" :use nil) + (and (eq (shadow "A" 'tb-foo) t) + (eq (cadr (multiple-value-list (find-symbol "A" 'tb-foo))) :internal) + (equal (package-shadowing-symbols 'tb-foo) + (list (find-symbol "A" 'tb-foo))))) +(eq (shadow '()) t) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (make-package "TB-FOO" :use nil) + (and (eq (shadow #\A 'tb-foo) t) + (eq (cadr (multiple-value-list (find-symbol "A" 'tb-foo))) :internal) + (equal (package-shadowing-symbols 'tb-foo) + (list (find-symbol "A" 'tb-foo))))) +(eq (shadow '()) t) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (make-package "TB-FOO" :use nil) + (and (eq (shadow 'a 'tb-foo) t) + (eq (cadr (multiple-value-list (find-symbol "A" 'tb-foo))) :internal) + (equal (package-shadowing-symbols 'tb-foo) + (list (find-symbol "A" 'tb-foo))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (make-package "TB-FOO" :use nil) + (and (eq (shadow '(a) 'tb-foo) t) + (eq (cadr (multiple-value-list (find-symbol "A" 'tb-foo))) :internal) + (equal (package-shadowing-symbols 'tb-foo) + (list (find-symbol "A" 'tb-foo))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (make-package "TB-FOO" :use nil) + (and (eq (shadow '("A") 'tb-foo) t) + (eq (cadr (multiple-value-list (find-symbol "A" 'tb-foo))) :internal) + (equal (package-shadowing-symbols 'tb-foo) + (list (find-symbol "A" 'tb-foo))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (make-package "TB-FOO" :use nil) + (and (eq (shadow '(#\A) 'tb-foo) t) + (eq (cadr (multiple-value-list (find-symbol "A" 'tb-foo))) :internal) + (equal (package-shadowing-symbols 'tb-foo) + (list (find-symbol "A" 'tb-foo))))) +(progn + (when (find-package "A") (delete-package "A")) + (make-package "A" :use nil) + (and (eq (shadow "BUZ" #\A) t) + (eq (cadr (multiple-value-list (find-symbol "BUZ" 'a))) :internal) + (equal (package-shadowing-symbols 'a) + (list (find-symbol "BUZ" 'a))))) +(progn + (when (find-package "A") (delete-package "A")) + (make-package "A" :use nil) + (and (eq (shadow "BUZ" "A") t) + (eq (cadr (multiple-value-list (find-symbol "BUZ" 'a))) :internal) + (equal (package-shadowing-symbols 'a) + (list (find-symbol "BUZ" 'a))))) +(progn + (when (find-package "A") (delete-package "A")) + (make-package "A" :use nil) + (and (eq (shadow "BUZ" 'a) t) + (eq (cadr (multiple-value-list (find-symbol "BUZ" 'a))) :internal) + (equal (package-shadowing-symbols 'a) + (list (find-symbol "BUZ" 'a))))) +(progn + (when (find-package "A") (delete-package "A")) + (make-package "A" :use nil) + (and (eq (shadow "BUZ" (find-package 'a)) t) + (eq (cadr (multiple-value-list (find-symbol "BUZ" 'a))) :internal) + (equal (package-shadowing-symbols 'a) + (list (find-symbol "BUZ" 'a))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use nil)) + (names '(a #\B "C" "BUZ"))) + (and (eq (shadow names) t) + (every #'(lambda (name) + (eq (cadr (multiple-value-list (find-symbol name))) + :internal)) + names) + (null (set-difference (mapcar #'find-symbol (mapcar #'string names)) + (package-shadowing-symbols *package*)))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use '(cl))) + (names '(a #\B "C" "BUZ" "CAR")) + a b c) + (setq a (intern "A")) + (export (setq b (intern "B"))) + (shadowing-import (setq c (intern "C"))) + (and (eq (shadow names) t) + (equal (multiple-value-list (find-symbol "A")) (list a :internal)) + (equal (multiple-value-list (find-symbol "B")) (list b :external)) + (equal (multiple-value-list (find-symbol "C")) (list c :internal)) + (eq (cadr (multiple-value-list (find-symbol "BUZ"))) :internal) + (eq (cadr (multiple-value-list (find-symbol "CAR"))) :internal) + (not (eq (car (multiple-value-list (find-symbol "CAR"))) 'cl:car)) + (null (set-difference (mapcar #'find-symbol (mapcar #'string names)) + (package-shadowing-symbols *package*)))))) + + + + +;; shadowing-import +(eq (shadowing-import '()) t) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (shadowing-import '() (make-package "TB-FOO" :use nil)) + (let ((list nil)) + (null (do-symbols (symbol "TB-FOO" list) (push symbol list))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use nil))) + (and (not (find-symbol "CAR")) + (not (find-symbol "CDR")) + (not (find-symbol "LIST")) + (eq (shadowing-import '(cl:car cl:cdr cl:list)) t) + (eq (find-symbol "CAR") 'cl:car) + (eq (find-symbol "CDR") 'cl:cdr) + (eq (find-symbol "LIST") 'cl:list)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let* ((*package* (make-package "TB-FOO" :use (list 'cl))) + (names '("CAR" "CDR" "LIST" "APPEND")) + (symbols (mapcar #'make-symbol names))) + (and (eq (shadowing-import symbols) t) + (every #'eq symbols (mapcar #'find-symbol names)) + (every #'(lambda (symbol) + (member symbol (package-shadowing-symbols *package*))) + symbols)))) +(progn + (when (find-package "A") (delete-package "A")) + (make-package "A" :use nil) + (let ((symbol (make-symbol "CAR"))) + (and (eq (shadowing-import symbol "A") t) + (equal (multiple-value-list (find-symbol "CAR" "A")) + (list symbol :internal))))) +(progn + (when (find-package "A") (delete-package "A")) + (make-package "A" :use nil) + (let ((symbol (make-symbol "CAR"))) + (and (eq (shadowing-import symbol #\A) t) + (equal (multiple-value-list (find-symbol "CAR" "A")) + (list symbol :internal))))) +(progn + (when (find-package "A") (delete-package "A")) + (make-package "A" :use nil) + (let ((symbol (make-symbol "CAR"))) + (and (eq (shadowing-import symbol 'a) t) + (equal (multiple-value-list (find-symbol "CAR" "A")) + (list symbol :internal))))) +(progn + (when (find-package "A") (delete-package "A")) + (make-package "A" :use nil) + (let ((symbol (make-symbol "CAR"))) + (and (eq (shadowing-import symbol (find-package 'a)) t) + (equal (multiple-value-list (find-symbol "CAR" "A")) + (list symbol :internal))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (make-package "TB-FOO" :use nil) + (let ((buz0 (intern "BUZ" 'tb-foo)) + (buz1 (make-symbol "BUZ"))) + (and (equal (multiple-value-list (find-symbol "BUZ" 'tb-foo)) + (list buz0 :internal)) + (eq (shadowing-import buz1 'tb-foo) t) + + (equal (multiple-value-list (find-symbol "BUZ" 'tb-foo)) + (list buz1 :internal)) + (equal (list buz1) (package-shadowing-symbols 'tb-foo)) + (unintern buz1 'tb-foo) + (equal (multiple-value-list (find-symbol "BUZ" 'tb-foo)) '(nil nil)) + (null (package-shadowing-symbols 'tb-foo))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (make-package "TB-FOO" :use nil) + (let ((buz0 (intern "BUZ" 'tb-foo)) + (buz1 (make-symbol "BUZ"))) + (shadow buz0 'tb-foo) + (and (equal (multiple-value-list (find-symbol "BUZ" 'tb-foo)) + (list buz0 :internal)) + (eq (shadowing-import buz1 'tb-foo) t) + + (equal (multiple-value-list (find-symbol "BUZ" 'tb-foo)) + (list buz1 :internal)) + (equal (list buz1) (package-shadowing-symbols 'tb-foo)) + (unintern buz1 'tb-foo) + (equal (multiple-value-list (find-symbol "BUZ" 'tb-foo)) '(nil nil)) + (null (package-shadowing-symbols 'tb-foo))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (make-package "TB-FOO" :use nil) + (let ((buz0 (intern "BUZ" 'tb-foo)) + (buz1 (make-symbol "BUZ"))) + (export buz0 'tb-foo) + (and (equal (multiple-value-list (find-symbol "BUZ" 'tb-foo)) + (list buz0 :external)) + (eq (shadowing-import buz1 'tb-foo) t) + + (equal (multiple-value-list (find-symbol "BUZ" 'tb-foo)) + (list buz1 :internal)) + (equal (list buz1) (package-shadowing-symbols 'tb-foo)) + (unintern buz1 'tb-foo) + (equal (multiple-value-list (find-symbol "BUZ" 'tb-foo)) '(nil nil)) + (null (package-shadowing-symbols 'tb-foo))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (make-package "TB-FOO" :use nil) + (let ((buz0 (intern "BUZ" 'tb-foo)) + (buz1 (make-symbol "BUZ"))) + (export buz0 'tb-foo) + (shadow buz0 'tb-foo) + (and (equal (multiple-value-list (find-symbol "BUZ" 'tb-foo)) + (list buz0 :external)) + (eq (shadowing-import buz1 'tb-foo) t) + (equal (multiple-value-list (find-symbol "BUZ" 'tb-foo)) + (list buz1 :internal)) + (equal (list buz1) (package-shadowing-symbols 'tb-foo)) + (unintern buz1 'tb-foo) + (equal (multiple-value-list (find-symbol "BUZ" 'tb-foo)) '(nil nil)) + (null (package-shadowing-symbols 'tb-foo))))) + + + +;; import +(eq (import '()) t) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (make-package "TB-FOO" :use nil) + (let ((list nil)) + (and (eq (import '() "TB-FOO") t) + (null (do-symbols (symbol "TB-FOO" list) (push symbol list)))))) +(progn + (when (find-package "A") (delete-package "A")) + (make-package "A" :use nil) + (and (not (find-symbol "CAR" 'a)) + (eq (import 'cl:car 'a) t) + (equal (multiple-value-list (find-symbol "CAR" 'a)) '(cl:car :internal)))) +(progn + (when (find-package "A") (delete-package "A")) + (make-package "A" :use nil) + (and (not (find-symbol "CAR" 'a)) + (eq (import 'cl:car #\A) t) + (equal (multiple-value-list (find-symbol "CAR" 'a)) '(cl:car :internal)))) +(progn + (when (find-package "A") (delete-package "A")) + (make-package "A" :use nil) + (and (not (find-symbol "CAR" 'a)) + (eq (import 'cl:car "A") t) + (equal (multiple-value-list (find-symbol "CAR" 'a)) '(cl:car :internal)))) +(progn + (when (find-package "A") (delete-package "A")) + (make-package "A" :use nil) + (and (not (find-symbol "CAR" 'a)) + (eq (import 'cl:car (find-package "A")) t) + (equal (multiple-value-list (find-symbol "CAR" 'a)) '(cl:car :internal)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (make-package "TB-FOO" :use nil) + (and (not (find-symbol "CAR" 'tb-foo)) + (eq (import 'cl:car 'tb-foo) t) + (equal (multiple-value-list (find-symbol "CAR" 'tb-foo)) + '(cl:car :internal)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (make-package "TB-FOO" :use nil) + (and (not (find-symbol "CAR" 'tb-foo)) + (eq (import (list 'cl:car 'cl:cdr 'cl:list :test) 'tb-foo) t) + (equal (multiple-value-list (find-symbol "CAR" 'tb-foo)) + '(cl:car :internal)) + (equal (multiple-value-list (find-symbol "CDR" 'tb-foo)) + '(cl:cdr :internal)) + (equal (multiple-value-list (find-symbol "TEST" 'tb-foo)) + '(:test :internal)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use nil))) + (and (not (find-symbol "CAR" 'tb-foo)) + (eq (import (list 'cl:car 'cl:cdr 'cl:list :test)) t) + (equal (multiple-value-list (find-symbol "CAR" 'tb-foo)) + '(cl:car :internal)) + (equal (multiple-value-list (find-symbol "CDR" 'tb-foo)) + '(cl:cdr :internal)) + (equal (multiple-value-list (find-symbol "TEST" 'tb-foo)) + '(:test :internal))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let (buz) + (make-package "TB-FOO" :use nil) + (and (export (setq buz (intern "BUZ" "TB-FOO")) "TB-FOO") + (equal (multiple-value-list (find-symbol "BUZ" "TB-FOO")) + (list buz :external)) + (eq (import buz "TB-FOO") t) + (equal (multiple-value-list (find-symbol "BUZ" "TB-FOO")) + (list buz :external))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let (buz) + (make-package "TB-FOO" :use nil) + (and (setq buz (intern "BUZ" "TB-FOO")) + (equal (multiple-value-list (find-symbol "BUZ" "TB-FOO")) + (list buz :internal)) + (eq (import buz "TB-FOO") t) + (equal (multiple-value-list (find-symbol "BUZ" "TB-FOO")) + (list buz :internal))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use '(cl)))) + (and (equal (multiple-value-list (find-symbol "CAR")) '(cl:car :inherited)) + (eq (import 'cl:car) t) + (equal (multiple-value-list (find-symbol "CAR")) '(cl:car :internal))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (make-package "TB-FOO" :use nil) + (let ((buz (make-symbol "BUZ"))) + (and (null (symbol-package buz)) + (eq (import buz 'tb-foo) t) + (eq (symbol-package buz) (find-package 'tb-foo))))) +(HANDLER-CASE + (PROGN + (WHEN (FIND-PACKAGE "TB-FOO") (DELETE-PACKAGE "TB-FOO")) + (LET ((*PACKAGE* (MAKE-PACKAGE "TB-FOO" :USE '(CL)))) + (IMPORT (MAKE-SYMBOL "CAR")))) + (PACKAGE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE + (PROGN + (WHEN (FIND-PACKAGE "TB-FOO") (DELETE-PACKAGE "TB-FOO")) + (LET ((*PACKAGE* (MAKE-PACKAGE "TB-FOO" :USE NIL))) + (INTERN "BUZ") + (IMPORT (MAKE-SYMBOL "BUZ")))) + (PACKAGE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE + (PROGN + (WHEN (FIND-PACKAGE "TB-FOO") (DELETE-PACKAGE "TB-FOO")) + (LET ((*PACKAGE* (MAKE-PACKAGE "TB-FOO" :USE NIL))) + (EXPORT (INTERN "BUZ")) + (IMPORT (MAKE-SYMBOL "BUZ")))) + (PACKAGE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE + (PROGN + (WHEN (FIND-PACKAGE "TB-FOO") (DELETE-PACKAGE "TB-FOO")) + (LET ((*PACKAGE* (MAKE-PACKAGE "TB-FOO" :USE NIL))) + (SHADOWING-IMPORT (MAKE-SYMBOL "BUZ")) + (IMPORT (MAKE-SYMBOL "BUZ")))) + (PACKAGE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + + + +;; unintern +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (make-package "TB-FOO" :use nil) + (not (unintern 'cl:car "TB-FOO"))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (make-package "TB-FOO" :use nil) + (and (unintern (intern "BUZ" "TB-FOO") "TB-FOO") + (not (find-symbol "BUZ" "TB-FOO")))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use nil))) + (not (unintern 'cl:car)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use nil))) + (and (unintern (intern "BUZ")) + (not (find-symbol "BUZ"))))) +(progn + (when (find-package "A") (delete-package "A")) + (make-package "A" :use nil) + (and (unintern (intern "BUZ" "A") #\A) + (not (find-symbol "BUZ" "A")))) +(progn + (when (find-package "A") (delete-package "A")) + (make-package "A" :use nil) + (and (unintern (intern "BUZ" "A") "A") + (not (find-symbol "BUZ" "A")))) +(progn + (when (find-package "A") (delete-package "A")) + (make-package "A" :use nil) + (and (unintern (intern "BUZ" "A") 'a) + (not (find-symbol "BUZ" "A")))) +(progn + (when (find-package "A") (delete-package "A")) + (make-package "A" :use nil) + (and (unintern (intern "BUZ" "A") (find-package 'a)) + (not (find-symbol "BUZ" "A")))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use '(cl)))) + (and (equal (multiple-value-list (find-symbol "CAR")) '(cl:car :inherited)) + (not (unintern 'cl:car))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use nil))) + (and (import 'cl:car) + (equal (multiple-value-list (find-symbol "CAR")) '(cl:car :internal)) + (unintern 'cl:car) + (not (find-symbol "CAR"))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use '(cl)))) + (and (equal (multiple-value-list (find-symbol "CAR")) '(cl:car :inherited)) + (import 'cl:car) + (equal (multiple-value-list (find-symbol "CAR")) '(cl:car :internal)) + (unintern 'cl:car) + (equal (multiple-value-list (find-symbol "CAR")) + '(cl:car :inherited))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use nil)) + (buz (make-symbol "BUZ"))) + (and (null (symbol-package buz)) + (import buz) + (shadow buz) + (eq (symbol-package buz) *package*) + (member buz (package-shadowing-symbols *package*)) + (unintern buz) + (not (find-symbol "BUZ")) + (not (member buz (package-shadowing-symbols *package*))) + (null (symbol-package buz))))) +(HANDLER-CASE + (PROGN + (WHEN (FIND-PACKAGE "TB-FOO") (DELETE-PACKAGE "TB-FOO")) + (WHEN (FIND-PACKAGE "TB-BAR-TO-USE") + (MAPCAN #'DELETE-PACKAGE (PACKAGE-USED-BY-LIST "TB-BAR-TO-USE")) + (DELETE-PACKAGE "TB-BAR-TO-USE")) + (LET ((*PACKAGE* (MAKE-PACKAGE "TB-FOO" :USE NIL)) SYMBOL) + (AND (SETQ SYMBOL (INTERN "CAR")) + (SHADOW "CAR") + (MAKE-PACKAGE "TB-BAR-TO-USE" :USE NIL) + (EXPORT (INTERN "CAR" "TB-BAR-TO-USE") "TB-BAR-TO-USE") + (USE-PACKAGE (LIST "TB-BAR-TO-USE" "CL")) + (EQUAL (MULTIPLE-VALUE-LIST (FIND-SYMBOL "CAR")) + (LIST SYMBOL :INTERNAL)) + (UNINTERN SYMBOL)))) + (PACKAGE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (let ((*package* (make-package "TB-FOO" :use nil)) + symbol) + (and (setq symbol (intern "CAR")) + (shadow "CAR") + (make-package "TB-BAR-TO-USE" :use nil) + (import 'cl:car "TB-BAR-TO-USE") + (export 'cl:car "TB-BAR-TO-USE") + (use-package (list "TB-BAR-TO-USE" "CL")) + (equal (multiple-value-list (find-symbol "CAR")) + (list symbol :internal)) + (unintern symbol)))) + + + +;; use-package +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use nil))) + (and (not (find-symbol "CAR")) + (eq (use-package 'cl) t) + (find-symbol "CAR")))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use nil))) + (and (not (find-symbol "CAR")) + (eq (use-package "COMMON-LISP") t) + (find-symbol "CAR")))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use nil))) + (and (not (find-symbol "CAR")) + (eq (use-package (find-package "COMMON-LISP")) t) + (find-symbol "CAR")))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use nil))) + (and (not (find-symbol "CAR")) + (eq (use-package '(cl)) t) + (find-symbol "CAR")))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use nil))) + (and (not (find-symbol "CAR")) + (eq (use-package '("COMMON-LISP")) t) + (find-symbol "CAR")))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use nil))) + (and (not (find-symbol "CAR")) + (eq (use-package (list (find-package "COMMON-LISP"))) t) + (find-symbol "CAR")))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((package (make-package "TB-FOO" :use nil)) + (*package* (find-package 'cl-user))) + (and (not (find-symbol "CAR" package)) + (eq (use-package (list (find-package "COMMON-LISP")) package) t) + (find-symbol "CAR" package)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((package (make-package "TB-FOO" :use nil)) + (*package* (find-package 'cl-user))) + (and (not (find-symbol "CAR" package)) + (eq (use-package (list (find-package "COMMON-LISP")) "TB-FOO") t) + (find-symbol "CAR" package)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((package (make-package "TB-FOO" :use nil)) + (*package* (find-package 'cl-user))) + (and (not (find-symbol "CAR" package)) + (eq (use-package (list (find-package "COMMON-LISP")) 'tb-foo) t) + (find-symbol "CAR" package)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((package (make-package "TB-FOO" :use nil)) + (*package* (find-package 'cl-user))) + (and (not (find-symbol "CAR" package)) + (eq (use-package (list (find-package "COMMON-LISP")) + (find-package 'tb-foo)) + t) + (find-symbol "CAR" package)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use nil))) + (and (use-package 'cl) + (member (find-package 'cl) (package-use-list *package*))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (let* ((*package* (make-package "TB-FOO" :use nil)) + boo woo buz) + (and (make-package "TB-BAR-TO-USE" :use nil) + (export (list (setq boo (intern "BOO" 'tb-bar-to-use))) 'tb-bar-to-use) + (setq woo (intern "WOO")) + (export (list (setq buz (intern "BUZ")))) + (use-package (list 'tb-bar-to-use 'cl)) + (equal (multiple-value-list (find-symbol "BOO")) (list boo :inherited)) + (equal (multiple-value-list (find-symbol "WOO")) (list woo :internal)) + (equal (multiple-value-list (find-symbol "BUZ")) (list buz :external)) + (equal (multiple-value-list (find-symbol "CAR")) + (list 'cl:car :inherited)) + (equal (multiple-value-list (find-symbol "LIST")) + (list 'cl:list :inherited))))) +(HANDLER-CASE + (PROGN + (WHEN (FIND-PACKAGE "TB-FOO") (DELETE-PACKAGE "TB-FOO")) + (MAKE-PACKAGE "TB-FOO" :USE NIL) + (INTERN "CAR" 'TB-FOO) + (USE-PACKAGE 'CL 'TB-FOO)) + (PACKAGE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE + (PROGN + (WHEN (FIND-PACKAGE "TB-FOO") (DELETE-PACKAGE "TB-FOO")) + (MAKE-PACKAGE "TB-FOO" :USE NIL) + (EXPORT (INTERN "CAR" 'TB-FOO) 'TB-FOO) + (USE-PACKAGE 'CL 'TB-FOO)) + (PACKAGE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE + (PROGN + (WHEN (FIND-PACKAGE "TB-FOO") (DELETE-PACKAGE "TB-FOO")) + (WHEN (FIND-PACKAGE "TB-BAR-TO-USE") + (MAPCAN #'DELETE-PACKAGE (PACKAGE-USED-BY-LIST "TB-BAR-TO-USE")) + (DELETE-PACKAGE "TB-BAR-TO-USE")) + (MAKE-PACKAGE "TB-FOO" :USE '(CL)) + (MAKE-PACKAGE "TB-BAR-TO-USE" :USE NIL) + (EXPORT (INTERN "CAR" 'TB-BAR-TO-USE) 'TB-BAR-TO-USE) + (USE-PACKAGE 'TB-BAR-TO-USE 'TB-FOO)) + (PACKAGE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + + + +;; unuse-package +(progn + (when (find-package "TB-FOO-TO-USE") + (unuse-package (package-use-list "TB-FOO-TO-USE") "TB-FOO-TO-USE")) + (when (find-package "TB-BAR-TO-USE") + (unuse-package (package-use-list "TB-BAR-TO-USE") "TB-BAR-TO-USE")) + (when (find-package "TB-FOO-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-FOO-TO-USE")) + (delete-package "TB-FOO-TO-USE")) + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (and (make-package "TB-FOO-TO-USE" :use nil) + (make-package "TB-BAR-TO-USE" :use '("TB-FOO-TO-USE")) + (use-package "TB-BAR-TO-USE" "TB-FOO-TO-USE") + (export (intern "FOO" "TB-FOO-TO-USE") "TB-FOO-TO-USE") + (export (intern "BAR" "TB-BAR-TO-USE") "TB-BAR-TO-USE") + (eq (cadr (multiple-value-list (find-symbol "FOO" "TB-FOO-TO-USE"))) + :external) + (eq (cadr (multiple-value-list (find-symbol "BAR" "TB-FOO-TO-USE"))) + :inherited) + (eq (cadr (multiple-value-list (find-symbol "FOO" "TB-BAR-TO-USE"))) + :inherited) + (eq (cadr (multiple-value-list (find-symbol "BAR" "TB-BAR-TO-USE"))) + :external) + (unuse-package (package-use-list "TB-FOO-TO-USE") "TB-FOO-TO-USE") + (unuse-package (package-use-list "TB-BAR-TO-USE") "TB-BAR-TO-USE"))) + + +;; delete-package +(progn + (when (find-package "a") (delete-package "a")) + (and (make-package "a" :use nil) + (delete-package "a") + (not (find-package "a")))) +(progn + (when (find-package "a") (delete-package "a")) + (and (make-package "a" :use nil) + (delete-package #\a) + (not (find-package "a")))) +(progn + (when (find-package "a") (delete-package "a")) + (and (make-package "a" :use nil) + (delete-package '|a|) + (not (find-package "a")))) +(progn + (when (find-package "a") (delete-package "a")) + (and (make-package "a" :use nil) + (delete-package (find-package '|a|)) + (not (find-package "a")))) +(progn + (mapc #'(lambda (name) (when (find-package name) (delete-package name))) + '("a" "b" "c" "d" "e")) + (and (make-package "a" :nicknames '("b" "c" "d" "e") :use nil) + (delete-package "a") + (not (find-package "a")) + (not (find-package "b")) + (not (find-package "c")) + (not (find-package "d")) + (not (find-package "e")))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((package (make-package "TB-FOO" :use nil))) + (and (delete-package "TB-FOO") + (not (find-package "TB-FOO")) + (packagep package) + (null (package-name package))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((package (make-package "TB-FOO" :use nil))) + (and (delete-package "TB-FOO") + (not (member package (list-all-packages)))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((package (make-package "TB-FOO" :use nil))) + (and (delete-package "TB-FOO") + (null (delete-package package))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((car-home-package (symbol-package 'cl:car))) + (and (make-package "TB-FOO" :use nil) + (import 'cl:car "TB-FOO") + (delete-package 'tb-foo) + (eq 'cl:car (find-symbol "CAR" 'cl)) + (eq (symbol-package 'cl:car) car-home-package) + (eq (intern "CAR" 'cl) 'cl:car)))) +(HANDLER-CASE + (PROGN + (WHEN (FIND-PACKAGE "TB-FOO") (DELETE-PACKAGE "TB-FOO")) + (WHEN (FIND-PACKAGE "TB-BAR-TO-USE") + (MAPCAN #'DELETE-PACKAGE (PACKAGE-USED-BY-LIST "TB-BAR-TO-USE")) + (DELETE-PACKAGE "TB-BAR-TO-USE")) + (AND (MAKE-PACKAGE "TB-BAR-TO-USE" :USE NIL) + (MAKE-PACKAGE "TB-FOO" :USE '("TB-BAR-TO-USE")) + (DELETE-PACKAGE "TB-BAR-TO-USE"))) + (PACKAGE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + + +;; in-package +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use nil))) + (in-package cl-user) + (eq *package* (find-package 'cl-user)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use nil))) + (in-package "CL-USER") + (eq *package* (find-package 'cl-user)))) +(progn + (when (find-package "A") (delete-package "A")) + (make-package "A" :use nil) + (let ((*package* *package*)) + (in-package "A") + (eq *package* (find-package 'a)))) +(progn + (when (find-package "A") (delete-package "A")) + (make-package "A" :use nil) + (let ((*package* *package*)) + (in-package #\A) + (eq *package* (find-package 'a)))) +(progn + (when (find-package "A") (delete-package "A")) + (make-package "A" :use nil) + (let ((*package* *package*)) + (in-package a) + (eq *package* (find-package 'a)))) +(progn + (when (find-package "A") (delete-package "A")) + (HANDLER-CASE (PROGN (IN-PACKAGE "A")) + (PACKAGE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL))) + + +;; defpackage +(progn + (when (find-package "A") (delete-package "A")) + (packagep (defpackage #\A))) +(progn + (when (find-package "A") (delete-package "A")) + (packagep (defpackage a))) +(progn + (when (find-package "A") (delete-package "A")) + (packagep (defpackage "A"))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO")) + (null (package-nicknames 'tb-foo)) + (null (package-shadowing-symbols 'tb-foo)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO" (:nicknames))) + (null (package-nicknames 'tb-foo)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO" (:nicknames) (:shadow))) + (null (package-nicknames 'tb-foo)) + (null (package-shadowing-symbols 'tb-foo)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO" + (:nicknames) + (:shadow) + (:shadowing-import-from common-lisp))) + (null (package-nicknames 'tb-foo)) + (null (package-shadowing-symbols 'tb-foo)))) +(progn + (mapc #'(lambda (name) (when (find-package name) (delete-package name))) + '("TB-FOO" "TB-FOO-NICKNAME-1" "TB-FOO-NICKNAME-2" "TB-FOO-NICKNAME-3")) + (and (packagep (defpackage "TB-FOO" (:nicknames tb-foo-nickname-1))) + (equal (package-nicknames 'tb-foo) '("TB-FOO-NICKNAME-1")))) +#-CLISP +;; Bruno: unfounded assumptions about the order of the package-nicknames list +(progn + (mapc #'(lambda (name) (when (find-package name) (delete-package name))) + '("TB-FOO" "TB-FOO-NICKNAME-1" "TB-FOO-NICKNAME-2" "TB-FOO-NICKNAME-3")) + (and (packagep (defpackage "TB-FOO" + (:nicknames tb-foo-nickname-1 tb-foo-nickname-2 + tb-foo-nickname-3))) + (equal (package-nicknames 'tb-foo) + '("TB-FOO-NICKNAME-1" "TB-FOO-NICKNAME-2" "TB-FOO-NICKNAME-3")))) +(progn + (mapc #'(lambda (name) (when (find-package name) (delete-package name))) + '("A" "B" "C" "D")) + (and (packagep (defpackage "A" (:nicknames #\B c "D"))) + (null (set-difference (package-nicknames 'a) '("B" "C" "D") + :test #'string=)))) +(progn + (mapc #'(lambda (name) (when (find-package name) (delete-package name))) + '("A" "B" "C" "D")) + (and (packagep (defpackage "A" + (:nicknames) (:nicknames #\B) (:nicknames c "D"))) + (null (set-difference (package-nicknames 'a) '("B" "C" "D") + :test #'string=)))) +;(progn +; (when (find-package "TB-FOO") (delete-package "TB-FOO")) +; (and (packagep (defpackage "TB-FOO" +; (:nicknames) (:documentation "doc for tb-foo package"))) +; (packagep (find-package 'tb-foo)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO" (:use))) + (null (package-use-list 'tb-foo)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO" (:use cl))) + (equal (package-use-list 'tb-foo) (list (find-package 'cl))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE" :use nil) + (and (packagep (defpackage "TB-FOO" (:use cl tb-bar-to-use))) + (null (set-difference (package-use-list 'tb-foo) + (mapcar #'find-package '(cl tb-bar-to-use)))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE" :use nil) + (and (packagep (defpackage "TB-FOO" (:use cl) (:use) (:use tb-bar-to-use))) + (null (set-difference (package-use-list 'tb-foo) + (mapcar #'find-package '(cl tb-bar-to-use)))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE" :use nil) + (and (packagep (defpackage "TB-FOO" (:use cl) (:use) (:use "TB-BAR-TO-USE"))) + (null (set-difference (package-use-list 'tb-foo) + (mapcar #'find-package '(cl tb-bar-to-use)))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (when (find-package "B") + (mapcan #'delete-package (package-used-by-list "B")) + (delete-package "B")) + (make-package "B" :use nil) + (and (packagep (defpackage "TB-FOO" (:use cl) (:use) (:use "B"))) + (null (set-difference (package-use-list 'tb-foo) + (mapcar #'find-package '(cl b)))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (when (find-package "B") + (mapcan #'delete-package (package-used-by-list "B")) + (delete-package "B")) + (make-package "B" :use nil) + (and (packagep (defpackage "TB-FOO" (:use cl) (:use) (:use #\B))) + (null (set-difference (package-use-list 'tb-foo) + (mapcar #'find-package '(cl b)))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (when (find-package "B") + (mapcan #'delete-package (package-used-by-list "B")) + (delete-package "B")) + (make-package "B" :use nil) + (and (packagep (eval `(defpackage "TB-FOO" + (:use cl) (:use) (:use ,(find-package #\B))))) + (null (set-difference (package-use-list 'tb-foo) + (mapcar #'find-package '(cl b)))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO" (:shadow))) + (null (package-shadowing-symbols 'tb-foo)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO" (:shadow "A"))) + (equal (package-shadowing-symbols 'tb-foo) + (list (find-symbol "A" 'tb-foo))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO" (:shadow a #\b "c" "D"))) + (null (set-difference (package-shadowing-symbols 'tb-foo) + (mapcar #'(lambda (name) (find-symbol name 'tb-foo)) + '("A" "b" "c" "D")))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO" (:shadow a) (:shadow ) + (:shadow #\b "c" "D")))) + (null (set-difference (package-shadowing-symbols 'tb-foo) + (mapcar #'(lambda (name) (find-symbol name 'tb-foo)) + '("A" "b" "c" "D"))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO" (:shadowing-import-from cl))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO" (:shadowing-import-from "COMMON-LISP"))) + (null (package-shadowing-symbols 'tb-foo)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO" + (:shadowing-import-from "COMMON-LISP" car cdr list))) + (every #'(lambda (name) (find-symbol name 'tb-foo)) '("CAR" "CDR" "LIST")) + (null (set-difference (package-shadowing-symbols 'tb-foo) + '(cl:car cl:cdr cl:list))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO" + (:shadowing-import-from "COMMON-LISP" car cdr) + (:shadowing-import-from "COMMON-LISP") + (:shadowing-import-from "COMMON-LISP" list))) + (every #'(lambda (name) (find-symbol name 'tb-foo)) '("CAR" "CDR" "LIST")) + (null (set-difference (package-shadowing-symbols 'tb-foo) + '(cl:car cl:cdr cl:list))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE" :use nil) + (let ((buz (intern "BUZ" 'tb-bar-to-use))) + (and (packagep (defpackage "TB-FOO" + (:shadowing-import-from "COMMON-LISP" car cdr) + (:shadowing-import-from tb-bar-to-use "BUZ"))) + (every #'(lambda (name) (find-symbol name 'tb-foo)) '("CAR" "CDR")) + (null (set-difference (package-shadowing-symbols 'tb-foo) + (list 'cl:car 'cl:cdr buz)))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE" :use nil) + (let ((buz (intern "BUZ" 'tb-bar-to-use)) + (baz (intern "BAZ" 'tb-bar-to-use))) + (and (packagep (defpackage "TB-FOO" + (:shadowing-import-from "COMMON-LISP" car cdr) + (:shadowing-import-from tb-bar-to-use "BUZ" "BAZ"))) + (every #'(lambda (name) (find-symbol name 'tb-foo)) + '("CAR" "CDR" "BUZ" "BAZ")) + (null (set-difference (package-shadowing-symbols 'tb-foo) + (list 'cl:car 'cl:cdr buz baz)))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE" :use nil) + (let ((buz (intern "BUZ" 'tb-bar-to-use)) + (baz (intern "BAZ" 'tb-bar-to-use))) + (and (packagep (defpackage "TB-FOO" + (:shadow "BOO") + (:shadowing-import-from "COMMON-LISP" car cdr) + (:shadowing-import-from tb-bar-to-use "BUZ" "BAZ"))) + (every #'(lambda (name) (find-symbol name 'tb-foo)) + '("CAR" "CDR" "BUZ" "BAZ" "BOO")) + (null (set-difference (package-shadowing-symbols 'tb-foo) + (list 'cl:car 'cl:cdr buz baz + (find-symbol "BOO" 'tb-foo))))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (eval `(defpackage "TB-FOO" + (:shadowing-import-from ,(find-package 'cl) + "CAR" "CDR")))) + (every #'(lambda (name) (find-symbol name 'tb-foo)) '("CAR" "CDR")))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (eval `(defpackage "TB-FOO" + (:import-from ,(find-package 'cl) + "CAR" "CDR")))) + (every #'(lambda (name) (find-symbol name 'tb-foo)) '("CAR" "CDR")))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (packagep (defpackage "TB-FOO" (:import-from cl)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO" (:import-from cl "CAR" "CDR"))) + (every #'(lambda (name) (find-symbol name 'tb-foo)) '("CAR" "CDR")))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO" + (:import-from "COMMON-LISP" car cdr list))) + (every #'(lambda (name) (find-symbol name 'tb-foo)) + '("CAR" "CDR" "LIST")))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO" + (:import-from "COMMON-LISP" car cdr) + (:import-from "COMMON-LISP") + (:import-from "COMMON-LISP" list))) + (every #'(lambda (name) (find-symbol name 'tb-foo)) + '("CAR" "CDR" "LIST")))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE" :use nil) + (let ((buz (intern "BUZ" 'tb-bar-to-use))) + (and (packagep (defpackage "TB-FOO" + (:import-from "COMMON-LISP" car cdr) + (:import-from tb-bar-to-use "BUZ"))) + (every #'(lambda (name) (find-symbol name 'tb-foo)) '("CAR" "CDR")) + (eq (find-symbol "BUZ" 'tb-foo) buz)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE" :use nil) + (let ((buz (intern "BUZ" 'tb-bar-to-use)) + (baz (intern "BAZ" 'tb-bar-to-use))) + (and (packagep (defpackage "TB-FOO" + (:import-from "COMMON-LISP" car cdr) + (:import-from tb-bar-to-use "BUZ" "BAZ"))) + (every #'(lambda (name) (find-symbol name 'tb-foo)) + '("CAR" "CDR" "BUZ" "BAZ")) + (eq (find-symbol "BUZ" 'tb-foo) buz) + (eq (find-symbol "BAZ" 'tb-foo) baz)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (packagep (defpackage "TB-FOO" (:export)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (packagep (defpackage "TB-FOO" (:export) (:export)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO" (:export "A"))) + (eq (cadr (multiple-value-list (find-symbol "A" 'tb-foo))) :external))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO" (:export "A" "B" "C"))) + (every #'(lambda (name) + (eq (cadr (multiple-value-list (find-symbol name 'tb-foo))) + :external)) + '("A" "B" "C")))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO" (:export "A" "B" "C"))) + (every #'(lambda (name) + (eq (cadr (multiple-value-list (find-symbol name 'tb-foo))) + :external)) + '("A" "B" "C")))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO" + (:export "A") (:export "B") (:export "C"))) + (every #'(lambda (name) + (eq (cadr (multiple-value-list (find-symbol name 'tb-foo))) + :external)) + '("A" "B" "C")))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO" + (:export "A" "B" "C" "CAR") + (:use cl))) + (every #'(lambda (name) + (eq (cadr (multiple-value-list (find-symbol name 'tb-foo))) + :external)) + '("A" "B" "C" "CAR")) + (eq (find-symbol "CAR" 'tb-foo) 'cl:car))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO" + (:export "A" "B" "C" "CAR") + (:import-from cl "CAR"))) + (every #'(lambda (name) + (eq (cadr (multiple-value-list (find-symbol name 'tb-foo))) + :external)) + '("A" "B" "C" "CAR")) + (eq (find-symbol "CAR" 'tb-foo) 'cl:car))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO" + (:export "A" "B" "C" "CAR") + (:shadowing-import-from cl "CAR"))) + (every #'(lambda (name) + (eq (cadr (multiple-value-list (find-symbol name 'tb-foo))) + :external)) + '("A" "B" "C" "CAR")) + (eq (find-symbol "CAR" 'tb-foo) 'cl:car))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE" :use nil) + (let ((buz (intern "BUZ" 'tb-bar-to-use))) + (and (packagep (defpackage "TB-FOO" + (:export "A" "B" "C" "CAR" "CDR" "BUZ") + (:use tb-bar-to-use) + (:import-from cl "CDR") + (:shadowing-import-from cl "CAR"))) + (every #'(lambda (name) + (eq (cadr (multiple-value-list (find-symbol name 'tb-foo))) + :external)) + '("A" "B" "C" "CAR" "CDR" "BUZ")) + (eq (find-symbol "CAR" 'tb-foo) 'cl:car) + (eq (find-symbol "CDR" 'tb-foo) 'cl:cdr) + (eq (find-symbol "BUZ" 'tb-bar-to-use) buz)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (packagep (defpackage "TB-FOO" (:intern)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (packagep (defpackage "TB-FOO" (:intern) (:intern)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO" (:intern "A"))) + (eq (cadr (multiple-value-list (find-symbol "A" 'tb-foo))) :internal))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO" (:intern "A" "B" "C"))) + (every #'(lambda (name) + (eq (cadr (multiple-value-list (find-symbol name 'tb-foo))) + :internal)) + '("A" "B" "C")))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO" (:intern "A" "B" "C"))) + (every #'(lambda (name) + (eq (cadr (multiple-value-list (find-symbol name 'tb-foo))) + :internal)) + '("A" "B" "C")))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO" + (:intern "A") (:intern "B") (:intern "C"))) + (every #'(lambda (name) + (eq (cadr (multiple-value-list (find-symbol name 'tb-foo))) + :internal)) + '("A" "B" "C")))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO" + (:intern "A" "B" "C" "CAR") + (:use cl))) + (every #'(lambda (name) + (eq (cadr (multiple-value-list (find-symbol name 'tb-foo))) + :internal)) + '("A" "B" "C")) + (equal (multiple-value-list (find-symbol "CAR" 'tb-foo)) + '(cl:car :inherited)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO" (:size 10))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO" (:size 0))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (and (packagep (defpackage "TB-FOO" (:size 1000))))) + +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE" :use nil) + (let ((buz (intern "BUZ" 'tb-bar-to-use))) + (export buz 'tb-bar-to-use) + (and + (packagep + (defpackage "TB-FOO" + (:size 10) + (:shadow "SHADOW1" "SHADOW2") + (:shadowing-import-from cl "CAR" "CDR") + (:use tb-bar-to-use) + (:import-from keyword "TEST") + (:intern "S0" "S1") + ;;(:documentation "doc") + (:nicknames "TB-FOO-NICKNAME-0" "TB-FOO-NICKNAME-1" "TB-FOO-NICKNAME-2") + (:export "SHADOW1" "CAR"))) + (equal (multiple-value-list (find-symbol "BUZ" 'tb-foo-nickname-0)) + (list buz :inherited)) + (eq (cadr (multiple-value-list (find-symbol "SHADOW1" 'tb-foo-nickname-2))) + :external) + (eq (cadr (multiple-value-list (find-symbol "SHADOW2" 'tb-foo-nickname-2))) + :internal) + (equal (multiple-value-list (find-symbol "CAR" 'tb-foo-nickname-2)) + (list 'cl:car :external)) + (equal (multiple-value-list (find-symbol "CDR" 'tb-foo-nickname-2)) + (list 'cl:cdr :internal)) + (equal (multiple-value-list (find-symbol "TEST" 'tb-foo-nickname-2)) + (list :test :internal)) + (eq (cadr (multiple-value-list (find-symbol "S0" 'tb-foo-nickname-2))) + :internal) + (eq (cadr (multiple-value-list (find-symbol "S1" 'tb-foo-nickname-2))) + :internal) + ))) + +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (make-package "TB-BAR-TO-USE" :use nil) + (let ((buz (intern "BUZ" 'tb-bar-to-use))) + (export buz 'tb-bar-to-use) + (and + (packagep + (defpackage "TB-FOO" + (:export "SHADOW1") + (:size 10) + (:nicknames "TB-FOO-NICKNAME-1" "TB-FOO-NICKNAME-2") + (:shadow "SHADOW1") + (:shadowing-import-from cl "CAR") + (:intern "S1") + (:shadowing-import-from cl) + (:use tb-bar-to-use) + (:nicknames "TB-FOO-NICKNAME-0") + (:shadowing-import-from cl "CDR") + (:shadow "SHADOW2") + (:import-from keyword "TEST") + (:intern "S0") + ;;(:documentation "doc") + (:nicknames) + (:export "CAR"))) + (equal (multiple-value-list (find-symbol "BUZ" 'tb-foo-nickname-0)) + (list buz :inherited)) + (eq (cadr (multiple-value-list (find-symbol "SHADOW1" 'tb-foo-nickname-2))) + :external) + (eq (cadr (multiple-value-list (find-symbol "SHADOW2" 'tb-foo-nickname-2))) + :internal) + (equal (multiple-value-list (find-symbol "CAR" 'tb-foo-nickname-2)) + (list 'cl:car :external)) + (equal (multiple-value-list (find-symbol "CDR" 'tb-foo-nickname-2)) + (list 'cl:cdr :internal)) + (equal (multiple-value-list (find-symbol "TEST" 'tb-foo-nickname-2)) + (list :test :internal)) + (eq (cadr (multiple-value-list (find-symbol "S0" 'tb-foo-nickname-2))) + :internal) + (eq (cadr (multiple-value-list (find-symbol "S1" 'tb-foo-nickname-2))) + :internal) + ))) + + + + + +;; with-package-iterator +(with-package-iterator (get "CL" :external) + (multiple-value-bind (more symbol status pkg) (get) (declare (ignore more)) + (and (symbolp symbol) (eq status :external) (eq pkg (find-package 'cl))))) + +(with-package-iterator (get 'cl :external) + (multiple-value-bind (more symbol status pkg) (get) (declare (ignore more)) + (and (symbolp symbol) (eq status :external) (eq pkg (find-package 'cl))))) + +(with-package-iterator (get (find-package 'cl) :external) + (multiple-value-bind (more symbol status pkg) (get) (declare (ignore more)) + (and (symbolp symbol) (eq status :external) (eq pkg (find-package 'cl))))) + +(with-package-iterator (get '(cl) :external) + (multiple-value-bind (more symbol status pkg) (get) (declare (ignore more)) + (and (symbolp symbol) (eq status :external) (eq pkg (find-package 'cl))))) + +(with-package-iterator (get (list "CL") :external) + (multiple-value-bind (more symbol status pkg) (get) (declare (ignore more)) + (and (symbolp symbol) (eq status :external) (eq pkg (find-package 'cl))))) + +(with-package-iterator (get (list (find-package "COMMON-LISP")) :external) + (multiple-value-bind (more symbol status pkg) (get) (declare (ignore more)) + (and (symbolp symbol) (eq status :external) (eq pkg (find-package 'cl))))) + +(with-package-iterator (get 'cl :external :internal :inherited) + (multiple-value-bind (more symbol status pkg) (get) + (declare (ignore more)) + (and (symbolp symbol) + (member status '(:external :internal :inherited)) + (eq pkg (find-package 'cl))))) + +(with-package-iterator (get (list 'cl) :internal) + (multiple-value-bind (more symbol status pkg) (get) + (or (not more) + (and (symbolp symbol) + (eq status :internal) + (eq pkg (find-package 'cl)))))) + +(with-package-iterator (get (list 'cl) :inherited) + (multiple-value-bind (more symbol status pkg) (get) + (or (not more) + (and (symbolp symbol) + (eq status :inherited) + (eq pkg (find-package 'cl)))))) + +;;; cmucl barfs on (macrolet () (declare)) +(progn + #-cmu + (with-package-iterator (get "CL" :external) + (declare (optimize (safety 3))) + (multiple-value-bind (more symbol status pkg) (get) + (declare (ignore more)) + (and (symbolp symbol) (eq status :external) (eq pkg (find-package 'cl))))) + #+cmu 'skipped) +(progn + (when (find-package "TB-FOO") + (delete-package "TB-FOO")) + (let ((package (make-package "TB-FOO" :use nil)) + list) + (with-package-iterator (get package :internal) + (and (loop + (multiple-value-bind (more symbol status pkg) (get) + (declare (ignore status pkg)) + (unless more (return t)) + (push symbol list))) + (null list))))) +(progn + (when (find-package "TB-FOO") + (delete-package "TB-FOO")) + (let ((package (make-package "TB-FOO" :use nil))) + (dolist (name '(a b c d e f g "S1" "S2" "ss")) + (intern name package)) + (with-package-iterator (get package :internal) + (loop + (multiple-value-bind (more symbol status pkg) (get) + (unless more (return t)) + (unless (and (eq status :internal) + (eq pkg package) + (eq symbol (find-symbol (string symbol) pkg))) + (return nil))))))) +(progn + (when (find-package #\a) + (delete-package #\a)) + (let ((package (make-package #\a :use nil))) + (dolist (name '(a b c d e f g "S1" "S2" "ss")) + (intern name package)) + (with-package-iterator (get #\a :internal) + (loop + (multiple-value-bind (more symbol status pkg) (get) + (unless more (return t)) + (unless (and (eq status :internal) + (eq pkg package) + (eq symbol (find-symbol (string symbol) pkg))) + (return nil))))))) +(progn + (when (find-package #\a) + (delete-package #\a)) + (let ((package (make-package #\a :use nil))) + (dolist (name '(a b c d e f g "S1" "S2" "ss")) + (intern name package)) + (with-package-iterator (get (list #\a) :internal) + (loop + (multiple-value-bind (more symbol status pkg) (get) + (unless more (return t)) + (unless (and (eq status :internal) + (eq pkg package) + (eq symbol (find-symbol (string symbol) pkg))) + (return nil))))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (when (find-package "TB-BAR-TO-USE") + (mapcan #'delete-package (package-used-by-list "TB-BAR-TO-USE")) + (delete-package "TB-BAR-TO-USE")) + (let* ((package (make-package "TB-BAR-TO-USE" :use nil)) + (package-1 (make-package "TB-FOO" :use (list package))) + (symbol-list nil)) + (export (intern "S" package) package) + (shadow '("S") package-1) + (with-package-iterator (get package-1 :internal :external :inherited) + (loop + (multiple-value-bind (more symbol status pkg) (get) + (declare (ignore status pkg)) + (unless more (return t)) + (push symbol symbol-list)))) + (not (member (intern "S" package) symbol-list)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let* ((package (make-package "TB-FOO" :use nil)) + (symbol-list nil)) + (with-package-iterator (get package :internal :external) + (loop + (multiple-value-bind (more symbol status pkg) (get) + (declare (ignore status pkg)) + (unless more (return t)) + (push symbol symbol-list)))) + (null symbol-list))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let* ((package (make-package "TB-FOO" :use nil)) + (symbol-list '(a b c d car cdr i lisp)) + (list nil)) + (dolist (symbol symbol-list) + (shadowing-import symbol package)) + (with-package-iterator (get package :internal) + (loop + (multiple-value-bind (more symbol status pkg) (get) + (declare (ignore status pkg)) + (unless more (return t)) + (push symbol list)))) + (null (set-difference symbol-list list)))) +(with-package-iterator (get 'cl :external) + (loop + (multiple-value-bind (more symbol status package) (get) + (unless more (return t)) + (unless (and (eq status :external) + (eq package (find-package 'cl)) + (eq symbol (find-symbol (symbol-name symbol) 'cl-user))) + (return nil))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let* ((package (make-package "TB-FOO" :use 'cl))) + (shadow '("CAR") package) + (with-package-iterator (get package :external :inherited :internal) + (loop + (multiple-value-bind (more symbol status pkg) (get) + (declare (ignore pkg status)) + (unless more (return t)) + (when (eq symbol 'cl:car) (return nil))))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let* ((*package* (make-package "TB-FOO" :use nil)) + (names '("BLACK" "RED" "WHITE" "YELLOW" "VIOLET" "BROWN" "BLUE")) + list) + (mapc #'intern names) + (export (mapcar #'find-symbol + (mapcan #'(lambda (name) + (when (= (length name) 5) (list name))) names))) + (with-package-iterator (get *package* :external :inherited :internal) + (loop + (multiple-value-bind (more symbol status pkg) (get) + (declare (ignore pkg)) + (unless more (return)) + (push (symbol-name symbol) (getf list status))))) + (and (null (set-difference (getf list :external) '("BLACK" "WHITE" "BROWN") + :test #'string=)) + (null (set-difference (getf list :internal) + '("RED" "YELLOW" "VIOLET" "BLUE") + :test #'string=)) + (null (getf list :inherited))))) + + +(flet ((test-package-iterator (package) + (unless (packagep package) + (setq package (find-package package))) + (let ((all-entries '()) + (generated-entries '())) + (do-symbols (x package) + (multiple-value-bind (symbol accessibility) + (find-symbol (symbol-name x) package) + (push (list symbol accessibility) all-entries))) + (with-package-iterator (generator-fn package + :internal :external :inherited) + (loop + (multiple-value-bind (more? symbol accessibility pkg) + (generator-fn) + (declare (ignore pkg)) + (unless more? (return)) + (let ((l (multiple-value-list (find-symbol (symbol-name symbol) + package)))) + (unless (equal l (list symbol accessibility)) + (error "Symbol ~S not found as ~S in package ~A [~S]" + symbol accessibility (package-name package) l)) + (push l generated-entries))))) + (unless (and (subsetp all-entries generated-entries :test #'equal) + (subsetp generated-entries all-entries :test #'equal)) + (error "Generated entries and Do-Symbols entries don't correspond")) + t))) + (every #'test-package-iterator '("CL" "CL-USER" "KEYWORD"))) + + +;; do-symbols +(null (do-symbols (symbol) (declare (ignore symbol)))) +(null (do-symbols (symbol *package*) (declare (ignore symbol)))) +(null (do-external-symbols (symbol) (declare (ignore symbol)))) +(null (do-external-symbols (symbol *package*) (declare (ignore symbol)))) +(null (do-all-symbols (symbol) (declare (ignore symbol)))) +(do-symbols (symbol *package* (null symbol))) +(do-external-symbols (symbol *package* (null symbol))) +(do-all-symbols (symbol (null symbol))) +(do-symbols (symbol 'CL nil) (declare (ignore symbol)) (return t)) +(do-external-symbols (symbol 'CL nil) (declare (ignore symbol)) (return t)) +(do-all-symbols (symbol nil) (declare (ignore symbol)) (return t)) +(do-symbols (symbol 'cl nil) + (go start) + found + (return t) + start + (when (eq symbol 'cl:car) + (go found))) +(do-external-symbols (symbol 'cl nil) + (go start) + found + (return t) + start + (when (eq symbol 'cl:car) + (go found))) +(do-all-symbols (symbol nil) + (go start) + found + (return t) + start + (when (eq symbol 'cl:car) + (go found))) +(let ((i 0) + (list nil) + (*package* (find-package "COMMON-LISP-USER"))) + (do-symbols (symbol) + (push symbol list) + (incf i) + (when (= i 10) (return))) + (every #'symbolp list)) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use nil)) + (name-list '("A" "B" "DOG" "CAT" "giraffe" "hippo" "wolf")) + (list)) + (export (mapcar #'intern name-list)) + (null (set-difference (do-symbols (symbol *package* list) + (pushnew symbol list)) + (mapcar #'find-symbol name-list))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use nil)) + list) + (do-symbols (symbol *package*) (push symbol list)) + (null list))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use nil)) + list) + (do-symbols (symbol) (push symbol list)) + (null list))) +(do-symbols (symbol 'cl t) + (unless (eq symbol (find-symbol (symbol-name symbol) 'cl)) + (return nil))) +(do-symbols (symbol 'keyword t) + (unless (equal + (multiple-value-list (find-symbol (symbol-name symbol) 'keyword)) + (list symbol :external)) + (return nil))) + + +;; do-external-symbols +(let (list1 list2) + (and (do-external-symbols (symbol 'keyword t) (push symbol list1)) + (do-symbols (symbol 'keyword t) (push symbol list2)) + (null (set-difference list1 list2)))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use nil)) + list) + (do-external-symbols (symbol *package*) (push symbol list)) + (null list))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use nil)) + list) + (do-external-symbols (symbol) (push symbol list)) + (null list))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use nil)) + (name-list '("A" "B" "DOG" "CAT" "giraffe" "hippo" "wolf")) + (list)) + (export (mapcar #'intern name-list)) + (null (set-difference (do-external-symbols (symbol *package* list) + (pushnew symbol list)) + (mapcar #'find-symbol name-list))))) +(progn + (when (find-package "TB-FOO") (delete-package "TB-FOO")) + (let ((*package* (make-package "TB-FOO" :use nil)) + (name-list '("A" "B" "DOG" "CAT" "giraffe" "hippo" "wolf")) + (list)) + (mapcar #'intern name-list) + (null (do-external-symbols (symbol *package* list) + (pushnew symbol list))))) + + +;; do-all-symbols +(let ((i 0) + (list nil)) + (do-all-symbols (symbol) + (push symbol list) + (incf i) + (when (= i 10) (return))) + (every #'symbolp list)) +(let ((list nil)) + (do-all-symbols (symbol) (push symbol list)) + (with-package-iterator (get (list-all-packages) :external :internal) + (loop + (multiple-value-bind (more symbol status package) (get) + (declare (ignore status package)) + (unless more (return t)) + (unless (member symbol list) (return nil)))))) + diff --git a/Sacla/tests/must-package.patch b/Sacla/tests/must-package.patch new file mode 100644 index 0000000..0bc747e --- /dev/null +++ b/Sacla/tests/must-package.patch @@ -0,0 +1,12 @@ +*** sacla/lisp/test/must-package.lisp 2004-08-03 08:34:55.000000000 +0200 +--- CLISP/clisp-20040712/sacla-tests/must-package.lisp 2004-08-06 03:13:08.000000000 +0200 +*************** +*** 1459,1464 **** +--- 1459,1465 ---- + '("TB-FOO" "TB-FOO-NICKNAME-1" "TB-FOO-NICKNAME-2" "TB-FOO-NICKNAME-3")) + (and (packagep (defpackage "TB-FOO" (:nicknames tb-foo-nickname-1))) + (equal (package-nicknames 'tb-foo) '("TB-FOO-NICKNAME-1")))) ++ #-CLISP ; unfounded assumptions about the order of the package-nicknames list + (progn + (mapc #'(lambda (name) (when (find-package name) (delete-package name))) + '("TB-FOO" "TB-FOO-NICKNAME-1" "TB-FOO-NICKNAME-2" "TB-FOO-NICKNAME-3")) diff --git a/Sacla/tests/must-printer.lisp b/Sacla/tests/must-printer.lisp new file mode 100644 index 0000000..33a43ee --- /dev/null +++ b/Sacla/tests/must-printer.lisp @@ -0,0 +1,1610 @@ +;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp> +;; ALL RIGHTS RESERVED. +;; +;; $Id: must-printer.lisp,v 1.16 2004/08/09 02:49:54 yuji Exp $ +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; * Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; * Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;; printer control variables +(eql *print-base* 10) +(null *print-radix*) +(eq *print-case* :upcase) +*print-gensym* +(null *print-level*) +(null *print-length*) +(null *print-circle*) +*print-escape* +(null *print-readably*) +*print-pprint-dispatch* +(null *print-lines*) +(null *print-right-margin*) + + +;; string +(string= "abc" (write-to-string "abc" :escape nil)) +(string= "\"abc\"" (write-to-string "abc" :readably t)) +(string= "\"abc\"" (write-to-string "abc" :escape nil :readably t)) + +(string= "ABC" (write-to-string "ABC" :escape nil)) +(string= "\"ABC\"" (write-to-string "ABC" :readably t)) +(string= "\"ABC\"" (write-to-string "ABC" :escape nil :readably t)) + +(string= "\"A\\\\B\\\"C\"" (write-to-string "A\\B\"C" :escape nil :readably t)) +(string= "\"A\\\\B\\\"C\"" (write-to-string "A\\B\"C")) +(string= "A\\B\"C" (write-to-string "A\\B\"C" :escape nil)) +(let ((str "a\\b\"")) + (and (= 4 (length str)) + (string= str (read-from-string (write-to-string str))))) +(let ((str "a\\b\"")) + (and (= 4 (length str)) + (string= str (read-from-string + (write-to-string str :escape nil :readably t))))) + +(string= "\"\\\"\"" (write-to-string "\"")) +(string= "\"\\\"\"" (write-to-string "\"" :escape nil :readably t)) +(string= "\"" (read-from-string (write-to-string "\""))) +(string= "\"" (read-from-string (write-to-string "\"" :escape nil :readably t))) + +(string= "\"\"" (write-to-string "")) +(string= "\"\"" (write-to-string "" :escape nil :readably t)) +(string= "" (write-to-string "" :escape nil)) + +(string= "\" \"" (write-to-string " ")) +(string= "\" \"" (write-to-string " " :escape nil :readably t)) +(string= " " (write-to-string " " :escape nil)) + +(string= "\" \"" (write-to-string " ")) +(string= "\" \"" (write-to-string " " :escape nil :readably t)) +(string= " " (write-to-string " " :escape nil)) + +(string= "\" +\"" (write-to-string " +" :escape nil :readably t)) +(string= " +" (write-to-string " +" :escape nil)) + + +(string= "\"\\\"\\\"\\\"\\\"\\\"\\\"\"" + (write-to-string "\"\"\"\"\"\"" :readably t)) +(string= "\"\"\"\"\"\"" + (read-from-string (write-to-string "\"\"\"\"\"\"" :readably t))) +(string= "\"\"\"\"\"\"" + (write-to-string "\"\"\"\"\"\"" :readably nil :escape nil)) +(string= "\" \"" + (write-to-string " " :readably t)) + +(string= "\"\\\"Hi\\\" \\\"Oh, hi!\\\"\"" + (write-to-string "\"Hi\" \"Oh, hi!\"" :readably t)) +(string= "\"Hi\" \"Oh, hi!\"" + (write-to-string "\"Hi\" \"Oh, hi!\"" + :pretty nil :readably nil :escape nil)) + +(string= "abc" + (write-to-string "abc" :array nil :escape nil) + ;; 22.1.3.4 Printing Strings + ;; http://www.lispworks.com/reference/HyperSpec/Body/22_acd.htm + ;; The printing of strings is not affected by *print-array*. + ) + + + +(string= "abc" + (write-to-string (make-array 10 + :element-type 'character + :initial-contents "abcdefghij" + :fill-pointer 3) + :escape nil)) + + + +;; integer, *print-base*, *print-radix* +(string= (write-to-string 0) "0") +(string= (write-to-string -0) "0") +(string= (write-to-string 9) "9") +(string= (write-to-string -10) "-10") +(string= (write-to-string 1234567890987654321234567890987654321) + "1234567890987654321234567890987654321") +(let ((*print-radix* t)) (string= (write-to-string 0) "0.")) +(let ((*print-radix* t)) (string= (write-to-string -52) "-52.")) +(let ((*print-radix* t)) + (string= (write-to-string -1234567890987654321234567890987654321) + "-1234567890987654321234567890987654321.")) + +(let ((*print-base* 2)) (string= (write-to-string 0) "0")) +(let ((*print-base* 2)) (string= (write-to-string 10) "1010")) +(let ((*print-base* 2)) + (string= (write-to-string -1234567890987654321234567890987654321) + "-111011011100010011100101100000010011000101110111101001110100010101110010000101001111011010110110001011000001110010110001")) +(let ((*print-base* 2) (*print-radix* t)) + (string= (write-to-string 11) "#b1011")) +(let ((*print-base* 2) (*print-radix* t)) + (string= (write-to-string -15) "#b-1111")) +(let ((*print-base* 2) (*print-radix* t)) + (string= (write-to-string 1234567890987654321234567890987654321) + "#b111011011100010011100101100000010011000101110111101001110100010101110010000101001111011010110110001011000001110010110001")) + + +(let ((*print-base* 8)) (string= (write-to-string 10) "12")) +(let ((*print-base* 8)) (string= (write-to-string -21) "-25")) +(let ((*print-base* 8) (*print-radix* t)) + (string= (write-to-string 11) "#o13")) +(let ((*print-base* 8) (*print-radix* t)) + (string= (write-to-string -13) "#o-15")) +(let ((*print-base* 8)) + (string= (write-to-string 1234567890987654321234567890987654321) + "7334234540230567516425620517326613016261")) +(let ((*print-base* 8) (*print-radix* t)) + (string= (write-to-string -1234567890987654321234567890987654321) + "#o-7334234540230567516425620517326613016261")) + + +(let ((*print-base* 16)) (string= (write-to-string 20) "14")) +(let ((*print-base* 16)) (string= (write-to-string -22) "-16")) +(let ((*print-base* 16)) (string= (string-upcase (write-to-string -30)) "-1E")) +(let ((*print-base* 16) (*print-radix* t)) + (string= (write-to-string 21) "#x15")) +(let ((*print-base* 16) (*print-radix* t)) + (string= (write-to-string -23) "#x-17")) +(let ((*print-base* 16)) + (string= (string-upcase (write-to-string 1234567890987654321234567890987654321)) + "EDC4E5813177A7457214F6B62C1CB1")) +(let ((*print-base* 16) (*print-radix* t)) + (string= (string-upcase (write-to-string -1234567890987654321234567890987654321)) + "#X-EDC4E5813177A7457214F6B62C1CB1")) + +(let ((*print-base* 24.)) (string= (write-to-string 9) "9")) +(let ((*print-base* 24.)) + (string= (string-upcase (write-to-string 17)) "H")) +(let ((*print-base* 24.)) + (string= (string-upcase (write-to-string -17)) "-H")) +(let ((*print-base* 24.) (*print-radix* t)) + (string= (write-to-string 9.) "#24r9")) +(let ((*print-base* 24.) (*print-radix* t)) + (string-equal (write-to-string 23.) "#24rN")) +(let ((*print-base* 24.) (*print-radix* t)) + (string-equal (write-to-string -23.) "#24r-N")) +(let ((*print-base* 24)) + (string= (string-upcase (write-to-string 1234567890987654321234567890987654321)) + "1EDFC9EAF544D8D12FI44J4FMCH")) + +(loop for *print-base* from 2 upto 36 + always (string= (write-to-string 0) "0")) +(loop for *print-base* from 2 upto 36 + always (string= (write-to-string -1) "-1")) +(loop for *print-base* from 2 upto 36 + always (string= (string-upcase (write-to-string (1- *print-base*))) + (string (char "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" + (1- *print-base*))))) +(loop for *print-base* from 2 upto 36 + always (string= (write-to-string *print-base*) "10")) +(let ((list nil)) + (equal (dotimes (i 35 (reverse list)) + (let ((*print-base* (+ i 2))) + ;;collect the decimal number 40 in each base from 2 to 36 + (push (string-upcase (write-to-string 40)) list))) + '("101000" "1111" "220" "130" "104" "55" "50" "44" "40" "37" "34" + "31" "2C" "2A" "28" "26" "24" "22" "20" "1J" "1I" "1H" "1G" "1F" + "1E" "1D" "1C" "1B" "1A" "19" "18" "17" "16" "15" "14"))) +(let ((list nil)) + (equal (dotimes (i 35 (reverse list)) + (let ((*print-base* (+ i 2)) + (*print-radix* t)) + ;;collect the decimal number 40 in each base from 2 to 36 + (push (string-upcase (write-to-string 40)) list))) + '("#B101000" "#3R1111" "#4R220" "#5R130" "#6R104" "#7R55" "#O50" + "#9R44" "40." "#11R37" "#12R34" "#13R31" "#14R2C" "#15R2A" + "#X28" "#17R26" "#18R24" "#19R22" "#20R20" "#21R1J" "#22R1I" + "#23R1H" "#24R1G" "#25R1F" "#26R1E" "#27R1D" "#28R1C" "#29R1B" + "#30R1A" "#31R19" "#32R18" "#33R17" "#34R16" "#35R15" "#36R14"))) + + +;; ratio, *print-base*, *print-radix* +(string= (write-to-string 1/3) "1/3") +(string= (write-to-string -1/2) "-1/2") +(string= (write-to-string -3/5) "-3/5") +(let ((*print-radix* t)) + ;; Variable *PRINT-BASE*, *PRINT-RADIX* + ;; http://www.lispworks.com/reference/HyperSpec/Body/v_pr_bas.htm + ;; For integers, base ten is indicated by a trailing decimal point instead + ;; of a leading radix specifier; for ratios, #10r is used. + (string= (write-to-string 1/15) "#10r1/15")) +(let ((*print-radix* t)) + (string= (write-to-string -4/15) "#10r-4/15")) +(string= (write-to-string 2/1234567890987654321234567890987654321) + "2/1234567890987654321234567890987654321") +(string= (write-to-string 1234567890987654321234567890987654321/4) + "1234567890987654321234567890987654321/4") +(let ((*print-radix* t)) + (string= (write-to-string 2/1234567890987654321234567890987654321) + "#10r2/1234567890987654321234567890987654321")) + +(let ((*print-base* 2)) (string= (write-to-string 1/3) "1/11")) +(let ((*print-base* 2)) (string= (write-to-string -1/2) "-1/10")) +(let ((*print-base* 2)) (string= (write-to-string -3/5) "-11/101")) +(let ((*print-base* 2) (*print-radix* t)) + (string= (write-to-string 1/15) "#b1/1111")) +(let ((*print-base* 2) (*print-radix* t)) + (string= (write-to-string -3/16) "#b-11/10000")) +(let ((*print-base* 2)) + (string= (write-to-string 2/1234567890987654321234567890987654321) + "10/111011011100010011100101100000010011000101110111101001110100010101110010000101001111011010110110001011000001110010110001")) +(let ((*print-base* 2)) + (string= (write-to-string -1234567890987654321234567890987654321/2) + "-111011011100010011100101100000010011000101110111101001110100010101110010000101001111011010110110001011000001110010110001/10")) +(let ((*print-base* 2) (*print-radix* t)) + (string= (write-to-string 2/1234567890987654321234567890987654321) + "#b10/111011011100010011100101100000010011000101110111101001110100010101110010000101001111011010110110001011000001110010110001")) + +(let ((*print-base* 8)) (string= (write-to-string 1/3) "1/3")) +(let ((*print-base* 8)) (string= (write-to-string -1/4) "-1/4")) +(let ((*print-base* 8)) (string= (write-to-string -3/7) "-3/7")) +(let ((*print-base* 8) + (*print-radix* t)) + (string= (write-to-string 1/3) "#o1/3")) +(let ((*print-base* 8) + (*print-radix* t)) + (string= (write-to-string -3/7) "#o-3/7")) +(let ((*print-base* 8) + (*print-radix* t)) + (string= (write-to-string -15/11) "#o-17/13")) +(let ((*print-base* 8)) + (string= (write-to-string 2/1234567890987654321234567890987654321) + "2/7334234540230567516425620517326613016261")) +(let ((*print-base* 8) + (*print-radix* t)) + (string= (write-to-string -1234567890987654321234567890987654321/4) + "#o-7334234540230567516425620517326613016261/4")) + +(let ((*print-base* 16)) (string= (write-to-string 1/8) "1/8")) +(let ((*print-base* 16)) (string= (write-to-string -1/9) "-1/9")) +(let ((*print-base* 16)) (string-equal (write-to-string -9/10) "-9/A")) +(let ((*print-base* 16) + (*print-radix* t)) + (string= (write-to-string 1/3) "#x1/3")) +(let ((*print-base* 16) + (*print-radix* t)) + (string= (write-to-string 3/8) "#x3/8")) +(let ((*print-base* 16) + (*print-radix* t)) + (string= (write-to-string -4/9) "#x-4/9")) +(let ((*print-base* 16)) + (string= (write-to-string 2/1234567890987654321234567890987654321) + "2/EDC4E5813177A7457214F6B62C1CB1")) +(let ((*print-base* 16) + (*print-radix* t)) + (string-equal (write-to-string 1234567890987654321234567890987654321/4) + "#xEDC4E5813177A7457214F6B62C1CB1/4")) +(let ((*print-base* 16) + (*print-radix* t)) + (string-equal (write-to-string 1234567890987654321234567890987654321/1234) + "#xEDC4E5813177A7457214F6B62C1CB1/4D2")) + +(let ((*print-base* 21)) (string= (write-to-string 1/8) "1/8")) +(let ((*print-base* 21)) (string= (write-to-string -1/9) "-1/9")) +(let ((*print-base* 21)) (string-equal (write-to-string -9/10) "-9/A")) +(let ((*print-base* 21) + (*print-radix* t)) + (string= (write-to-string 1/4) "#21r1/4")) +(let ((*print-base* 21) + (*print-radix* t)) + (string-equal (write-to-string -1/20) "#21r-1/K")) +(let ((*print-base* 21)) + (string= (write-to-string 2/1234567890987654321234567890987654321) + "2/29FADE40CGDJK4D0654KEAD5K6EK")) +(let ((*print-base* 21) + (*print-radix* t)) + (string-equal (write-to-string 1234567890987654321234567890987654321/1234) + "#21r29FADE40CGDJK4D0654KEAD5K6EK/2GG")) + +(loop for *print-base* from 3 upto 36 + always (string= (write-to-string 1/2) "1/2")) +(loop for *print-base* from 4 upto 36 + always (string= (write-to-string -1/3) "-1/3")) +(loop for *print-base* from 3 upto 36 + always (string= + (string-upcase (write-to-string (/ 1 (1- *print-base*)))) + (concatenate 'string + "1/" + (string (char "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" + (1- *print-base*)))))) +(loop for *print-base* from 2 upto 36 + always (string= (write-to-string (/ 1 *print-base*)) "1/10")) +(let ((list nil)) + (equal (dotimes (i 35 (reverse list)) + (let ((*print-base* (+ i 2))) + ;;collect the decimal number 40 in each base from 2 to 36 + (push (string-upcase (write-to-string 41/40)) list))) + '("101001/101000" "1112/1111" "221/220" "131/130" "105/104" + "56/55" "51/50" "45/44" "41/40" "38/37" "35/34" + "32/31" "2D/2C" "2B/2A" "29/28" "27/26" "25/24" "23/22" "21/20" + "1K/1J" "1J/1I" "1I/1H" "1H/1G" "1G/1F" + "1F/1E" "1E/1D" "1D/1C" "1C/1B" "1B/1A" "1A/19" "19/18" "18/17" + "17/16" "16/15" "15/14"))) +(let ((list nil)) + (equal (dotimes (i 35 (reverse list)) + (let ((*print-base* (+ i 2)) + (*print-radix* t)) + ;;collect the decimal number 40 in each base from 2 to 36 + (push (string-upcase (write-to-string 41/40)) list))) + '("#B101001/101000" "#3R1112/1111" "#4R221/220" "#5R131/130" + "#6R105/104" "#7R56/55" "#O51/50" "#9R45/44" "#10R41/40" + "#11R38/37" "#12R35/34" "#13R32/31" "#14R2D/2C" "#15R2B/2A" + "#X29/28" "#17R27/26" "#18R25/24" "#19R23/22" "#20R21/20" + "#21R1K/1J" "#22R1J/1I" "#23R1I/1H" "#24R1H/1G" "#25R1G/1F" + "#26R1F/1E" "#27R1E/1D" "#28R1D/1C" "#29R1C/1B" "#30R1B/1A" + "#31R1A/19" "#32R19/18" "#33R18/17" "#34R17/16" "#35R16/15" + "#36R15/14"))) + +;; character +(let ((*print-escape* nil)) + (string= (write-to-string #\a) "a")) +(let ((*print-escape* nil) + (*print-readably* nil)) + (string= (write-to-string #\d) "d")) +(let ((*print-escape* nil)) + (string= (write-to-string #\m) "m")) +(let ((*print-escape* nil)) + (string= (write-to-string #\z) "z")) +(let ((*print-escape* nil) + (*print-readably* nil)) + (loop for c across " !\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_'abcdefghijklmnopqrstuvwxyz{|}~" + always (string= (write-to-string c) (string c)))) +(let ((*print-escape* nil)) + (loop for c across " !\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_'abcdefghijklmnopqrstuvwxyz{|}~" + always (string= (write-to-string c) (string c)))) + +(string= (write-to-string #\b) "#\\b") +(string= (write-to-string #\n) "#\\n") +(string= (write-to-string #\x) "#\\x") +(let ((*print-escape* nil) + (*print-readably* t)) + (string= (write-to-string #\c) "#\\c")) +(loop for c across "!#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[]^_'abcdefghijklmnopqrstuvwxyz{|}~" + always (string= (write-to-string c) (concatenate 'string "#\\" (string c)))) +(string= (write-to-string #\\) "#\\\\") +(string= (write-to-string #\") "#\\\"") +(let ((*print-readably* t) + (*print-escape* nil)) + (loop for c across "!#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[]^_'abcdefghijklmnopqrstuvwxyz{|}~" + always (string= (write-to-string c) (concatenate 'string "#\\" (string c))))) +(let ((*print-readably* t) + (*print-escape* t)) + (loop for c across "!#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[]^_'abcdefghijklmnopqrstuvwxyz{|}~" + always (string= (write-to-string c) (concatenate 'string "#\\" (string c))))) +(let ((*print-readably* nil) + (*print-escape* t)) + (loop for c across "!#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[]^_'abcdefghijklmnopqrstuvwxyz{|}~" + always (string= (write-to-string c) (concatenate 'string "#\\" (string c))))) + +(progn + (let ((*print-readably* t)) + ;; 22.1.3.2 Printing Characters + ;; http://www.lispworks.com/reference/HyperSpec/Body/22_acb.htm + ;; For the graphic standard characters, the character itself is always used + ;; for printing in #\ notation---even if the character also has a name[5]. + ;; + ;; http://www.lispworks.com/reference/HyperSpec/Body/26_glo_g.htm#graphic + ;; graphic adj. -snip- Space is defined to be graphic. + (string= (write-to-string #\Space) "#\\ ")) + 'skipped) + + +;;; symbol +;; accessible symbol, escaping off, *print-case* :capitalize +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :upcase) + (string= "abc" (write-to-string '|abc| :escape nil :case :capitalize))) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :downcase) + (string= "Abc" (write-to-string '|abc| :escape nil :case :capitalize))) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :preserve) + (string= "abc" (write-to-string '|abc| :escape nil :case :capitalize))) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :invert) + (string= "ABC" (write-to-string '|abc| :escape nil :case :capitalize))) + + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :upcase) + (string= "Abc" (write-to-string '|ABC| :escape nil :case :capitalize))) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :downcase) + (string= "ABC" (write-to-string '|ABC| :escape nil :case :capitalize))) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :preserve) + (string= "ABC" (write-to-string '|ABC| :escape nil :case :capitalize))) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :invert) + (string= "abc" (write-to-string '|ABC| :escape nil :case :capitalize))) + + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :upcase) + (string= "Abc-abc" + (write-to-string '|ABC-abc| :escape nil :case :capitalize))) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :downcase) + (string= "ABC-Abc" + (write-to-string '|ABC-abc| :escape nil :case :capitalize))) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :preserve) + (string= "ABC-abc" + (write-to-string '|ABC-abc| :escape nil :case :capitalize))) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :invert) + (string= "ABC-abc" + (write-to-string '|ABC-abc| :escape nil :case :capitalize))) + + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :upcase) + (string= "abc-Abc" + (write-to-string '|abc-ABC| :escape nil :case :capitalize))) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :downcase) + (string= "Abc-ABC" + (write-to-string '|abc-ABC| :escape nil :case :capitalize))) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :preserve) + (string= "abc-ABC" + (write-to-string '|abc-ABC| :escape nil :case :capitalize))) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :invert) + (string= "abc-ABC" + (write-to-string '|abc-ABC| :escape nil :case :capitalize))) + + +;; accessible symbol, escaping off, *print-case* :upcase +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :upcase) + (string= "abc" (write-to-string '|abc| :escape nil :case :upcase))) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :downcase) + (string= "ABC" (write-to-string '|abc| :escape nil :case :upcase))) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :preserve) + (string= "abc" (write-to-string '|abc| :escape nil :case :upcase))) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :invert) + (string= "ABC" (write-to-string '|abc| :escape nil :case :upcase))) + + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :upcase) + (string= "ABC" (write-to-string '|ABC| :escape nil :case :upcase))) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :downcase) + (string= "ABC" (write-to-string '|ABC| :escape nil :case :upcase))) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :preserve) + (string= "ABC" (write-to-string '|ABC| :escape nil :case :upcase))) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :invert) + (string= "abc" (write-to-string '|ABC| :escape nil :case :upcase))) + + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :upcase) + (string= "ABC-abc" (write-to-string '|ABC-abc| :escape nil :case :upcase))) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :downcase) + (string= "ABC-ABC" (write-to-string '|ABC-abc| :escape nil :case :upcase))) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :preserve) + (string= "ABC-abc" (write-to-string '|ABC-abc| :escape nil :case :upcase))) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :invert) + (string= "ABC-abc" (write-to-string '|ABC-abc| :escape nil :case :upcase))) + + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :upcase) + (string= "abc-ABC" (write-to-string '|abc-ABC| :escape nil :case :upcase))) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :downcase) + (string= "ABC-ABC" (write-to-string '|abc-ABC| :escape nil :case :upcase))) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :preserve) + (string= "abc-ABC" (write-to-string '|abc-ABC| :escape nil :case :upcase))) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :invert) + (string= "abc-ABC" (write-to-string '|abc-ABC| :escape nil :case :upcase))) + + +;; accessible symbol, escaping off, *print-case* :downcase +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :upcase) + (string= "abc" (write-to-string '|abc| :escape nil :case :downcase))) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :downcase) + (string= "abc" (write-to-string '|abc| :escape nil :case :downcase))) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :preserve) + (string= "abc" (write-to-string '|abc| :escape nil :case :downcase))) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :invert) + (string= "ABC" (write-to-string '|abc| :escape nil :case :downcase))) + + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :upcase) + (string= "abc" (write-to-string '|ABC| :escape nil :case :downcase))) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :downcase) + (string= "ABC" (write-to-string '|ABC| :escape nil :case :downcase))) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :preserve) + (string= "ABC" (write-to-string '|ABC| :escape nil :case :downcase))) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :invert) + (string= "abc" (write-to-string '|ABC| :escape nil :case :downcase))) + + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :upcase) + (string= "abc-abc" (write-to-string '|ABC-abc| :escape nil :case :downcase))) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :downcase) + (string= "ABC-abc" (write-to-string '|ABC-abc| :escape nil :case :downcase))) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :preserve) + (string= "ABC-abc" (write-to-string '|ABC-abc| :escape nil :case :downcase))) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :invert) + (string= "ABC-abc" (write-to-string '|ABC-abc| :escape nil :case :downcase))) + + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :upcase) + (string= "abc-abc" (write-to-string '|abc-ABC| :escape nil :case :downcase))) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :downcase) + (string= "abc-ABC" (write-to-string '|abc-ABC| :escape nil :case :downcase))) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :preserve) + (string= "abc-ABC" (write-to-string '|abc-ABC| :escape nil :case :downcase))) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :invert) + (string= "abc-ABC" (write-to-string '|abc-ABC| :escape nil :case :downcase))) + + + +;; keyword symbol, escaping off +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :upcase) + (string= "abc-Abc" + (write-to-string ':|abc-ABC| :escape nil :case :capitalize))) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :upcase) + (string= "abc-ABC" (write-to-string ':|abc-ABC| :escape nil :case :upcase))) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :upcase) + (string= "abc-abc" (write-to-string ':|abc-ABC| :escape nil :case :downcase))) + + +;; non accessible symbol, escaping off +(let ((*readtable* (copy-readtable nil))) + (when (find-package "TEST-PKG0") (delete-package "TEST-PKG0")) + (make-package "TEST-PKG0" :use ()) + (setf (readtable-case *readtable*) :upcase) + (string= "abc" (write-to-string (intern "abc" "TEST-PKG0") + :escape nil :case :capitalize))) + +(let ((*readtable* (copy-readtable nil))) + (when (find-package "TEST-PKG0") (delete-package "TEST-PKG0")) + (make-package "TEST-PKG0" :use ()) + (setf (readtable-case *readtable*) :upcase) + (string= "abc" (write-to-string (intern "abc" "TEST-PKG0") + :escape nil :case :upcase))) + +(let ((*readtable* (copy-readtable nil))) + (when (find-package "TEST-PKG0") (delete-package "TEST-PKG0")) + (make-package "TEST-PKG0" :use ()) + (setf (readtable-case *readtable*) :upcase) + (string= "abc" (write-to-string (intern "abc" "TEST-PKG0") + :escape nil :case :downcase))) + + + +;; accessible symbol, *print-readably* t +(loop + named loop0 + with printed-name + with *readtable* = (copy-readtable nil) + for readtable-case in '(:upcase :downcase :preserve :invert) + do (loop + for *print-case* in '(:upcase :downcase :capitalize) + do (loop + for symbol in '(|ZEBRA| |Zebra| |zebra|) + do (setf (readtable-case *readtable*) readtable-case) + (setq printed-name (write-to-string symbol :readably t)) + unless (eq symbol (read-from-string printed-name)) + do (format t "~&Symbol = ~S~%Erroneous printed representation = ~S~%readtable-case = ~S~%*print-case* = ~S~%" + symbol printed-name readtable-case *print-case*) + (return-from loop0 nil))) + finally (return-from loop0 t)) + +;; keyword symbol, *print-readably* t +(loop + named loop0 + with printed-name + with *readtable* = (copy-readtable nil) + for readtable-case in '(:upcase :downcase :preserve :invert) + do (loop + for *print-case* in '(:upcase :downcase :capitalize) + do (loop + for symbol in '(:|ZEBRA| :|Zebra| :|zebra|) + do (setf (readtable-case *readtable*) readtable-case) + (setq printed-name (write-to-string symbol :readably t)) + unless (eq symbol (read-from-string printed-name)) + do (format t "~&Symbol = ~S~%Erroneous printed representation = ~S~%readtable-case = ~S~%*print-case* = ~S~%" + symbol printed-name readtable-case *print-case*) + (return-from loop0 nil))) + finally (return-from loop0 t)) + +;; non accessible symbol, *print-readably* t +(progn + (when (find-package "TEST-PKG0") (delete-package "TEST-PKG0")) + (make-package "TEST-PKG0" :use ()) + (loop + named loop0 + with printed-name + with *readtable* = (copy-readtable nil) + for readtable-case in '(:upcase :downcase :preserve :invert) + do (loop + for *print-case* in '(:upcase :downcase :capitalize) + do (loop + for symbol in (mapcar #'(lambda (name) (intern name "TEST-PKG0")) + '("ZEBRA" "Zebra" "zebra")) + do (setf (readtable-case *readtable*) readtable-case) + (setq printed-name (write-to-string symbol :readably t)) + unless (eq symbol (read-from-string printed-name)) + do (format t "~&Symbol = ~S~%Erroneous printed representation = ~S~%readtable-case = ~S~%*print-case* = ~S~%" + symbol printed-name readtable-case *print-case*) + (return-from loop0 nil))) + finally (return-from loop0 t))) + + +;; symbols having nongraphic characters in their name +(eq '| | (read-from-string (write-to-string '| | :readably t))) +(eq '| +| (read-from-string (write-to-string '| +| :readably t))) + +;; symbols having nonalphabetic characters in their name +(eq '| | (read-from-string (write-to-string '| | :readably t))) +(eq '|"| (read-from-string (write-to-string '|"| :readably t))) +(eq '|#| (read-from-string (write-to-string '|#| :readably t))) +(eq '|'| (read-from-string (write-to-string '|'| :readably t))) +(eq '|(| (read-from-string (write-to-string '|(| :readably t))) +(eq '|)| (read-from-string (write-to-string '|)| :readably t))) +(eq '|,| (read-from-string (write-to-string '|,| :readably t))) +(eq '|;| (read-from-string (write-to-string '|;| :readably t))) +(eq '|\\| (read-from-string (write-to-string '|\\| :readably t))) +(= 1 (length (symbol-name (read-from-string (write-to-string '|\\| + :readably t))))) +(eq '|`| (read-from-string (write-to-string '|`| :readably t))) +(eq '|\|| (read-from-string (write-to-string '|\|| :readably t))) +(= 1 (length (symbol-name (read-from-string (write-to-string '|\|| + :readably t))))) +(loop + for symbol in '(|-!-| |/*/| |$$$| |^^^^^^^^^^^^^|) + always (loop + with *readtable* = (copy-readtable nil) + for table-case in '(:upcase :downcase :preserve :invert) + do (setf (readtable-case *readtable*) table-case) + always (loop for *print-case in '(:upcase :downcase :capitalize) + always (string= (symbol-name symbol) + (write-to-string symbol :escape nil))))) + +;; uninterned symbols +(string= "ABC" + (symbol-name (read-from-string (write-to-string (make-symbol "ABC") + :readably t + :case :upcase)))) +(string= "ABC" + (symbol-name (read-from-string (write-to-string (make-symbol "ABC") + :readably t + :case :downcase)))) +(string= "ABC" + (symbol-name (read-from-string (write-to-string (make-symbol "ABC") + :readably t + :case :capitalize)))) +(string= "G01" (write-to-string (make-symbol "G01") :escape t :gensym nil)) +(string= "G01" (write-to-string (make-symbol "G01") :escape nil :gensym nil)) +(string= "#:G01" (write-to-string (make-symbol "G01") :escape t :gensym t)) +#-CLISP ;Bruno: CLISP prints symbols readably with vertical bars: "#:|G01|" +(string= "#:G01" + ;; Variable *PRINT-READABLY* + ;; http://www.lispworks.com/reference/HyperSpec/Body/v_pr_rda.htm + ;; If the value of some other printer control variable is such + ;; that these requirements would be violated, the value of that + ;; other variable is ignored. + ;; Specifically, if *print-readably* is true, printing proceeds + ;; as if *print-escape*, *print-array*, and *print-gensym* were + ;; also true, and as if *print-length*, *print-level*, and + ;; *print-lines* were false. + (write-to-string (make-symbol "G01") + :escape nil :gensym nil :readably t)) + + +;; "FACE" as a symbol when *read-base* is 16 +(let ((face (let ((*print-base* 16)) (write-to-string 'face :readably t))) + (*read-base* 16)) + ;; 22.1.3.3 Printing Symbols + ;; http://www.lispworks.com/reference/HyperSpec/Body/22_acc.htm + ;; When printing a symbol, the printer inserts enough single escape + ;; and/or multiple escape characters (backslashes and/or vertical-bars) + ;; so that if read were called with the same *readtable* and with + ;; *read-base* bound to the current output base, it would return the same + ;; symbol (if it is not apparently uninterned) or an uninterned symbol + ;; with the same print name (otherwise). + ;; For example, if the value of *print-base* were 16 when printing the + ;; symbol face, it would have to be printed as \FACE or \Face or |FACE|, + ;; because the token face would be read as a hexadecimal number (decimal + ;; value 64206) if the value of *read-base* were 16. + (eq 'face (read-from-string face))) + + +(eq '|01| (read-from-string (write-to-string '|01| :readably t))) +(eq '|1| (read-from-string (write-to-string '|1| :readably t))) +(eq '|0123456789| (read-from-string (write-to-string '|0123456789| + :readably t))) + +;; symbols in a package with a mixed case name, *print-readably* t +(progn + (when (find-package "Test-Pkg0") (delete-package "Test-Pkg0")) + (make-package "Test-Pkg0" :use ()) + (loop + named loop0 + with printed-name + with *readtable* = (copy-readtable nil) + for readtable-case in '(:upcase :downcase :preserve :invert) + do (loop + for *print-case* in '(:upcase :downcase :capitalize) + do (loop + for symbol in (mapcar #'(lambda (name) (intern name "Test-Pkg0")) + '("ZEBRA" "Zebra" "zebra")) + do (setf (readtable-case *readtable*) readtable-case) + (setq printed-name (write-to-string symbol :readably t)) + unless (eq symbol (read-from-string printed-name)) + do (format t "~&Symbol = ~S~%Erroneous printed representation = ~S~%readtable-case = ~S~%*print-case* = ~S~%" + symbol printed-name readtable-case *print-case*) + (return-from loop0 nil))) + finally (return-from loop0 t))) + +;; symbols in a package with weird chars in the name, *print-readably* t +(progn + (when (find-package "Test\|Pkg 0\;") (delete-package "Test\|Pkg 0\;")) + (make-package "Test\|Pkg 0\;" :use ()) + (loop + named loop0 + with *readtable* = (copy-readtable nil) + for readtable-case in '(:upcase :downcase :preserve :invert) + do (loop + for *print-case* in '(:upcase :downcase :capitalize) + do (loop + for symbol in (mapcar #'(lambda (name) (intern name "Test\|Pkg 0\;")) + '("ZEBRA" "Zebra" "zebra")) + do (setf (readtable-case *readtable*) readtable-case) + unless (eq symbol (read-from-string (write-to-string symbol + :readably t))) + do (format t "~&Symbol = ~S~%Erroneous printed representation = ~S~%readtable-case = ~S~%*print-case* = ~S~%" + symbol printed-name readtable-case *print-case*) + (return-from loop0 nil))) + finally (return-from loop0 t))) + + +;; weird symbols in a weird package, *print-readably* t +(progn + (when (find-package "Test\|Pkg 0\;") (delete-package "Test\|Pkg 0\;")) + (make-package "Test\|Pkg 0\;" :use ()) + (loop + named loop0 + with *readtable* = (copy-readtable nil) + for readtable-case in '(:upcase :downcase :preserve :invert) + do (loop + for *print-case* in '(:upcase :downcase :capitalize) + do (loop + for symbol in (mapcar #'(lambda (name) (intern name "Test\|Pkg 0\;")) + '("Z\\E\"BRA" "Z\;e\|bra" "z\:e bra")) + do (setf (readtable-case *readtable*) readtable-case) + unless (eq symbol (read-from-string (write-to-string symbol + :readably t))) + do (format t "~&Symbol = ~S~%Erroneous printed representation = ~S~%readtable-case = ~S~%*print-case* = ~S~%" + symbol printed-name readtable-case *print-case*) + (return-from loop0 nil))) + finally (return-from loop0 t))) + + + +;; bit-vector +(string= "#*0101" (write-to-string #*0101 :readably t :array t)) +(string= "#*01" (write-to-string #*01 :readably t :array t)) +(string= "#*0" (write-to-string #*0 :readably t :array t)) +(string= "#*1" (write-to-string #*1 :readably t :array t)) +(string= "#*" (write-to-string #* :readably t :array t)) +(string= "#*10101111000" (write-to-string #*10101111000 + :readably t :array t)) + +(string= "#*0101" (write-to-string #*0101 :readably t :array nil)) +(string= "#*01" (write-to-string #*01 :readably t :array nil)) +(string= "#*0" (write-to-string #*0 :readably t :array nil)) +(string= "#*1" (write-to-string #*1 :readably t :array nil)) +(string= "#*" (write-to-string #* :readably t :array nil)) +(string= "#*10101111000" (write-to-string #*10101111000 + :readably t :array nil)) + +(string= "#*0101" (write-to-string #*0101 :array t)) +(string= "#*01" (write-to-string #*01 :array t)) +(string= "#*0" (write-to-string #*0 :array t)) +(string= "#*1" (write-to-string #*1 :array t)) +(string= "#*" (write-to-string #* :array t)) +(string= "#*10101111000" (write-to-string #*10101111000 :array t)) + +(zerop (search "#<" (write-to-string #*0101 :array nil))) +(zerop (search "#<" (write-to-string #*01 :array nil))) +(zerop (search "#<" (write-to-string #*0 :array nil))) +(zerop (search "#<" (write-to-string #*1 :array nil))) +(zerop (search "#<" (write-to-string #* :array nil))) +(zerop (search "#<" (write-to-string #*10101111000 :array nil))) +(string= "#*01" + (write-to-string (make-array 10 + :element-type 'bit + :initial-contents '(0 1 0 1 0 1 0 1 0 1) + :fill-pointer 2) + :readably t :array t)) + + +;; list +(null (read-from-string (write-to-string '()))) +(string= (write-to-string '(1) :pretty nil) "(1)") +(string= (write-to-string '(1 2) :pretty nil) "(1 2)") +(string= (write-to-string '(1 2 3) :pretty nil) "(1 2 3)") +(string= (write-to-string '(1 2 3 4) :pretty nil) "(1 2 3 4)") +(string= (write-to-string '(1 . 2) :pretty nil) "(1 . 2)") +(string= (write-to-string '(1 2 . 3) :pretty nil) "(1 2 . 3)") +(string= (write-to-string '(1 2 3 . 4) :pretty nil) "(1 2 3 . 4)") +(let ((list (loop for i from 0 upto 100 collect i))) + (equal (read-from-string (write-to-string list)) list)) + +;; list *print-level* *print-length* +(string= (write-to-string '(1 (2 (3 (4 (5 (6)))))) :pretty nil :level 0) "#") +(string= (write-to-string '(1 (2 (3 (4 (5 (6)))))) :pretty nil :level 1) + "(1 #)") +(string= (write-to-string '(1 (2 (3 (4 (5 (6)))))) :pretty nil :level 2) + "(1 (2 #))") +(string= (write-to-string '(1 (2 (3 (4 (5 (6)))))) :pretty nil :level 3) + "(1 (2 (3 #)))") +(string= (write-to-string '(1 (2 (3 (4 (5 (6)))))) :pretty nil :level 4) + "(1 (2 (3 (4 #))))") +(string= (write-to-string '(1 (2 (3 (4 (5 (6)))))) :pretty nil :level 4) + "(1 (2 (3 (4 #))))") +(string= (write-to-string '(1 (2 (3 (4 (5 (6)))))) :pretty nil :level 5) + "(1 (2 (3 (4 (5 #)))))") +(string= (write-to-string '(1 (2 (3 (4 (5 (6)))))) :pretty nil :level 6) + "(1 (2 (3 (4 (5 (6))))))") +(string= (write-to-string '(1 (2 (3 (4 (5 (6)))))) :pretty nil :level 7) + "(1 (2 (3 (4 (5 (6))))))") +(string= (write-to-string '(1 (2 (3 (4 (5 (6)))))) :pretty nil :level 100) + "(1 (2 (3 (4 (5 (6))))))") + +(string= (write-to-string '(1 2 3 4 5 6) :pretty nil :length 0) "(...)") +(string= (write-to-string '(1 2 3 4 5 6) :pretty nil :length 1) "(1 ...)") +(string= (write-to-string '(1 2 3 4 5 6) :pretty nil :length 2) "(1 2 ...)") +(string= (write-to-string '(1 2 3 4 5 6) :pretty nil :length 3) "(1 2 3 ...)") +(string= (write-to-string '(1 2 3 4 5 6) :pretty nil :length 4) "(1 2 3 4 ...)") +(string= (write-to-string '(1 2 3 4 5 6) :pretty nil :length 5) + "(1 2 3 4 5 ...)") +(string= (write-to-string '(1 2 3 4 5 6) :pretty nil :length 6) + "(1 2 3 4 5 6)") +(string= (write-to-string '(1 2 3 4 5 6) :pretty nil :length 7) + "(1 2 3 4 5 6)") +(string= (write-to-string '(1 2 3 4 5 6) :pretty nil :length 100) + "(1 2 3 4 5 6)") + +(string= (write-to-string '(1 2 . 3) :pretty nil :length 0) "(...)") +(string= (write-to-string '(1 2 . 3) :pretty nil :length 1) "(1 ...)") +(string= (write-to-string '(1 2 . 3) :pretty nil :length 2) "(1 2 . 3)") +(string= (write-to-string '(1 2 . 3) :pretty nil :length 3) "(1 2 . 3)") + +(string= (write-to-string '(1 (2 (3 (4 (5 (6)))))) + :pretty nil :level 0 :length 0) + "#") +(string= (write-to-string '(1 (2 (3 (4 (5 (6)))))) + :pretty nil :level 1 :length 0) + "(...)") +(string= (write-to-string '(1 (2 (3 (4 (5 (6)))))) + :pretty nil :level 0 :length 1) + "#") +(string= (write-to-string '(1 (2 (3 (4 (5 (6)))))) + :pretty nil :level 1 :length 1) + "(1 ...)") +(string= (write-to-string '(1 (2 (3 (4 (5 (6)))))) + :pretty nil :level 2 :length 1) + "(1 ...)") +(string= (write-to-string '(1 (2 (3 (4 (5 (6)))))) + :pretty nil :level 2 :length 2) + "(1 (2 #))") + +(string= (write-to-string '((((1))) ((2)) (3) 4) + :pretty nil :level 0 :length 0) + "#") +(string= (write-to-string '((((1))) ((2)) (3) 4) + :pretty nil :level 1 :length 0) + "(...)") +(string= (write-to-string '((((1))) ((2)) (3) 4) + :pretty nil :level 1 :length 4) + "(# # # 4)") +(string= (write-to-string '((((1))) ((2)) (3) 4) + :pretty nil :level 2 :length 3) + "((#) (#) (3) ...)") +(string= (write-to-string '((((1))) ((2)) (3) 4) + :pretty nil :level 3 :length 3) + "(((#)) ((2)) (3) ...)") +(string= (write-to-string '((((1))) ((2)) (3) 4) + :pretty nil :level 4 :length 3) + "((((1))) ((2)) (3) ...)") +(string= (write-to-string '((((1))) ((2)) (3) 4) + :pretty nil :level 2 :length 4) + "((#) (#) (3) 4)") +(string= (write-to-string '((((1))) ((2)) (3) 4) + :pretty nil :level 4 :length 4) + "((((1))) ((2)) (3) 4)") + +(string= (write-to-string '((((1))) ((2)) (3) 4 (5) ((6)) (((7)))) + :pretty nil :level 3 :length 6) + "(((#)) ((2)) (3) 4 (5) ((6)) ...)") + +(string= (write-to-string '((((1 ((2)) (3)))) ((2 (3) 4 5 6)) (3 (4 (5 6)))) + :pretty nil :level 6 :length 3) + "((((1 ((2)) (3)))) ((2 (3) 4 ...)) (3 (4 (5 6))))") +(string= (write-to-string '((((1 ((2)) (3)))) ((2 (3) 4 5 6)) (3 (4 (5 6)))) + :pretty nil :level 2 :length 2) + "((#) (#) ...)") +(string= (write-to-string '((((1 ((2)) (3)))) ((2 (3) 4 5 6)) (3 (4 (5 6)))) + :pretty nil :level 3 :length 2) + "(((#)) ((2 # ...)) ...)") +(string= (write-to-string '(((1)) ((1) 2 ((3)) (((4)))) 3 (4)) + :pretty nil :level 2 :length 3) + "((#) (# 2 # ...) 3 ...)") + + + +;; vector +;; 22.1.3.7 Printing Other Vectors +;; http://www.lispworks.com/reference/HyperSpec/Body/22_acg.htm +;; If *print-array* is true and *print-readably* is false, any vector +;; other than a string or bit vector is printed using general-vector +;; syntax; this means that information about specialized vector +;; representations does not appear. The printed representation of a +;; zero-length vector is #(). The printed representation of a +;; non-zero-length vector begins with #(. Following that, the first +;; element of the vector is printed. If there are any other elements, +;; they are printed in turn, with each such additional element preceded +;; by a space if *print-pretty* is false, or whitespace[1] if +;; *print-pretty* is true. A right-parenthesis after the last element +;; terminates the printed representation of the vector. +(string= (write-to-string '#() :pretty nil :array t) "#()") +(string= (write-to-string '#(1) :pretty nil :array t) "#(1)") +(string= (write-to-string '#(1 2 3) :pretty nil :array t) "#(1 2 3)") +(string= (write-to-string (make-array 10 + :initial-contents '(0 1 2 3 4 5 6 7 8 9) + :fill-pointer 3) + :pretty nil :array t) + "#(0 1 2)") + +;; vector *print-level* *print-length* +(string= (write-to-string '#(1 (2 (3 (4 (5 (6)))))) + :pretty nil :array t :level 0) "#") +(string= (write-to-string '#(1 (2 (3 (4 (5 (6)))))) + :pretty nil :array t :level 1) + "#(1 #)") +(string= (write-to-string '#(1 (2 (3 (4 (5 (6)))))) + :pretty nil :array t :level 2) + "#(1 (2 #))") +(string= (write-to-string '#(1 (2 (3 (4 (5 (6)))))) + :pretty nil :array t :level 3) + "#(1 (2 (3 #)))") +(string= (write-to-string '#(1 (2 (3 (4 (5 (6)))))) + :pretty nil :array t :level 4) + "#(1 (2 (3 (4 #))))") +(string= (write-to-string '#(1 (2 (3 (4 (5 (6)))))) + :pretty nil :array t :level 4) + "#(1 (2 (3 (4 #))))") +(string= (write-to-string '#(1 (2 (3 (4 (5 (6)))))) + :pretty nil :array t :level 5) + "#(1 (2 (3 (4 (5 #)))))") +(string= (write-to-string '#(1 (2 (3 (4 (5 (6)))))) + :pretty nil :array t :level 6) + "#(1 (2 (3 (4 (5 (6))))))") +(string= (write-to-string '#(1 (2 (3 (4 (5 (6)))))) + :pretty nil :array t :level 7) + "#(1 (2 (3 (4 (5 (6))))))") +(string= (write-to-string '#(1 (2 (3 (4 (5 (6)))))) + :pretty nil :array t :level 100) + "#(1 (2 (3 (4 (5 (6))))))") + +(string= (write-to-string '#(1 2 3 4 5 6) :pretty nil :array t :length 0) + "#(...)") +(string= (write-to-string '#(1 2 3 4 5 6) :pretty nil :array t :length 1) + "#(1 ...)") +(string= (write-to-string '#(1 2 3 4 5 6) :pretty nil :array t :length 2) + "#(1 2 ...)") +(string= (write-to-string '#(1 2 3 4 5 6) :pretty nil :array t :length 3) + "#(1 2 3 ...)") +(string= (write-to-string '#(1 2 3 4 5 6) :pretty nil :array t :length 4) + "#(1 2 3 4 ...)") +(string= (write-to-string '#(1 2 3 4 5 6) :pretty nil :array t :length 5) + "#(1 2 3 4 5 ...)") +(string= (write-to-string '#(1 2 3 4 5 6) :pretty nil :array t :length 6) + "#(1 2 3 4 5 6)") +(string= (write-to-string '#(1 2 3 4 5 6) :pretty nil :array t :length 7) + "#(1 2 3 4 5 6)") +(string= (write-to-string '#(1 2 3 4 5 6) :pretty nil :array t :length 100) + "#(1 2 3 4 5 6)") + +(string= (write-to-string '#(1 #(2 #(3 #(4 #(5 #(6)))))) + :pretty nil :array t :level 0 :length 0) + "#") +(string= (write-to-string '#(1 #(2 #(3 #(4 #(5 #(6)))))) + :pretty nil :array t :level 1 :length 0) + "#(...)") +(string= (write-to-string '#(1 #(2 #(3 #(4 #(5 #(6)))))) + :pretty nil :array t :level 0 :length 1) + "#") +(string= (write-to-string '#(1 #(2 #(3 #(4 #(5 #(6)))))) + :pretty nil :array t :level 1 :length 1) + "#(1 ...)") +(string= (write-to-string '#(1 #(2 #(3 #(4 #(5 #(6)))))) + :pretty nil :array t :level 2 :length 1) + "#(1 ...)") +(string= (write-to-string '#(1 #(2 #(3 #(4 #(5 #(6)))))) + :pretty nil :array t :level 2 :length 2) + "#(1 #(2 #))") + +(string= (write-to-string '#(#(#(#(1))) #(#(2)) #(3) 4) + :pretty nil :array t :level 0 :length 0) + "#") +(string= (write-to-string '#(#(#(#(1))) #(#(2)) #(3) 4) + :pretty nil :array t :level 1 :length 0) + "#(...)") +(string= (write-to-string '#(#(#(#(1))) #(#(2)) #(3) 4) + :pretty nil :array t :level 1 :length 4) + "#(# # # 4)") +(string= (write-to-string '#(#(#(#(1))) #(#(2)) #(3) 4) + :pretty nil :array t :level 2 :length 3) + "#(#(#) #(#) #(3) ...)") +(string= (write-to-string '#(#(#(#(1))) #(#(2)) #(3) 4) + :pretty nil :array t :level 3 :length 3) + "#(#(#(#)) #(#(2)) #(3) ...)") +(string= (write-to-string '#(#(#(#(1))) #(#(2)) #(3) 4) + :pretty nil :array t :level 4 :length 3) + "#(#(#(#(1))) #(#(2)) #(3) ...)") +(string= (write-to-string '#(#(#(#(1))) #(#(2)) #(3) 4) + :pretty nil :array t :level 2 :length 4) + "#(#(#) #(#) #(3) 4)") +(string= (write-to-string '#(#(#(#(1))) #(#(2)) #(3) 4) + :pretty nil :array t :level 4 :length 4) + "#(#(#(#(1))) #(#(2)) #(3) 4)") + +(string= (write-to-string '#(#(#(#(1))) #(#(2)) #(3) 4 #(5) #(#(6)) #(#(#(7)))) + :pretty nil :array t :level 3 :length 6) + "#(#(#(#)) #(#(2)) #(3) 4 #(5) #(#(6)) ...)") + +(string= (write-to-string '#(#(#(#(1 #(#(2)) #(3)))) + #(#(2 #(3) 4 5 6)) + #(3 #(4 #(5 6)))) + :pretty nil :array t :level 6 :length 3) + "#(#(#(#(1 #(#(2)) #(3)))) #(#(2 #(3) 4 ...)) #(3 #(4 #(5 6))))") +(string= (write-to-string '#(#(#(#(1 #(#(2)) #(3)))) + #(#(2 #(3) 4 5 6)) + #(3 #(4 #(5 6)))) + :pretty nil :array t :level 2 :length 2) + "#(#(#) #(#) ...)") +(string= (write-to-string '#(#(#(#(1 #(#(2)) #(3)))) + #(#(2 #(3) 4 5 6)) + #(3 #(4 #(5 6)))) + :pretty nil :array t :level 3 :length 2) + "#(#(#(#)) #(#(2 # ...)) ...)") +(string= (write-to-string '#(#(#(1)) #(#(1) 2 #(#(3)) #(#(#(4)))) 3 #(4)) + :pretty nil :array t :level 2 :length 3) + "#(#(#) #(# 2 # ...) 3 ...)") + + +;; array +(string= (write-to-string '#0A1 :pretty nil :array t) "#0A1") +(string= (write-to-string '#1A() :pretty nil :array t) "#()") +(string= (write-to-string '#1A(1 2 3) :pretty nil :array t) "#(1 2 3)") +(string= (write-to-string '#2A((1 2 3) (4 5 6)) :pretty nil :array t) + "#2A((1 2 3) (4 5 6))") +(string= (write-to-string '#3A(((1 a) (2 b) (3 c)) + ((4 d) (5 e) (6 f))) :pretty nil :array t) + "#3A(((1 A) (2 B) (3 C)) ((4 D) (5 E) (6 F)))") +(string= (write-to-string (make-array (make-list 20 :initial-element 1) + :initial-element 0) + :pretty nil :array t) + "#20A((((((((((((((((((((0))))))))))))))))))))") + +;; array *print-level* *print-length* +;(string= (write-to-string '#0A10 :pretty nil :array t :level 0 :length 0) "#") +(string= (write-to-string '#0A10 :pretty nil :array t :level 1 :length 1) + "#0A10") +(string= (write-to-string '#2A((0) (1) (2) (3)) + :pretty nil :array t :level 1 :length 1) + "#2A(# ...)") +(string= (write-to-string '#2A((0) (1) (2) (3)) + :pretty nil :array t :level 2 :length 2) + "#2A((0) (1) ...)") +(string= (write-to-string '#2A((0) (1) (2) (3)) + :pretty nil :array t :level 2 :length 0) + "#2A(...)") +(string= (write-to-string '#3A(((0) (1) (2)) ((3) (4) (5))) + :pretty nil :array t :level 3 :length 2) + "#3A(((0) (1) ...) ((3) (4) ...))") +(string= (write-to-string (make-array (make-list 20 :initial-element 1) + :initial-element 0) + :pretty nil :array t :level 0 :length 100) + "#") +(string= (write-to-string (make-array (make-list 20 :initial-element 1) + :initial-element 0) + :pretty nil :array t :level 100 :length 0) + "#20A(...)") +(string= (write-to-string (make-array (make-list 20 :initial-element 1) + :initial-element 0) + :pretty nil :array t :level 10 :length 100) + "#20A((((((((((#))))))))))") +(string= (write-to-string '#2A((0 1 2) (3 4 5) (6 7 8) (9 10 11)) + :pretty nil :array t :level 2 :length 2) + "#2A((0 1 ...) (3 4 ...) ...)") +(string= (write-to-string '#2A((0 1 2) (3 4 5) (6 7 8) (9 10 11)) + :pretty nil :array t :level 1 :length 2) + "#2A(# # ...)") +(string= (write-to-string '#3A(((0) (1) (2)) ((3) (4) (5)) + ((6) (7) (8)) ((9) (10) (11))) + :pretty nil :array t :level 2 :length 3) + "#3A((# # #) (# # #) (# # #) ...)") +(string= (write-to-string '#3A(((0) (1) (2)) ((3) (4) (5)) + ((6) (7) (8)) ((9) (10) (11))) + :pretty nil :array t :level 3 :length 4) + "#3A(((0) (1) (2)) ((3) (4) (5)) ((6) (7) (8)) ((9) (10) (11)))") + + +;; *print-array* +(string= (write-to-string "abc" :array t :escape nil) "abc") +(string= (write-to-string "abc" :array nil :escape nil) "abc") +(= 2 (mismatch "#<" (write-to-string #() :array nil))) +(= 2 (mismatch "#<" (write-to-string #(1 2 3) :array nil))) +(= 2 (mismatch "#<" (write-to-string #*1010 :array nil))) +(= 2 (mismatch "#<" (write-to-string #2A((0 1 2) (3 4 5)) :array nil))) +(= 2 (mismatch "#<" (write-to-string #3A(((0 1) (2 3)) ((4 5) (6 7))) + :array nil))) +(= 2 (mismatch "#<" (write-to-string #4A((((0) (1)) ((2) (3))) + (((4) (5)) ((6) (7))) + (((8) (9)) ((10) (11))) + (((12) (13)) ((14) (15)))) + :array nil))) + + + +;; label +(let* ((list '#1=(#1# . #1#)) + (x (read-from-string (write-to-string list :circle t)))) + (and (eq x (car x)) + (eq x (cdr x)))) + +(let* ((list '#1=(a . #1#)) + (x (read-from-string (write-to-string list :circle t)))) + (and (eq (car x) 'a) + (eq x (cdr x)))) + +(let* ((list '(a . #1=(b c . #1#))) + (x (read-from-string (write-to-string list :circle t)))) + (and (eq (first x) 'a) + (eq (second x) 'b) + (eq (third x) 'c) + (eq (fourth x) 'b) + (eq (cdr x) (nthcdr 3 x)))) + +(let* ((list '(#1=#:G1041 #1#)) + (x (read-from-string (write-to-string list :circle t)))) + ;; 22.1.3.3.1 Package Prefixes for Symbols + ;; http://www.lispworks.com/reference/HyperSpec/Body/22_acca.htm + ;; Because the #: syntax does not intern the following symbol, it is + ;; necessary to use circular-list syntax if *print-circle* is true and + ;; the same uninterned symbol appears several times in an expression to + ;; be printed. For example, the result of + ;; + ;; (let ((x (make-symbol "FOO"))) (list x x)) + ;; + ;; would be printed as (#:foo #:foo) if *print-circle* were false, but as + ;; (#1=#:foo #1#) if *print-circle* were true. + (and (= 2 (length x)) + (symbolp (first x)) + (eq (first x) (second x)))) + +(let* ((list '#1=(a (b #2=(x y z) . #1#) . #2#)) + (x (read-from-string (write-to-string list :circle t)))) + (and (eq (first x) 'a) + (eq x (cddr (second x))) + (eq (second (second x)) (cddr x)))) + +(let* ((list '#1=#(#1# a)) + (x (read-from-string (write-to-string list :circle t)))) + (and (eq x (aref x 0)) + (eq 'a (aref x 1)))) + +(let* ((list '#1=#(a #1#)) + (x (read-from-string (write-to-string list :circle t)))) + (and (eq (aref x 0) 'a) + (eq x (aref x 1)))) + +(let* ((list '#(#1=#:G00 #1#)) + (x (read-from-string (write-to-string list :circle t)))) + (and (eq (aref x 0) (aref x 1)) + (string= (symbol-name (aref x 0)) "G00") + (null (symbol-package (aref x 0))))) + +(let* ((list '#(#(#1=#:G00) #2=#(#1# a) #(#2# #1#))) + (x (read-from-string (write-to-string list :circle t)))) + (and (= 3 (length x)) + (= 1 (length (aref x 0))) + (= 2 (length (aref x 1))) + (= 2 (length (aref x 2))) + (eq (aref (aref x 0) 0) (aref (aref x 1) 0)) + (eq 'a (aref (aref x 1) 1)) + (eq (aref (aref x 0) 0) (aref (aref x 2) 1)) + (eq (aref x 1) (aref (aref x 2) 0)))) + +(let* ((array '#1=#0A#1#) + (x (read-from-string (write-to-string array :array t :circle t)))) + (and (null (array-dimensions array)) + (eq x (aref x)))) +(let* ((array '#1=#2A((1 2 3) (4 5 #1#))) + (x (read-from-string (write-to-string array :array t :circle t)))) + (and (equal (array-dimensions array) '(2 3)) + (= 1 (aref x 0 0)) + (= 2 (aref x 0 1)) + (= 3 (aref x 0 2)) + (= 4 (aref x 1 0)) + (= 5 (aref x 1 1)) + (eq x (aref x 1 2)))) +(let* ((array #1=#3A(((1 a) (2 b) (3 #1#)) ((4 d) (5 e) (6 f)))) + (x (read-from-string (write-to-string array :array t :circle t)))) + (and (equal (array-dimensions array) '(2 3 2)) + (= 1 (aref x 0 0 0)) + (eq 'a (aref x 0 0 1)) + (= 2 (aref x 0 1 0)) + (eq 'b (aref x 0 1 1)) + (= 3 (aref x 0 2 0)) + (eq x (aref x 0 2 1)) + (= 4 (aref x 1 0 0)) + (eq 'd (aref x 1 0 1)) + (= 5 (aref x 1 1 0)) + (eq 'e (aref x 1 1 1)) + (= 6 (aref x 1 2 0)) + (eq 'f (aref x 1 2 1)))) + +(let* ((array #3A(((1 #1=#:G0) (#2=#:G1 b) (3 #1#)) ((4 d) (5 e) (#2# f)))) + (x (read-from-string (write-to-string array :array t :circle t)))) + (and (equal (array-dimensions array) '(2 3 2)) + (= 1 (aref x 0 0 0)) + (eq (aref x 0 0 1) (aref x 0 2 1)) + (null (symbol-package (aref x 0 0 1))) + (string= "G0" (symbol-name (aref x 0 0 1))) + (eq (aref x 0 1 0) (aref x 1 2 0)) + (null (symbol-package (aref x 0 1 0))) + (string= "G1" (symbol-name (aref x 0 1 0))) + (eq 'b (aref x 0 1 1)) + (= 3 (aref x 0 2 0)) + (= 4 (aref x 1 0 0)) + (eq 'd (aref x 1 0 1)) + (= 5 (aref x 1 1 0)) + (eq 'e (aref x 1 1 1)) + (eq 'f (aref x 1 2 1)))) + +(let* ((array #1=#3A(((#1# #2=#:G0) (#3=#:G1 #2#) (#3# #1#)) + ((#1# #2#) (#2# #3#) (#2# #1#)))) + (x (read-from-string (write-to-string array :array t :circle t)))) + (and (equal (array-dimensions array) '(2 3 2)) + (eq x (aref x 0 0 0)) + (null (symbol-package (aref x 0 0 1))) + (string= (symbol-name (aref x 0 0 1)) "G0") + (null (symbol-package (aref x 0 1 0))) + (string= (symbol-name (aref x 0 1 0)) "G1") + (eq (aref x 0 1 0) (aref x 0 2 0)) + (eq x (aref x 0 2 1)) + (eq x (aref x 1 0 0)) + (eq (aref x 1 0 1) (aref x 0 0 1)) + (eq (aref x 1 1 0) (aref x 0 0 1)) + (eq (aref x 1 1 1) (aref x 0 1 0)) + (eq (aref x 1 2 0) (aref x 0 0 1)) + (eq (aref x 1 2 1) x))) + +(let* ((array #4A((((0 #1=#:G00 2) (#1# 4 #2=#:G01)) + ((#3=#:G02 #2# 8) (9 #4=#:G03 #3#)) + ((#4# 12 #5=#:G04) (#6=#:G05 #6# #5#))))) + (x (read-from-string (write-to-string array :array t :circle t)))) + (and (equal (array-dimensions array) '(1 3 2 3)) + (= 0 (aref x 0 0 0 0)) + (null (symbol-package (aref x 0 0 0 1))) + (string= (symbol-name (aref x 0 0 0 1)) "G00") + (= 2 (aref x 0 0 0 2)) + + (eq (aref x 0 0 1 0) (aref x 0 0 0 1)) + (= 4 (aref x 0 0 1 1)) + (null (symbol-package (aref x 0 0 1 2))) + (string= (symbol-name (aref x 0 0 1 2)) "G01") + + (null (symbol-package (aref x 0 1 0 0))) + (string= (symbol-name (aref x 0 1 0 0)) "G02") + (eq (aref x 0 1 0 1) (aref x 0 0 1 2)) + (= 8 (aref x 0 1 0 2)) + + (= 9 (aref x 0 1 1 0)) + (null (symbol-package (aref x 0 1 1 1))) + (string= (symbol-name (aref x 0 1 1 1)) "G03") + (eq (aref x 0 1 1 2) (aref x 0 1 0 0)) + + (eq (aref x 0 2 0 0) (aref x 0 1 1 1)) + (= 12 (aref x 0 2 0 1)) + (null (symbol-package (aref x 0 2 0 2))) + (string= (symbol-name (aref x 0 2 0 2)) "G04") + + (null (symbol-package (aref x 0 2 1 0))) + (string= (symbol-name (aref x 0 2 1 0)) "G05") + (eq (aref x 0 2 1 1) (aref x 0 2 1 0)) + (eq (aref x 0 2 1 2) (aref x 0 2 0 2)))) + + +(let* ((sequence '#1=(#(0 #2=(#1#) #1# 3) #3=#2A((#1# #2#) (#3# 4)))) + (x (read-from-string (write-to-string sequence :array t :circle t)))) + (and (= 2 (length x)) + (= 4 (length (first x))) + (= 0 (aref (first x) 0)) + (eq x (first (aref (first x) 1))) + (eq x (aref (first x) 2)) + (= 3 (aref (first x) 3)) + (equal (array-dimensions (second x)) '(2 2)) + (eq x (aref (second x) 0 0)) + (eq (aref (second x) 0 1) (aref (first x) 1)) + (eq (aref (second x) 1 0) (second x)) + (= 4 (aref (second x) 1 1)))) + +(let* ((sequence '#1=#(#2=(0 1 . #3=(2)) #(#3# #2# #1#) #3A(((#1# #2# #3#))))) + (x (read-from-string (write-to-string sequence :array t :circle t)))) + (and (= 3 (length x)) + (= 3 (length (aref x 0))) + (= 0 (first (aref x 0))) + (= 1 (second (aref x 0))) + (= 2 (third (aref x 0))) + (= 3 (length (aref x 1))) + (eq (aref (aref x 1) 0) (cddr (aref x 0))) + (eq (aref (aref x 1) 1) (aref x 0)) + (eq (aref (aref x 1) 2) x) + (equal (array-dimensions (aref x 2)) '(1 1 3)) + (eq (aref (aref x 2) 0 0 0) x) + (eq (aref (aref x 2) 0 0 1) (aref x 0)) + (eq (aref (aref x 2) 0 0 2) (cddr (aref x 0))))) + +;; *print-level* *print-length* array, vector, list intermingled +(let* ((sequence '((1 2 3) #(4 5 6) #2A((7 8 9) (10 11 12))))) + (string= (write-to-string sequence + :pretty nil :array t :level 0 :length 10) + "#")) +(let* ((sequence '((1 2 3) #(4 5 6) #2A((7 8 9) (10 11 12))))) + (string= (write-to-string sequence + :pretty nil :array t :level 1 :length 10) + "(# # #)")) +(let* ((sequence '((1 2 3) #(4 5 6) #2A((7 8 9) (10 11 12))))) + (string= (write-to-string sequence + :pretty nil :array t :level 2 :length 10) + "((1 2 3) #(4 5 6) #2A(# #))")) +(let* ((sequence '((1 2 3) #(4 5 6) #2A((7 8 9) (10 11 12))))) + (string= (write-to-string sequence + :pretty nil :array t :level 3 :length 10) + "((1 2 3) #(4 5 6) #2A((7 8 9) (10 11 12)))")) +(let* ((sequence '((1 2 3) #(4 5 6) #2A((7 8 9) (10 11 12))))) + (string= (write-to-string sequence + :pretty nil :array t :level 3 :length 1) + "((1 ...) ...)")) +(let* ((sequence '((1 2 3) #(4 5 6) #2A((7 8 9) (10 11 12))))) + (string= (write-to-string sequence + :pretty nil :array t :level 3 :length 2) + "((1 2 ...) #(4 5 ...) ...)")) +(let* ((sequence '((1 2 3) #(4 5 6) #2A((7 8 9) (10 11 12))))) + (string= (write-to-string sequence + :pretty nil :array t :level 3 :length 3) + "((1 2 3) #(4 5 6) #2A((7 8 9) (10 11 12)))")) +(let* ((sequence '((1 2 3) #(4 5 6) #2A((7 8 9 10) (11 12 13 14))))) + (string= (write-to-string sequence + :pretty nil :array t :level 3 :length 3) + "((1 2 3) #(4 5 6) #2A((7 8 9 ...) (11 12 13 ...)))")) + +(let* ((sequence '#((1 2 3) #(4 5 6) #2A((7 8 9) (10 11 12))))) + (string= (write-to-string sequence + :pretty nil :array t :level 0 :length 10) + "#")) +(let* ((sequence '#((1 2 3) #(4 5 6) #2A((7 8 9) (10 11 12))))) + (string= (write-to-string sequence + :pretty nil :array t :level 1 :length 10) + "#(# # #)")) +(let* ((sequence '#((1 2 3) #(4 5 6) #2A((7 8 9) (10 11 12))))) + (string= (write-to-string sequence + :pretty nil :array t :level 2 :length 10) + "#((1 2 3) #(4 5 6) #2A(# #))")) +(let* ((sequence '#((1 2 3) #(4 5 6) #2A((7 8 9) (10 11 12))))) + (string= (write-to-string sequence + :pretty nil :array t :level 3 :length 10) + "#((1 2 3) #(4 5 6) #2A((7 8 9) (10 11 12)))")) +(let* ((sequence '#((1 2 3) #(4 5 6) #2A((7 8 9) (10 11 12))))) + (string= (write-to-string sequence + :pretty nil :array t :level 3 :length 1) + "#((1 ...) ...)")) +(let* ((sequence '#((1 2 3) #(4 5 6) #2A((7 8 9) (10 11 12))))) + (string= (write-to-string sequence + :pretty nil :array t :level 3 :length 2) + "#((1 2 ...) #(4 5 ...) ...)")) +(let* ((sequence '#((1 2 3) #(4 5 6) #2A((7 8 9) (10 11 12))))) + (string= (write-to-string sequence + :pretty nil :array t :level 3 :length 3) + "#((1 2 3) #(4 5 6) #2A((7 8 9) (10 11 12)))")) +(let* ((sequence '#((1 2 3) #(4 5 6) #2A((7 8 9 10) (11 12 13 14))))) + (string= (write-to-string sequence + :pretty nil :array t :level 3 :length 3) + "#((1 2 3) #(4 5 6) #2A((7 8 9 ...) (11 12 13 ...)))")) + +(let* ((array '#2A(((10) #(100)) ((0 1 2) #2A((3) (4) (5) (6) (7)))))) + (string= (write-to-string array + :pretty nil :array t :level 0 :length 0) + "#")) +(let* ((array '#2A(((10) #(100)) ((0 1 2) #2A((3) (4) (5) (6) (7)))))) + (string= (write-to-string array + :pretty nil :array t :level 1 :length 0) + "#2A(...)")) +(let* ((array '#2A(((10) #(100)) ((0 1 2) #2A((3) (4) (5) (6) (7)))))) + (string= (write-to-string array + :pretty nil :array t :level 1 :length 1) + "#2A(# ...)")) +(let* ((array '#2A(((10) #(100)) ((0 1 2) #2A((3) (4) (5) (6) (7)))))) + (string= (write-to-string array + :pretty nil :array t :level 2 :length 1) + "#2A((# ...) ...)")) +(let* ((array '#2A(((10) #(100)) ((0 1 2) #2A((3) (4) (5) (6) (7)))))) + (string= (write-to-string array + :pretty nil :array t :level 2 :length 2) + "#2A((# #) (# #))")) +(let* ((array '#2A(((10) #(100)) ((0 1 2) #2A((3) (4) (5) (6) (7)))))) + (string= (write-to-string array + :pretty nil :array t :level 3 :length 1) + "#2A(((10) ...) ...)")) +(let* ((array '#2A(((10) #(100)) ((0 1 2) #2A((3) (4) (5) (6) (7)))))) + (string= (write-to-string array + :pretty nil :array t :level 3 :length 2) + "#2A(((10) #(100)) ((0 1 ...) #2A(# # ...)))")) +(let* ((array '#2A(((10) #(100)) ((0 1 2) #2A((3) (4) (5) (6) (7)))))) + (string= (write-to-string array + :pretty nil :array t :level 4 :length 2) + "#2A(((10) #(100)) ((0 1 ...) #2A((3) (4) ...)))")) +(let* ((array '#2A(((10) #(100)) ((0 1 2) #2A((3) (4) (5) (6) (7)))))) + (string= (write-to-string array + :pretty nil :array t :level 4 :length 3) + "#2A(((10) #(100)) ((0 1 2) #2A((3) (4) (5) ...)))")) +(let* ((array '#2A(((10) #(100)) ((0 1 2) #2A((3) (4) (5) (6) (7)))))) + (string= (write-to-string array + :pretty nil :array t :level 4 :length 5) + "#2A(((10) #(100)) ((0 1 2) #2A((3) (4) (5) (6) (7))))")) +(let* ((array '#2A(((10) #((100))) + ((0 (1) ((2))) #2A((3) ((4)) (((5))) ((6)) (7)))))) + (string= (write-to-string array + :pretty nil :array t :level 3 :length 5) + "#2A(((10) #(#)) ((0 # #) #2A(# # # # #)))")) +(let* ((array '#2A(((10) #((100))) + ((0 (1) ((2))) #2A((3) ((4)) (((5))) ((6)) (7)))))) + (string= (write-to-string array + :pretty nil :array t :level 4 :length 5) + "#2A(((10) #((100))) ((0 (1) (#)) #2A((3) (#) (#) (#) (7))))")) +(let* ((array '#2A(((10) #((100))) + ((0 (1) ((2))) #2A((3) ((4)) (((5))) ((6)) (7)))))) + (string= + (write-to-string array :pretty nil :array t :level 5 :length 5) + "#2A(((10) #((100))) ((0 (1) ((2))) #2A((3) ((4)) ((#)) ((6)) (7))))")) +(let* ((array '#2A(((10) #((100))) + ((0 (1) ((2))) #2A((3) ((4)) (((5))) ((6)) (7)))))) + (string= + (write-to-string array :pretty nil :array t :level 6 :length 4) + "#2A(((10) #((100))) ((0 (1) ((2))) #2A((3) ((4)) (((5))) ((6)) ...)))")) + + +;; (string= (write-to-string '#1=(0 #1#) :pretty nil :length 1 :circle t) +;; "(0 ...)") ;; or "#1=(0 ...)" + +;; *print-readably*, *print-level*, and *print-length +(equal (read-from-string + (write-to-string '(0 1 2) :pretty nil :readably t :level 0 :length 0)) + '(0 1 2)) +(equalp (read-from-string + (write-to-string #(0 1 2) :pretty nil :readably t :level 0 :length 0)) + #(0 1 2)) +(equalp (read-from-string + (write-to-string #2A((0) (1) (2)) + :pretty nil :readably t :level 0 :length 0)) + #2A((0) (1) (2))) + + +;; *print-level* *print-length* +;; Variable *PRINT-LEVEL*, *PRINT-LENGTH* +;; http://www.lispworks.com/reference/HyperSpec/Body/v_pr_lev.htm +;; *print-level* and *print-length* affect the printing of an any object +;; printed with a list-like syntax. They do not affect the printing of +;; symbols, strings, and bit vectors. +(string= "LENGTH" (write-to-string 'LENGTH :escape nil :level 0)) +(string= "LENGTH" (write-to-string 'LENGTH :escape nil :length 2)) +(string= "LENGTH" (write-to-string 'LENGTH :escape nil :level 0 :length 0)) +(string= "abcdefg" (write-to-string "abcdefg" :escape nil :level 0)) +(string= "abcdefg" (write-to-string "abcdefg" :escape nil :length 2)) +(string= "abcdefg" (write-to-string "abcdefg" :escape nil :level 0 :length 0)) +(string= "#*0101" (write-to-string #*0101 :array t :level 0)) +(string= "#*0101" (write-to-string #*0101 :array t :length 2)) +(string= "#*0101" (write-to-string #*0101 :array t :level 0 :length 0)) diff --git a/Sacla/tests/must-printer.patch b/Sacla/tests/must-printer.patch new file mode 100644 index 0000000..0f3b883 --- /dev/null +++ b/Sacla/tests/must-printer.patch @@ -0,0 +1,13 @@ +*** sacla/lisp/test/must-printer.lisp 2004-08-03 08:34:55.000000000 +0200 +--- CLISP/clisp-20040712/sacla-tests/must-printer.lisp 2004-08-07 02:40:21.000000000 +0200 +*************** +*** 774,779 **** +--- 774,780 ---- + (string= "G01" (write-to-string (make-symbol "G01") :escape t :gensym nil)) + (string= "G01" (write-to-string (make-symbol "G01") :escape nil :gensym nil)) + (string= "#:G01" (write-to-string (make-symbol "G01") :escape t :gensym t)) ++ #-CLISP ; CLISP prints symbols readably with vertical bars: "#:|G01|" + (string= "#:G01" + ;; Variable *PRINT-READABLY* + ;; http://www.lispworks.com/reference/HyperSpec/Body/v_pr_rda.htm + diff --git a/Sacla/tests/must-reader.lisp b/Sacla/tests/must-reader.lisp new file mode 100644 index 0000000..d491390 --- /dev/null +++ b/Sacla/tests/must-reader.lisp @@ -0,0 +1,3052 @@ +;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp> +;; ALL RIGHTS RESERVED. +;; +;; $Id: must-reader.lisp,v 1.11 2004/08/09 02:49:54 yuji Exp $ +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; * Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; * Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + +(symbolp (read-from-string"|ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789!$\"'(),_-./:;?+<=>#%&*@[\\]{\|}`^~|")) +(eq (read-from-string "this") 'this) +(eq (read-from-string "cl:car") 'cl:car) +(eq (read-from-string ":ok") :ok) +(eq (read-from-string "ok#") 'ok\#) +(eq (read-from-string "x#x") 'x\#x) +(eq (read-from-string "abc(x y z)") 'abc) +(multiple-value-bind (obj pos) (read-from-string "abc(x y z)") + (and (eq obj 'abc) + (equal (read-from-string "abc(x y z)" t nil :start pos) '(x y z)))) +(eq (read-from-string "abc") (read-from-string "ABC")) +(eq (read-from-string "abc") (read-from-string "|ABC|")) +(eq (read-from-string "abc") (read-from-string "a|B|c")) +(not (eq (read-from-string "abc") (read-from-string "|abc|"))) +(eq (read-from-string "abc") (read-from-string "\\A\\B\\C")) +(eq (read-from-string "abc") (read-from-string "a\\Bc")) +(eq (read-from-string "abc") (read-from-string "\\ABC")) +(not (eq (read-from-string "abc") (read-from-string "\\abc"))) + +(= 1 (eval (read-from-string "(length '(this-that))"))) +(= 3 (eval (read-from-string "(length '(this - that))"))) +(= 2 (eval (read-from-string "(length '(a + b))"))) +(= 34 (eval (read-from-string "(+ 34)"))) +(= 7 (eval (read-from-string "(+ 3 4)"))) + + +(eq :key (let ((*package* (find-package "KEYWORD"))) (read-from-string "key"))) +(progn + (when (find-package 'test-foo) (delete-package 'test-foo)) + (let ((*package* (make-package 'test-foo :use nil))) + (and (not (find-symbol "BAR")) + (eq (read-from-string "bar") (find-symbol "BAR"))))) + + + + +(= (read-from-string "1.0") 1.0) +(= (read-from-string "2/3") 2/3) +(zerop (read-from-string "0")) +(zerop (read-from-string "0.0")) +(zerop (read-from-string "0/3")) + +(null (read-from-string "()")) +(equal (read-from-string "(a)") '(a)) +(equal (read-from-string "(a b)") '(a b)) +(equal (read-from-string "(a b c)") '(a b c)) +(equal (read-from-string "(a b c d)") '(a b c d)) +(equal (read-from-string "(a b c d e)") '(a b c d e)) +(equal (read-from-string "(a b c d e f)") '(a b c d e f)) +(equal (read-from-string "(a b c d e f g)") '(a b c d e f g)) +(equal (read-from-string "(a b c d e f g h)") '(a b c d e f g h)) +(handler-case (read-from-string ".") + (reader-error () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)) +(handler-case (read-from-string "...") + (reader-error () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)) + +(let ((*read-base* 8)) (= (read-from-string "0") 0)) +(let ((*read-base* 8)) (= (read-from-string "1") 1)) +(let ((*read-base* 8)) (= (read-from-string "2") 2)) +(let ((*read-base* 8)) (= (read-from-string "3") 3)) +(let ((*read-base* 8)) (= (read-from-string "4") 4)) +(let ((*read-base* 8)) (= (read-from-string "5") 5)) +(let ((*read-base* 8)) (= (read-from-string "6") 6)) +(let ((*read-base* 8)) (= (read-from-string "7") 7)) +(let ((*read-base* 8)) (= (read-from-string "8.") 8)) +(let ((*read-base* 8)) (= (read-from-string "10") 8)) +(let ((*read-base* 8)) (= (read-from-string "11") 9)) +(let ((*read-base* 8)) (= (read-from-string "12") 10)) +(let ((*read-base* 8)) (= (read-from-string "13") 11)) +(let ((*read-base* 8)) (= (read-from-string "14") 12)) +(let ((*read-base* 8)) (= (read-from-string "15") 13)) +(let ((*read-base* 8)) (= (read-from-string "16") 14)) +(let ((*read-base* 8)) (= (read-from-string "17") 15)) +(let ((*read-base* 8)) (= (read-from-string "20") 16)) +(let ((*read-base* 8)) (= (read-from-string "21") 17)) + +(let ((*read-base* 16)) (= (read-from-string "0") 0)) +(let ((*read-base* 16)) (= (read-from-string "1") 1)) +(let ((*read-base* 16)) (= (read-from-string "2") 2)) +(let ((*read-base* 16)) (= (read-from-string "3") 3)) +(let ((*read-base* 16)) (= (read-from-string "4") 4)) +(let ((*read-base* 16)) (= (read-from-string "5") 5)) +(let ((*read-base* 16)) (= (read-from-string "6") 6)) +(let ((*read-base* 16)) (= (read-from-string "7") 7)) +(let ((*read-base* 16)) (= (read-from-string "8") 8)) +(let ((*read-base* 16)) (= (read-from-string "9") 9)) +(let ((*read-base* 16)) (= (read-from-string "A") 10)) +(let ((*read-base* 16)) (= (read-from-string "a") 10)) +(let ((*read-base* 16)) (= (read-from-string "B") 11)) +(let ((*read-base* 16)) (= (read-from-string "b") 11)) +(let ((*read-base* 16)) (= (read-from-string "C") 12)) +(let ((*read-base* 16)) (= (read-from-string "c") 12)) +(let ((*read-base* 16)) (= (read-from-string "D") 13)) +(let ((*read-base* 16)) (= (read-from-string "d") 13)) +(let ((*read-base* 16)) (= (read-from-string "E") 14)) +(let ((*read-base* 16)) (= (read-from-string "e") 14)) +(let ((*read-base* 16)) (= (read-from-string "F") 15)) +(let ((*read-base* 16)) (= (read-from-string "f") 15)) +(let ((*read-base* 16)) (= (read-from-string "10") 16)) +(let ((*read-base* 16)) (= (read-from-string "11") 17)) +(let ((*read-base* 16)) (= (read-from-string "12") 18)) +(let ((*read-base* 16)) (= (read-from-string "13") 19)) +(let ((*read-base* 16)) (= (read-from-string "14") 20)) +(let ((*read-base* 16)) (= (read-from-string "15") 21)) +(let ((*read-base* 16)) (= (read-from-string "16") 22)) +(let ((*read-base* 16)) (= (read-from-string "17") 23)) +(let ((*read-base* 16)) (= (read-from-string "18") 24)) +(let ((*read-base* 16)) (= (read-from-string "19") 25)) +(let ((*read-base* 16)) (= (read-from-string "1A") 26)) +(let ((*read-base* 16)) (= (read-from-string "1a") 26)) +(let ((*read-base* 16)) (= (read-from-string "1B") 27)) +(let ((*read-base* 16)) (= (read-from-string "1b") 27)) +(let ((*read-base* 16)) (= (read-from-string "1C") 28)) +(let ((*read-base* 16)) (= (read-from-string "1c") 28)) +(let ((*read-base* 16)) (= (read-from-string "1D") 29)) +(let ((*read-base* 16)) (= (read-from-string "1d") 29)) +(let ((*read-base* 16)) (= (read-from-string "1E") 30)) +(let ((*read-base* 16)) (= (read-from-string "1e") 30)) +(let ((*read-base* 16)) (= (read-from-string "1F") 31)) +(let ((*read-base* 16)) (= (read-from-string "1f") 31)) +(let ((*read-base* 16)) (= (read-from-string "20") 32)) + + +(= (read-from-string "0") 0) +(= (read-from-string "+0") 0) +(= (read-from-string "-0") 0) +(integerp (read-from-string "0")) +(integerp (read-from-string "+0")) +(integerp (read-from-string "-0")) +(= (read-from-string "1") 1) +(= (read-from-string "+1") 1) +(= (read-from-string "-1") -1) +(integerp (read-from-string "1")) +(integerp (read-from-string "+1")) +(integerp (read-from-string "-1")) +(= (read-from-string "12") 12) +(= (read-from-string "+12") 12) +(= (read-from-string "-12") -12) +(integerp (read-from-string "12")) +(integerp (read-from-string "+12")) +(integerp (read-from-string "-12")) +(= (read-from-string "123") 123) +(= (read-from-string "+123") 123) +(= (read-from-string "-123") -123) +(integerp (read-from-string "123")) +(integerp (read-from-string "+123")) +(integerp (read-from-string "-123")) +(= (read-from-string "1234") 1234) +(= (read-from-string "+1234") 1234) +(= (read-from-string "-1234") -1234) +(integerp (read-from-string "1234")) +(integerp (read-from-string "+1234")) +(integerp (read-from-string "-1234")) +(= (read-from-string "12345") 12345) +(= (read-from-string "+12345") 12345) +(= (read-from-string "-12345") -12345) +(integerp (read-from-string "12345")) +(integerp (read-from-string "+12345")) +(integerp (read-from-string "-12345")) +(integerp (read-from-string "48148148031244413808971345")) +(integerp (read-from-string "+48148148031244413808971345")) +(integerp (read-from-string "-48148148031244413808971345")) + +(= (read-from-string "0.") 0) +(= (read-from-string "+0.") 0) +(= (read-from-string "-0.") 0) +(integerp (read-from-string "0.")) +(integerp (read-from-string "+0.")) +(integerp (read-from-string "-0.")) +(= (read-from-string "1.") 1) +(= (read-from-string "+1.") 1) +(= (read-from-string "-1.") -1) +(integerp (read-from-string "1.")) +(integerp (read-from-string "+1.")) +(integerp (read-from-string "-1.")) +(= (read-from-string "12.") 12) +(= (read-from-string "+12.") 12) +(= (read-from-string "-12.") -12) +(integerp (read-from-string "12.")) +(integerp (read-from-string "+12.")) +(integerp (read-from-string "-12.")) +(= (read-from-string "123.") 123) +(= (read-from-string "+123.") 123) +(= (read-from-string "-123.") -123) +(integerp (read-from-string "123.")) +(integerp (read-from-string "+123.")) +(integerp (read-from-string "-123.")) +(= (read-from-string "1234.") 1234) +(= (read-from-string "+1234.") 1234) +(= (read-from-string "-1234.") -1234) +(integerp (read-from-string "1234.")) +(integerp (read-from-string "+1234.")) +(integerp (read-from-string "-1234.")) +(= (read-from-string "12345.") 12345) +(= (read-from-string "+12345.") 12345) +(= (read-from-string "-12345.") -12345) +(integerp (read-from-string "12345.")) +(integerp (read-from-string "+12345.")) +(integerp (read-from-string "-12345.")) +(integerp (read-from-string "48148148031244413808971345.")) +(integerp (read-from-string "+48148148031244413808971345.")) +(integerp (read-from-string "-48148148031244413808971345.")) + +(zerop (let ((*read-base* 2)) (read-from-string "0"))) +(zerop (let ((*read-base* 2)) (read-from-string "+0"))) +(zerop (let ((*read-base* 2)) (read-from-string "-0"))) +(= 1 (let ((*read-base* 2)) (read-from-string "1"))) +(= 1 (let ((*read-base* 2)) (read-from-string "+1"))) +(= -1 (let ((*read-base* 2)) (read-from-string "-1"))) +(= 2 (let ((*read-base* 2)) (read-from-string "10"))) +(= 2 (let ((*read-base* 2)) (read-from-string "+10"))) +(= -2 (let ((*read-base* 2)) (read-from-string "-10"))) +(= 3 (let ((*read-base* 2)) (read-from-string "11"))) +(= 3 (let ((*read-base* 2)) (read-from-string "+11"))) +(= -3 (let ((*read-base* 2)) (read-from-string "-11"))) +(= -11 (let ((*read-base* 2)) (read-from-string "-11."))) +(integerp (let ((*read-base* 2)) (read-from-string "-11."))) +(= 21 (let ((*read-base* 2)) (read-from-string "10101"))) +(= 21 (let ((*read-base* 2)) (read-from-string "+10101"))) +(= -21 (let ((*read-base* 2)) (read-from-string "-10101"))) +(= -1.0101 (let ((*read-base* 2)) (read-from-string "-1.0101"))) +(= 1.0101 (let ((*read-base* 2)) (read-from-string "1.0101"))) +(= 123 (let ((*read-base* 2)) (read-from-string "123."))) + +(zerop (let ((*read-base* 3)) (read-from-string "0"))) +(zerop (let ((*read-base* 3)) (read-from-string "+0"))) +(zerop (let ((*read-base* 3)) (read-from-string "-0"))) +(= 1 (let ((*read-base* 3)) (read-from-string "1"))) +(= 1 (let ((*read-base* 3)) (read-from-string "+1"))) +(= -1 (let ((*read-base* 3)) (read-from-string "-1"))) +(= 2 (let ((*read-base* 3)) (read-from-string "2"))) +(= 2 (let ((*read-base* 3)) (read-from-string "+2"))) +(= -2 (let ((*read-base* 3)) (read-from-string "-2"))) +(= 3 (let ((*read-base* 3)) (read-from-string "10"))) +(= 3 (let ((*read-base* 3)) (read-from-string "+10"))) +(= -3 (let ((*read-base* 3)) (read-from-string "-10"))) +(= 4 (let ((*read-base* 3)) (read-from-string "11"))) +(= 4 (let ((*read-base* 3)) (read-from-string "+11"))) +(= -4 (let ((*read-base* 3)) (read-from-string "-11"))) +(= 5 (let ((*read-base* 3)) (read-from-string "12"))) +(= 5 (let ((*read-base* 3)) (read-from-string "+12"))) +(= -5 (let ((*read-base* 3)) (read-from-string "-12"))) +(= 6 (let ((*read-base* 3)) (read-from-string "20"))) +(= 6 (let ((*read-base* 3)) (read-from-string "+20"))) +(= -6 (let ((*read-base* 3)) (read-from-string "-20"))) +(= 7 (let ((*read-base* 3)) (read-from-string "21"))) +(= 7 (let ((*read-base* 3)) (read-from-string "+21"))) +(= -7 (let ((*read-base* 3)) (read-from-string "-21"))) +(= 8 (let ((*read-base* 3)) (read-from-string "22"))) +(= 8 (let ((*read-base* 3)) (read-from-string "+22"))) +(= -8 (let ((*read-base* 3)) (read-from-string "-22"))) + +(= 391514 (let ((*read-base* 3)) (read-from-string "201220001112"))) +(= 391514 (let ((*read-base* 3)) (read-from-string "+201220001112"))) +(= -391514 (let ((*read-base* 3)) (read-from-string "-201220001112"))) + +(zerop (let ((*read-base* 8)) (read-from-string "0"))) +(zerop (let ((*read-base* 8)) (read-from-string "+0"))) +(zerop (let ((*read-base* 8)) (read-from-string "-0"))) +(= 1 (let ((*read-base* 8)) (read-from-string "1"))) +(= 1 (let ((*read-base* 8)) (read-from-string "+1"))) +(= -1 (let ((*read-base* 8)) (read-from-string "-1"))) +(= 7 (let ((*read-base* 8)) (read-from-string "7"))) +(= 7 (let ((*read-base* 8)) (read-from-string "+7"))) +(= -7 (let ((*read-base* 8)) (read-from-string "-7"))) + + +(zerop (let ((*read-base* 16)) (read-from-string "0"))) +(zerop (let ((*read-base* 16)) (read-from-string "+0"))) +(zerop (let ((*read-base* 16)) (read-from-string "-0"))) +(= 1 (let ((*read-base* 16)) (read-from-string "1"))) +(= 1 (let ((*read-base* 16)) (read-from-string "+1"))) +(= -1 (let ((*read-base* 16)) (read-from-string "-1"))) +(= 9 (let ((*read-base* 16)) (read-from-string "9"))) +(= 9 (let ((*read-base* 16)) (read-from-string "+9"))) +(= -9 (let ((*read-base* 16)) (read-from-string "-9"))) +(= 15 (let ((*read-base* 16)) (read-from-string "F"))) +(= -15 (let ((*read-base* 16)) (read-from-string "-F"))) +(= 15 (let ((*read-base* 16)) (read-from-string "F"))) +(= 15 (let ((*read-base* 16)) (read-from-string "f"))) +(= -15 (let ((*read-base* 16)) (read-from-string "-f"))) +(= 15 (let ((*read-base* 16)) (read-from-string "f"))) +(= 31 (let ((*read-base* 16)) (read-from-string "1F"))) +(= 31 (let ((*read-base* 16)) (read-from-string "+1F"))) +(= -31 (let ((*read-base* 16)) (read-from-string "-1F"))) +(= #x3F (let ((*read-base* 16)) (read-from-string "3F"))) +(= #x3F (let ((*read-base* 16)) (read-from-string "+3F"))) +(= #x-3F (let ((*read-base* 16)) (read-from-string "-3F"))) +(= 9 (let ((*read-base* 16)) (read-from-string "9."))) +(integerp (let ((*read-base* 16)) (read-from-string "9."))) +(= 10 (let ((*read-base* 16)) (read-from-string "10."))) +(integerp (let ((*read-base* 16)) (read-from-string "10."))) + +(equal (let (stack) + (dotimes (i 6 stack) + (let ((*read-base* (+ 10. i))) + (let ((object (read-from-string "(\\DAD DAD |BEE| BEE 123. 123)"))) + (push (list *read-base* object) stack))))) + '((15 (DAD 3088 BEE 2699 123 258)) + (14 (DAD 2701 BEE BEE 123 227)) + (13 (DAD DAD BEE BEE 123 198)) + (12 (DAD DAD BEE BEE 123 171)) + (11 (DAD DAD BEE BEE 123 146)) + (10 (DAD DAD BEE BEE 123 123)))) + +(loop for i from 2 upto 32 + always (zerop (let ((*read-base* i)) (read-from-string "0")))) +(loop for i from 2 upto 32 + always (zerop (let ((*read-base* i)) (read-from-string "+0")))) +(loop for i from 2 upto 32 + always (zerop (let ((*read-base* i)) (read-from-string "-0")))) +(loop for i from 2 upto 32 + always (= 1 (let ((*read-base* i)) (read-from-string "1")))) +(loop for i from 2 upto 32 + always (= 1 (let ((*read-base* i)) (read-from-string "+1")))) +(loop for i from 2 upto 32 + always (= -1 (let ((*read-base* i)) (read-from-string "-1")))) +(loop for i from 2 upto 32 + for n = (let ((*read-base* i)) (read-from-string "10.")) + always (and (integerp n) (= 10 n))) +(loop for i from 2 upto 32 + for n = (let ((*read-base* i)) (read-from-string "+10.")) + always (and (integerp n) (= 10 n))) +(loop for i from 2 upto 32 + for n = (let ((*read-base* i)) (read-from-string "-10.")) + always (and (integerp n) (= -10 n))) +(loop for i from 2 upto 32 + for n = (let ((*read-base* i)) (read-from-string "1.1")) + always (= 1.1 n)) +(loop for i from 2 upto 32 + for n = (let ((*read-base* i)) (read-from-string "+1.1")) + always (= 1.1 n)) +(loop for i from 2 upto 32 + for n = (let ((*read-base* i)) (read-from-string "-1.1")) + always (= -1.1 n)) + +(zerop (read-from-string "0/2")) +(zerop (read-from-string "0/3")) +(zerop (read-from-string "0/4")) +(zerop (read-from-string "0/5")) +(zerop (read-from-string "0/6")) +(zerop (read-from-string "0/7")) +(zerop (read-from-string "0/8")) +(zerop (read-from-string "0/9")) +(zerop (read-from-string "0/10")) +(zerop (read-from-string "0/11")) +(zerop (read-from-string "0/12")) +(zerop (read-from-string "0/13")) +(zerop (read-from-string "0/14")) +(zerop (read-from-string "0/15")) +(zerop (read-from-string "0/16")) +(zerop (read-from-string "0/17")) +(zerop (read-from-string "0/18")) +(zerop (read-from-string "0/19")) +(zerop (read-from-string "0/20")) + +(= 1/2 (read-from-string "1/2")) +(= 1/3 (read-from-string "1/3")) +(= 1/4 (read-from-string "1/4")) +(= 1/5 (read-from-string "1/5")) +(= 1/6 (read-from-string "1/6")) +(= 1/7 (read-from-string "1/7")) +(= 1/8 (read-from-string "1/8")) +(= 1/9 (read-from-string "1/9")) +(= 1/10 (read-from-string "1/10")) +(= 1/11 (read-from-string "1/11")) +(= 1/12 (read-from-string "1/12")) +(= 1/13 (read-from-string "1/13")) +(= 1/14 (read-from-string "1/14")) +(= 1/15 (read-from-string "1/15")) +(= 1/16 (read-from-string "1/16")) +(= 1/17 (read-from-string "1/17")) +(= 1/18 (read-from-string "1/18")) +(= 1/19 (read-from-string "1/19")) +(= 1/20 (read-from-string "1/20")) + +(= 2/2 (read-from-string "2/2")) +(= 2/3 (read-from-string "2/3")) +(= 2/4 (read-from-string "2/4")) +(= 2/5 (read-from-string "2/5")) +(= 2/6 (read-from-string "2/6")) +(= 2/7 (read-from-string "2/7")) +(= 2/8 (read-from-string "2/8")) +(= 2/9 (read-from-string "2/9")) +(= 2/10 (read-from-string "2/10")) +(= 2/11 (read-from-string "2/11")) +(= 2/12 (read-from-string "2/12")) +(= 2/13 (read-from-string "2/13")) +(= 2/14 (read-from-string "2/14")) +(= 2/15 (read-from-string "2/15")) +(= 2/16 (read-from-string "2/16")) +(= 2/17 (read-from-string "2/17")) +(= 2/18 (read-from-string "2/18")) +(= 2/19 (read-from-string "2/19")) +(= 2/20 (read-from-string "2/20")) + +(= 17/2 (read-from-string "17/2")) +(= 17/3 (read-from-string "17/3")) +(= 17/4 (read-from-string "17/4")) +(= 17/5 (read-from-string "17/5")) +(= 17/6 (read-from-string "17/6")) +(= 17/7 (read-from-string "17/7")) +(= 17/8 (read-from-string "17/8")) +(= 17/9 (read-from-string "17/9")) +(= 17/10 (read-from-string "17/10")) +(= 17/11 (read-from-string "17/11")) +(= 17/12 (read-from-string "17/12")) +(= 17/13 (read-from-string "17/13")) +(= 17/14 (read-from-string "17/14")) +(= 17/15 (read-from-string "17/15")) +(= 17/16 (read-from-string "17/16")) +(= 17/17 (read-from-string "17/17")) +(= 17/18 (read-from-string "17/18")) +(= 17/19 (read-from-string "17/19")) +(= 17/20 (read-from-string "17/20")) + +(= 0 (let ((*read-base* 2)) (read-from-string "0/1"))) +(= 1 (let ((*read-base* 2)) (read-from-string "1/1"))) +(= 1/2 (let ((*read-base* 2)) (read-from-string "1/10"))) +(= 1/3 (let ((*read-base* 2)) (read-from-string "1/11"))) +(= 1/4 (let ((*read-base* 2)) (read-from-string "1/100"))) +(= 1/5 (let ((*read-base* 2)) (read-from-string "1/101"))) +(= 1/6 (let ((*read-base* 2)) (read-from-string "1/110"))) +(= 1/7 (let ((*read-base* 2)) (read-from-string "1/111"))) +(= 1/8 (let ((*read-base* 2)) (read-from-string "1/1000"))) +(= 1/9 (let ((*read-base* 2)) (read-from-string "1/1001"))) +(= 1/10 (let ((*read-base* 2)) (read-from-string "1/1010"))) +(= 1/11 (let ((*read-base* 2)) (read-from-string "1/1011"))) +(= 1/12 (let ((*read-base* 2)) (read-from-string "1/1100"))) +(= 1/13 (let ((*read-base* 2)) (read-from-string "1/1101"))) +(= 1/14 (let ((*read-base* 2)) (read-from-string "1/1110"))) +(= 1/15 (let ((*read-base* 2)) (read-from-string "1/1111"))) +(= 1/16 (let ((*read-base* 2)) (read-from-string "1/10000"))) +(= 1/17 (let ((*read-base* 2)) (read-from-string "1/10001"))) +(= 1/18 (let ((*read-base* 2)) (read-from-string "1/10010"))) +(= 1/19 (let ((*read-base* 2)) (read-from-string "1/10011"))) +(= 1/20 (let ((*read-base* 2)) (read-from-string "1/10100"))) +(= 1/21 (let ((*read-base* 2)) (read-from-string "1/10101"))) +(= 1/22 (let ((*read-base* 2)) (read-from-string "1/10110"))) +(= 1/23 (let ((*read-base* 2)) (read-from-string "1/10111"))) + +(= 2 (let ((*read-base* 2)) (read-from-string "10/1"))) +(= 2/2 (let ((*read-base* 2)) (read-from-string "10/10"))) +(= 2/3 (let ((*read-base* 2)) (read-from-string "10/11"))) +(= 2/4 (let ((*read-base* 2)) (read-from-string "10/100"))) +(= 2/5 (let ((*read-base* 2)) (read-from-string "10/101"))) +(= 2/6 (let ((*read-base* 2)) (read-from-string "10/110"))) +(= 2/7 (let ((*read-base* 2)) (read-from-string "10/111"))) +(= 2/8 (let ((*read-base* 2)) (read-from-string "10/1000"))) +(= 2/9 (let ((*read-base* 2)) (read-from-string "10/1001"))) +(= 2/10 (let ((*read-base* 2)) (read-from-string "10/1010"))) +(= 2/11 (let ((*read-base* 2)) (read-from-string "10/1011"))) +(= 2/12 (let ((*read-base* 2)) (read-from-string "10/1100"))) +(= 2/13 (let ((*read-base* 2)) (read-from-string "10/1101"))) +(= 2/14 (let ((*read-base* 2)) (read-from-string "10/1110"))) +(= 2/15 (let ((*read-base* 2)) (read-from-string "10/1111"))) +(= 2/16 (let ((*read-base* 2)) (read-from-string "10/10000"))) +(= 2/17 (let ((*read-base* 2)) (read-from-string "10/10001"))) +(= 2/18 (let ((*read-base* 2)) (read-from-string "10/10010"))) +(= 2/19 (let ((*read-base* 2)) (read-from-string "10/10011"))) +(= 2/20 (let ((*read-base* 2)) (read-from-string "10/10100"))) +(= 2/21 (let ((*read-base* 2)) (read-from-string "10/10101"))) +(= 2/22 (let ((*read-base* 2)) (read-from-string "10/10110"))) +(= 2/23 (let ((*read-base* 2)) (read-from-string "10/10111"))) + +(= 3 (let ((*read-base* 2)) (read-from-string "11/1"))) +(= 3/2 (let ((*read-base* 2)) (read-from-string "11/10"))) +(= 3/3 (let ((*read-base* 2)) (read-from-string "11/11"))) +(= 3/4 (let ((*read-base* 2)) (read-from-string "11/100"))) +(= 3/5 (let ((*read-base* 2)) (read-from-string "11/101"))) +(= 3/6 (let ((*read-base* 2)) (read-from-string "11/110"))) +(= 3/7 (let ((*read-base* 2)) (read-from-string "11/111"))) +(= 3/8 (let ((*read-base* 2)) (read-from-string "11/1000"))) +(= 3/9 (let ((*read-base* 2)) (read-from-string "11/1001"))) +(= 3/10 (let ((*read-base* 2)) (read-from-string "11/1010"))) +(= 3/11 (let ((*read-base* 2)) (read-from-string "11/1011"))) +(= 3/12 (let ((*read-base* 2)) (read-from-string "11/1100"))) +(= 3/13 (let ((*read-base* 2)) (read-from-string "11/1101"))) +(= 3/14 (let ((*read-base* 2)) (read-from-string "11/1110"))) +(= 3/15 (let ((*read-base* 2)) (read-from-string "11/1111"))) +(= 3/16 (let ((*read-base* 2)) (read-from-string "11/10000"))) +(= 3/17 (let ((*read-base* 2)) (read-from-string "11/10001"))) +(= 3/18 (let ((*read-base* 2)) (read-from-string "11/10010"))) +(= 3/19 (let ((*read-base* 2)) (read-from-string "11/10011"))) +(= 3/20 (let ((*read-base* 2)) (read-from-string "11/10100"))) +(= 3/21 (let ((*read-base* 2)) (read-from-string "11/10101"))) +(= 3/22 (let ((*read-base* 2)) (read-from-string "11/10110"))) +(= 3/23 (let ((*read-base* 2)) (read-from-string "11/10111"))) + +(= 0 (let ((*read-base* 8)) (read-from-string "0/1"))) +(= 1/2 (let ((*read-base* 8)) (read-from-string "1/2"))) +(= 1/3 (let ((*read-base* 8)) (read-from-string "1/3"))) +(= 1/4 (let ((*read-base* 8)) (read-from-string "1/4"))) +(= 1/5 (let ((*read-base* 8)) (read-from-string "1/5"))) +(= 1/6 (let ((*read-base* 8)) (read-from-string "1/6"))) +(= 1/7 (let ((*read-base* 8)) (read-from-string "1/7"))) +(= 1/8 (let ((*read-base* 8)) (read-from-string "1/10"))) +(= 1/9 (let ((*read-base* 8)) (read-from-string "1/11"))) +(= 1/10 (let ((*read-base* 8)) (read-from-string "1/12"))) +(= 1/11 (let ((*read-base* 8)) (read-from-string "1/13"))) +(= 1/12 (let ((*read-base* 8)) (read-from-string "1/14"))) +(= 1/13 (let ((*read-base* 8)) (read-from-string "1/15"))) +(= 1/14 (let ((*read-base* 8)) (read-from-string "1/16"))) +(= 1/15 (let ((*read-base* 8)) (read-from-string "1/17"))) +(= 1/16 (let ((*read-base* 8)) (read-from-string "1/20"))) +(= 1/17 (let ((*read-base* 8)) (read-from-string "1/21"))) +(= 1/18 (let ((*read-base* 8)) (read-from-string "1/22"))) +(= 1/19 (let ((*read-base* 8)) (read-from-string "1/23"))) +(= 1/20 (let ((*read-base* 8)) (read-from-string "1/24"))) + +(= 3/2 (let ((*read-base* 8)) (read-from-string "3/2"))) +(= 3/3 (let ((*read-base* 8)) (read-from-string "3/3"))) +(= 3/4 (let ((*read-base* 8)) (read-from-string "3/4"))) +(= 3/5 (let ((*read-base* 8)) (read-from-string "3/5"))) +(= 3/6 (let ((*read-base* 8)) (read-from-string "3/6"))) +(= 3/7 (let ((*read-base* 8)) (read-from-string "3/7"))) +(= 3/8 (let ((*read-base* 8)) (read-from-string "3/10"))) +(= 3/9 (let ((*read-base* 8)) (read-from-string "3/11"))) +(= 3/10 (let ((*read-base* 8)) (read-from-string "3/12"))) +(= 3/11 (let ((*read-base* 8)) (read-from-string "3/13"))) +(= 3/12 (let ((*read-base* 8)) (read-from-string "3/14"))) +(= 3/13 (let ((*read-base* 8)) (read-from-string "3/15"))) +(= 3/14 (let ((*read-base* 8)) (read-from-string "3/16"))) +(= 3/15 (let ((*read-base* 8)) (read-from-string "3/17"))) +(= 3/16 (let ((*read-base* 8)) (read-from-string "3/20"))) +(= 3/17 (let ((*read-base* 8)) (read-from-string "3/21"))) +(= 3/18 (let ((*read-base* 8)) (read-from-string "3/22"))) +(= 3/19 (let ((*read-base* 8)) (read-from-string "3/23"))) +(= 3/20 (let ((*read-base* 8)) (read-from-string "3/24"))) + +(= 13/2 (let ((*read-base* 8)) (read-from-string "15/2"))) +(= 13/3 (let ((*read-base* 8)) (read-from-string "15/3"))) +(= 13/4 (let ((*read-base* 8)) (read-from-string "15/4"))) +(= 13/5 (let ((*read-base* 8)) (read-from-string "15/5"))) +(= 13/6 (let ((*read-base* 8)) (read-from-string "15/6"))) +(= 13/7 (let ((*read-base* 8)) (read-from-string "15/7"))) +(= 13/8 (let ((*read-base* 8)) (read-from-string "15/10"))) +(= 13/9 (let ((*read-base* 8)) (read-from-string "15/11"))) +(= 13/10 (let ((*read-base* 8)) (read-from-string "15/12"))) +(= 13/11 (let ((*read-base* 8)) (read-from-string "15/13"))) +(= 13/12 (let ((*read-base* 8)) (read-from-string "15/14"))) +(= 13/13 (let ((*read-base* 8)) (read-from-string "15/15"))) +(= 13/14 (let ((*read-base* 8)) (read-from-string "15/16"))) +(= 13/15 (let ((*read-base* 8)) (read-from-string "15/17"))) +(= 13/16 (let ((*read-base* 8)) (read-from-string "15/20"))) +(= 13/17 (let ((*read-base* 8)) (read-from-string "15/21"))) +(= 13/18 (let ((*read-base* 8)) (read-from-string "15/22"))) +(= 13/19 (let ((*read-base* 8)) (read-from-string "15/23"))) +(= 13/20 (let ((*read-base* 8)) (read-from-string "15/24"))) + + +(= 0 (let ((*read-base* 16)) (read-from-string "0/1"))) +(= 1/2 (let ((*read-base* 16)) (read-from-string "1/2"))) +(= 1/3 (let ((*read-base* 16)) (read-from-string "1/3"))) +(= 1/4 (let ((*read-base* 16)) (read-from-string "1/4"))) +(= 1/5 (let ((*read-base* 16)) (read-from-string "1/5"))) +(= 1/6 (let ((*read-base* 16)) (read-from-string "1/6"))) +(= 1/7 (let ((*read-base* 16)) (read-from-string "1/7"))) +(= 1/8 (let ((*read-base* 16)) (read-from-string "1/8"))) +(= 1/9 (let ((*read-base* 16)) (read-from-string "1/9"))) +(= 1/10 (let ((*read-base* 16)) (read-from-string "1/A"))) +(= 1/11 (let ((*read-base* 16)) (read-from-string "1/B"))) +(= 1/12 (let ((*read-base* 16)) (read-from-string "1/C"))) +(= 1/13 (let ((*read-base* 16)) (read-from-string "1/D"))) +(= 1/14 (let ((*read-base* 16)) (read-from-string "1/E"))) +(= 1/15 (let ((*read-base* 16)) (read-from-string "1/F"))) +(= 1/10 (let ((*read-base* 16)) (read-from-string "1/a"))) +(= 1/11 (let ((*read-base* 16)) (read-from-string "1/b"))) +(= 1/12 (let ((*read-base* 16)) (read-from-string "1/c"))) +(= 1/13 (let ((*read-base* 16)) (read-from-string "1/d"))) +(= 1/14 (let ((*read-base* 16)) (read-from-string "1/e"))) +(= 1/15 (let ((*read-base* 16)) (read-from-string "1/f"))) +(= 1/16 (let ((*read-base* 16)) (read-from-string "1/10"))) +(= 1/17 (let ((*read-base* 16)) (read-from-string "1/11"))) +(= 1/18 (let ((*read-base* 16)) (read-from-string "1/12"))) +(= 1/19 (let ((*read-base* 16)) (read-from-string "1/13"))) +(= 1/20 (let ((*read-base* 16)) (read-from-string "1/14"))) +(= 1/21 (let ((*read-base* 16)) (read-from-string "1/15"))) +(= 1/22 (let ((*read-base* 16)) (read-from-string "1/16"))) +(= 1/23 (let ((*read-base* 16)) (read-from-string "1/17"))) +(= 1/24 (let ((*read-base* 16)) (read-from-string "1/18"))) +(= 1/25 (let ((*read-base* 16)) (read-from-string "1/19"))) +(= 1/26 (let ((*read-base* 16)) (read-from-string "1/1A"))) +(= 1/27 (let ((*read-base* 16)) (read-from-string "1/1B"))) +(= 1/28 (let ((*read-base* 16)) (read-from-string "1/1C"))) +(= 1/29 (let ((*read-base* 16)) (read-from-string "1/1D"))) +(= 1/30 (let ((*read-base* 16)) (read-from-string "1/1E"))) +(= 1/31 (let ((*read-base* 16)) (read-from-string "1/1F"))) +(= 1/32 (let ((*read-base* 16)) (read-from-string "1/20"))) +(= 1/33 (let ((*read-base* 16)) (read-from-string "1/21"))) +(= 1/34 (let ((*read-base* 16)) (read-from-string "1/22"))) +(= 1/35 (let ((*read-base* 16)) (read-from-string "1/23"))) +(= 1/36 (let ((*read-base* 16)) (read-from-string "1/24"))) + +(= 2/2 (let ((*read-base* 16)) (read-from-string "2/2"))) +(= 2/3 (let ((*read-base* 16)) (read-from-string "2/3"))) +(= 2/4 (let ((*read-base* 16)) (read-from-string "2/4"))) +(= 2/5 (let ((*read-base* 16)) (read-from-string "2/5"))) +(= 2/6 (let ((*read-base* 16)) (read-from-string "2/6"))) +(= 2/7 (let ((*read-base* 16)) (read-from-string "2/7"))) +(= 2/8 (let ((*read-base* 16)) (read-from-string "2/8"))) +(= 2/9 (let ((*read-base* 16)) (read-from-string "2/9"))) +(= 2/10 (let ((*read-base* 16)) (read-from-string "2/A"))) +(= 2/11 (let ((*read-base* 16)) (read-from-string "2/B"))) +(= 2/12 (let ((*read-base* 16)) (read-from-string "2/C"))) +(= 2/13 (let ((*read-base* 16)) (read-from-string "2/D"))) +(= 2/14 (let ((*read-base* 16)) (read-from-string "2/E"))) +(= 2/15 (let ((*read-base* 16)) (read-from-string "2/F"))) +(= 2/10 (let ((*read-base* 16)) (read-from-string "2/a"))) +(= 2/11 (let ((*read-base* 16)) (read-from-string "2/b"))) +(= 2/12 (let ((*read-base* 16)) (read-from-string "2/c"))) +(= 2/13 (let ((*read-base* 16)) (read-from-string "2/d"))) +(= 2/14 (let ((*read-base* 16)) (read-from-string "2/e"))) +(= 2/15 (let ((*read-base* 16)) (read-from-string "2/f"))) +(= 2/16 (let ((*read-base* 16)) (read-from-string "2/10"))) +(= 2/17 (let ((*read-base* 16)) (read-from-string "2/11"))) +(= 2/18 (let ((*read-base* 16)) (read-from-string "2/12"))) +(= 2/19 (let ((*read-base* 16)) (read-from-string "2/13"))) +(= 2/20 (let ((*read-base* 16)) (read-from-string "2/14"))) +(= 2/21 (let ((*read-base* 16)) (read-from-string "2/15"))) +(= 2/22 (let ((*read-base* 16)) (read-from-string "2/16"))) +(= 2/23 (let ((*read-base* 16)) (read-from-string "2/17"))) +(= 2/24 (let ((*read-base* 16)) (read-from-string "2/18"))) +(= 2/25 (let ((*read-base* 16)) (read-from-string "2/19"))) +(= 2/26 (let ((*read-base* 16)) (read-from-string "2/1A"))) +(= 2/27 (let ((*read-base* 16)) (read-from-string "2/1B"))) +(= 2/28 (let ((*read-base* 16)) (read-from-string "2/1C"))) +(= 2/29 (let ((*read-base* 16)) (read-from-string "2/1D"))) +(= 2/30 (let ((*read-base* 16)) (read-from-string "2/1E"))) +(= 2/31 (let ((*read-base* 16)) (read-from-string "2/1F"))) +(= 2/32 (let ((*read-base* 16)) (read-from-string "2/20"))) +(= 2/33 (let ((*read-base* 16)) (read-from-string "2/21"))) +(= 2/34 (let ((*read-base* 16)) (read-from-string "2/22"))) +(= 2/35 (let ((*read-base* 16)) (read-from-string "2/23"))) +(= 2/36 (let ((*read-base* 16)) (read-from-string "2/24"))) + + +(= 10/2 (let ((*read-base* 16)) (read-from-string "a/2"))) +(= 10/3 (let ((*read-base* 16)) (read-from-string "a/3"))) +(= 10/4 (let ((*read-base* 16)) (read-from-string "a/4"))) +(= 10/5 (let ((*read-base* 16)) (read-from-string "a/5"))) +(= 10/6 (let ((*read-base* 16)) (read-from-string "a/6"))) +(= 10/7 (let ((*read-base* 16)) (read-from-string "a/7"))) +(= 10/8 (let ((*read-base* 16)) (read-from-string "a/8"))) +(= 10/9 (let ((*read-base* 16)) (read-from-string "a/9"))) +(= 10/10 (let ((*read-base* 16)) (read-from-string "a/A"))) +(= 10/11 (let ((*read-base* 16)) (read-from-string "a/B"))) +(= 10/12 (let ((*read-base* 16)) (read-from-string "a/C"))) +(= 10/13 (let ((*read-base* 16)) (read-from-string "a/D"))) +(= 10/14 (let ((*read-base* 16)) (read-from-string "a/E"))) +(= 10/15 (let ((*read-base* 16)) (read-from-string "a/F"))) +(= 10/10 (let ((*read-base* 16)) (read-from-string "a/a"))) +(= 10/11 (let ((*read-base* 16)) (read-from-string "a/b"))) +(= 10/12 (let ((*read-base* 16)) (read-from-string "a/c"))) +(= 10/13 (let ((*read-base* 16)) (read-from-string "a/d"))) +(= 10/14 (let ((*read-base* 16)) (read-from-string "a/e"))) +(= 10/15 (let ((*read-base* 16)) (read-from-string "a/f"))) +(= 10/16 (let ((*read-base* 16)) (read-from-string "a/10"))) +(= 10/17 (let ((*read-base* 16)) (read-from-string "a/11"))) +(= 10/18 (let ((*read-base* 16)) (read-from-string "a/12"))) +(= 10/19 (let ((*read-base* 16)) (read-from-string "a/13"))) +(= 10/20 (let ((*read-base* 16)) (read-from-string "a/14"))) +(= 10/21 (let ((*read-base* 16)) (read-from-string "a/15"))) +(= 10/22 (let ((*read-base* 16)) (read-from-string "a/16"))) +(= 10/23 (let ((*read-base* 16)) (read-from-string "a/17"))) +(= 10/24 (let ((*read-base* 16)) (read-from-string "a/18"))) +(= 10/25 (let ((*read-base* 16)) (read-from-string "a/19"))) +(= 10/26 (let ((*read-base* 16)) (read-from-string "a/1A"))) +(= 10/27 (let ((*read-base* 16)) (read-from-string "a/1B"))) +(= 10/28 (let ((*read-base* 16)) (read-from-string "a/1C"))) +(= 10/29 (let ((*read-base* 16)) (read-from-string "a/1D"))) +(= 10/30 (let ((*read-base* 16)) (read-from-string "a/1E"))) +(= 10/31 (let ((*read-base* 16)) (read-from-string "a/1F"))) +(= 10/32 (let ((*read-base* 16)) (read-from-string "a/20"))) +(= 10/33 (let ((*read-base* 16)) (read-from-string "a/21"))) +(= 10/34 (let ((*read-base* 16)) (read-from-string "a/22"))) +(= 10/35 (let ((*read-base* 16)) (read-from-string "a/23"))) +(= 10/36 (let ((*read-base* 16)) (read-from-string "a/24"))) + + +(= 35/2 (let ((*read-base* 16)) (read-from-string "23/2"))) +(= 35/3 (let ((*read-base* 16)) (read-from-string "23/3"))) +(= 35/4 (let ((*read-base* 16)) (read-from-string "23/4"))) +(= 35/5 (let ((*read-base* 16)) (read-from-string "23/5"))) +(= 35/6 (let ((*read-base* 16)) (read-from-string "23/6"))) +(= 35/7 (let ((*read-base* 16)) (read-from-string "23/7"))) +(= 35/8 (let ((*read-base* 16)) (read-from-string "23/8"))) +(= 35/9 (let ((*read-base* 16)) (read-from-string "23/9"))) +(= 35/10 (let ((*read-base* 16)) (read-from-string "23/A"))) +(= 35/11 (let ((*read-base* 16)) (read-from-string "23/B"))) +(= 35/12 (let ((*read-base* 16)) (read-from-string "23/C"))) +(= 35/13 (let ((*read-base* 16)) (read-from-string "23/D"))) +(= 35/14 (let ((*read-base* 16)) (read-from-string "23/E"))) +(= 35/15 (let ((*read-base* 16)) (read-from-string "23/F"))) +(= 35/10 (let ((*read-base* 16)) (read-from-string "23/a"))) +(= 35/11 (let ((*read-base* 16)) (read-from-string "23/b"))) +(= 35/12 (let ((*read-base* 16)) (read-from-string "23/c"))) +(= 35/13 (let ((*read-base* 16)) (read-from-string "23/d"))) +(= 35/14 (let ((*read-base* 16)) (read-from-string "23/e"))) +(= 35/15 (let ((*read-base* 16)) (read-from-string "23/f"))) +(= 35/16 (let ((*read-base* 16)) (read-from-string "23/10"))) +(= 35/17 (let ((*read-base* 16)) (read-from-string "23/11"))) +(= 35/18 (let ((*read-base* 16)) (read-from-string "23/12"))) +(= 35/19 (let ((*read-base* 16)) (read-from-string "23/13"))) +(= 35/20 (let ((*read-base* 16)) (read-from-string "23/14"))) +(= 35/21 (let ((*read-base* 16)) (read-from-string "23/15"))) +(= 35/22 (let ((*read-base* 16)) (read-from-string "23/16"))) +(= 35/23 (let ((*read-base* 16)) (read-from-string "23/17"))) +(= 35/24 (let ((*read-base* 16)) (read-from-string "23/18"))) +(= 35/25 (let ((*read-base* 16)) (read-from-string "23/19"))) +(= 35/26 (let ((*read-base* 16)) (read-from-string "23/1A"))) +(= 35/27 (let ((*read-base* 16)) (read-from-string "23/1B"))) +(= 35/28 (let ((*read-base* 16)) (read-from-string "23/1C"))) +(= 35/29 (let ((*read-base* 16)) (read-from-string "23/1D"))) +(= 35/30 (let ((*read-base* 16)) (read-from-string "23/1E"))) +(= 35/31 (let ((*read-base* 16)) (read-from-string "23/1F"))) +(= 35/32 (let ((*read-base* 16)) (read-from-string "23/20"))) +(= 35/33 (let ((*read-base* 16)) (read-from-string "23/21"))) +(= 35/34 (let ((*read-base* 16)) (read-from-string "23/22"))) +(= 35/35 (let ((*read-base* 16)) (read-from-string "23/23"))) +(= 35/36 (let ((*read-base* 16)) (read-from-string "23/24"))) + +(= 110/2 (let ((*read-base* 16)) (read-from-string "6E/2"))) +(= 110/3 (let ((*read-base* 16)) (read-from-string "6E/3"))) +(= 110/4 (let ((*read-base* 16)) (read-from-string "6E/4"))) +(= 110/5 (let ((*read-base* 16)) (read-from-string "6E/5"))) +(= 110/6 (let ((*read-base* 16)) (read-from-string "6E/6"))) +(= 110/7 (let ((*read-base* 16)) (read-from-string "6E/7"))) +(= 110/8 (let ((*read-base* 16)) (read-from-string "6E/8"))) +(= 110/9 (let ((*read-base* 16)) (read-from-string "6E/9"))) +(= 110/10 (let ((*read-base* 16)) (read-from-string "6E/A"))) +(= 110/11 (let ((*read-base* 16)) (read-from-string "6E/B"))) +(= 110/12 (let ((*read-base* 16)) (read-from-string "6E/C"))) +(= 110/13 (let ((*read-base* 16)) (read-from-string "6E/D"))) +(= 110/14 (let ((*read-base* 16)) (read-from-string "6E/E"))) +(= 110/15 (let ((*read-base* 16)) (read-from-string "6E/F"))) +(= 110/10 (let ((*read-base* 16)) (read-from-string "6E/a"))) +(= 110/11 (let ((*read-base* 16)) (read-from-string "6E/b"))) +(= 110/12 (let ((*read-base* 16)) (read-from-string "6E/c"))) +(= 110/13 (let ((*read-base* 16)) (read-from-string "6E/d"))) +(= 110/14 (let ((*read-base* 16)) (read-from-string "6E/e"))) +(= 110/15 (let ((*read-base* 16)) (read-from-string "6E/f"))) +(= 110/16 (let ((*read-base* 16)) (read-from-string "6E/10"))) +(= 110/17 (let ((*read-base* 16)) (read-from-string "6E/11"))) +(= 110/18 (let ((*read-base* 16)) (read-from-string "6E/12"))) +(= 110/19 (let ((*read-base* 16)) (read-from-string "6E/13"))) +(= 110/20 (let ((*read-base* 16)) (read-from-string "6E/14"))) +(= 110/21 (let ((*read-base* 16)) (read-from-string "6E/15"))) +(= 110/22 (let ((*read-base* 16)) (read-from-string "6E/16"))) +(= 110/23 (let ((*read-base* 16)) (read-from-string "6E/17"))) +(= 110/24 (let ((*read-base* 16)) (read-from-string "6E/18"))) +(= 110/25 (let ((*read-base* 16)) (read-from-string "6E/19"))) +(= 110/26 (let ((*read-base* 16)) (read-from-string "6E/1A"))) +(= 110/27 (let ((*read-base* 16)) (read-from-string "6E/1B"))) +(= 110/28 (let ((*read-base* 16)) (read-from-string "6E/1C"))) +(= 110/29 (let ((*read-base* 16)) (read-from-string "6E/1D"))) +(= 110/30 (let ((*read-base* 16)) (read-from-string "6E/1E"))) +(= 110/31 (let ((*read-base* 16)) (read-from-string "6E/1F"))) +(= 110/32 (let ((*read-base* 16)) (read-from-string "6E/20"))) +(= 110/33 (let ((*read-base* 16)) (read-from-string "6E/21"))) +(= 110/34 (let ((*read-base* 16)) (read-from-string "6E/22"))) +(= 110/35 (let ((*read-base* 16)) (read-from-string "6E/23"))) +(= 110/36 (let ((*read-base* 16)) (read-from-string "6E/24"))) + +(= 11/1111111111111111111111111111111111 + (read-from-string "11/1111111111111111111111111111111111")) + + +;; float ::= [sign] {decimal-digit}* decimal-point {decimal-digit}+ [exponent] +;; | [sign] {decimal-digit}+ [decimal-point {decimal-digit}*] exponent +(let ((f (read-from-string "0.0"))) (and (floatp f) (zerop f))) +(let ((f (read-from-string "+0.0"))) (and (floatp f) (zerop f))) +(let ((f (read-from-string "-0.0"))) (and (floatp f) (zerop f))) + +(let ((f (read-from-string ".0"))) (and (floatp f) (zerop f))) +(let ((f (read-from-string "+.0"))) (and (floatp f) (zerop f))) +(let ((f (read-from-string "-.0"))) (and (floatp f) (zerop f))) + +(let ((f (read-from-string "1.0"))) (and (floatp f) (= 1.0 f))) +(let ((f (read-from-string "+1.0"))) (and (floatp f) (= 1.0 f))) +(let ((f (read-from-string "-1.0"))) (and (floatp f) (= -1.0 f))) + +(let ((f (read-from-string "1d1"))) (and (floatp f) (= 1d1 f))) +(let ((f (read-from-string "1e1"))) (and (floatp f) (= 1e1 f))) +(let ((f (read-from-string "1f1"))) (and (floatp f) (= 1f1 f))) +(let ((f (read-from-string "1l1"))) (and (floatp f) (= 1l1 f))) +(let ((f (read-from-string "1s1"))) (and (floatp f) (= 1s1 f))) +(LET ((F (READ-FROM-STRING "1D1"))) (AND (FLOATP F) (= 1D1 F))) +(LET ((F (READ-FROM-STRING "1E1"))) (AND (FLOATP F) (= 1E1 F))) +(LET ((F (READ-FROM-STRING "1F1"))) (AND (FLOATP F) (= 1F1 F))) +(LET ((F (READ-FROM-STRING "1L1"))) (AND (FLOATP F) (= 1L1 F))) +(LET ((F (READ-FROM-STRING "1S1"))) (AND (FLOATP F) (= 1S1 F))) + +(let ((f (read-from-string "1d+1"))) (and (floatp f) (= 1d1 f))) +(let ((f (read-from-string "1e+1"))) (and (floatp f) (= 1e1 f))) +(let ((f (read-from-string "1f+1"))) (and (floatp f) (= 1f1 f))) +(let ((f (read-from-string "1l+1"))) (and (floatp f) (= 1l1 f))) +(let ((f (read-from-string "1s+1"))) (and (floatp f) (= 1s1 f))) +(LET ((F (READ-FROM-STRING "1D+1"))) (AND (FLOATP F) (= 1D1 F))) +(LET ((F (READ-FROM-STRING "1E+1"))) (AND (FLOATP F) (= 1E1 F))) +(LET ((F (READ-FROM-STRING "1F+1"))) (AND (FLOATP F) (= 1F1 F))) +(LET ((F (READ-FROM-STRING "1L+1"))) (AND (FLOATP F) (= 1L1 F))) +(LET ((F (READ-FROM-STRING "1S+1"))) (AND (FLOATP F) (= 1S1 F))) + +(let ((f (read-from-string "1d-1"))) (and (floatp f) (= 1d-1 f))) +(let ((f (read-from-string "1e-1"))) (and (floatp f) (= 1e-1 f))) +(let ((f (read-from-string "1f-1"))) (and (floatp f) (= 1f-1 f))) +(let ((f (read-from-string "1l-1"))) (and (floatp f) (= 1l-1 f))) +(let ((f (read-from-string "1s-1"))) (and (floatp f) (= 1s-1 f))) +(LET ((F (READ-FROM-STRING "1D-1"))) (AND (FLOATP F) (= 1D-1 F))) +(LET ((F (READ-FROM-STRING "1E-1"))) (AND (FLOATP F) (= 1E-1 F))) +(LET ((F (READ-FROM-STRING "1F-1"))) (AND (FLOATP F) (= 1F-1 F))) +(LET ((F (READ-FROM-STRING "1L-1"))) (AND (FLOATP F) (= 1L-1 F))) +(LET ((F (READ-FROM-STRING "1S-1"))) (AND (FLOATP F) (= 1S-1 F))) + + +(let ((f (read-from-string "+1d1"))) (and (floatp f) (= 1d1 f))) +(let ((f (read-from-string "+1e1"))) (and (floatp f) (= 1e1 f))) +(let ((f (read-from-string "+1f1"))) (and (floatp f) (= 1f1 f))) +(let ((f (read-from-string "+1l1"))) (and (floatp f) (= 1l1 f))) +(let ((f (read-from-string "+1s1"))) (and (floatp f) (= 1s1 f))) +(LET ((F (READ-FROM-STRING "+1D1"))) (AND (FLOATP F) (= 1D1 F))) +(LET ((F (READ-FROM-STRING "+1E1"))) (AND (FLOATP F) (= 1E1 F))) +(LET ((F (READ-FROM-STRING "+1F1"))) (AND (FLOATP F) (= 1F1 F))) +(LET ((F (READ-FROM-STRING "+1L1"))) (AND (FLOATP F) (= 1L1 F))) +(LET ((F (READ-FROM-STRING "+1S1"))) (AND (FLOATP F) (= 1S1 F))) + +(let ((f (read-from-string "+1d+1"))) (and (floatp f) (= 1d1 f))) +(let ((f (read-from-string "+1e+1"))) (and (floatp f) (= 1e1 f))) +(let ((f (read-from-string "+1f+1"))) (and (floatp f) (= 1f1 f))) +(let ((f (read-from-string "+1l+1"))) (and (floatp f) (= 1l1 f))) +(let ((f (read-from-string "+1s+1"))) (and (floatp f) (= 1s1 f))) +(LET ((F (READ-FROM-STRING "+1D+1"))) (AND (FLOATP F) (= 1D1 F))) +(LET ((F (READ-FROM-STRING "+1E+1"))) (AND (FLOATP F) (= 1E1 F))) +(LET ((F (READ-FROM-STRING "+1F+1"))) (AND (FLOATP F) (= 1F1 F))) +(LET ((F (READ-FROM-STRING "+1L+1"))) (AND (FLOATP F) (= 1L1 F))) +(LET ((F (READ-FROM-STRING "+1S+1"))) (AND (FLOATP F) (= 1S1 F))) + +(let ((f (read-from-string "+1d-1"))) (and (floatp f) (= 1d-1 f))) +(let ((f (read-from-string "+1e-1"))) (and (floatp f) (= 1e-1 f))) +(let ((f (read-from-string "+1f-1"))) (and (floatp f) (= 1f-1 f))) +(let ((f (read-from-string "+1l-1"))) (and (floatp f) (= 1l-1 f))) +(let ((f (read-from-string "+1s-1"))) (and (floatp f) (= 1s-1 f))) +(LET ((F (READ-FROM-STRING "+1D-1"))) (AND (FLOATP F) (= 1D-1 F))) +(LET ((F (READ-FROM-STRING "+1E-1"))) (AND (FLOATP F) (= 1E-1 F))) +(LET ((F (READ-FROM-STRING "+1F-1"))) (AND (FLOATP F) (= 1F-1 F))) +(LET ((F (READ-FROM-STRING "+1L-1"))) (AND (FLOATP F) (= 1L-1 F))) +(LET ((F (READ-FROM-STRING "+1S-1"))) (AND (FLOATP F) (= 1S-1 F))) + + +(let ((f (read-from-string "-1d1"))) (and (floatp f) (= -1d1 f))) +(let ((f (read-from-string "-1e1"))) (and (floatp f) (= -1e1 f))) +(let ((f (read-from-string "-1f1"))) (and (floatp f) (= -1f1 f))) +(let ((f (read-from-string "-1l1"))) (and (floatp f) (= -1l1 f))) +(let ((f (read-from-string "-1s1"))) (and (floatp f) (= -1s1 f))) +(LET ((F (READ-FROM-STRING "-1D1"))) (AND (FLOATP F) (= -1D1 F))) +(LET ((F (READ-FROM-STRING "-1E1"))) (AND (FLOATP F) (= -1E1 F))) +(LET ((F (READ-FROM-STRING "-1F1"))) (AND (FLOATP F) (= -1F1 F))) +(LET ((F (READ-FROM-STRING "-1L1"))) (AND (FLOATP F) (= -1L1 F))) +(LET ((F (READ-FROM-STRING "-1S1"))) (AND (FLOATP F) (= -1S1 F))) + +(let ((f (read-from-string "-1d+1"))) (and (floatp f) (= -1d1 f))) +(let ((f (read-from-string "-1e+1"))) (and (floatp f) (= -1e1 f))) +(let ((f (read-from-string "-1f+1"))) (and (floatp f) (= -1f1 f))) +(let ((f (read-from-string "-1l+1"))) (and (floatp f) (= -1l1 f))) +(let ((f (read-from-string "-1s+1"))) (and (floatp f) (= -1s1 f))) +(LET ((F (READ-FROM-STRING "-1D+1"))) (AND (FLOATP F) (= -1D1 F))) +(LET ((F (READ-FROM-STRING "-1E+1"))) (AND (FLOATP F) (= -1E1 F))) +(LET ((F (READ-FROM-STRING "-1F+1"))) (AND (FLOATP F) (= -1F1 F))) +(LET ((F (READ-FROM-STRING "-1L+1"))) (AND (FLOATP F) (= -1L1 F))) +(LET ((F (READ-FROM-STRING "-1S+1"))) (AND (FLOATP F) (= -1S1 F))) + +(let ((f (read-from-string "-1d-1"))) (and (floatp f) (= -1d-1 f))) +(let ((f (read-from-string "-1e-1"))) (and (floatp f) (= -1e-1 f))) +(let ((f (read-from-string "-1f-1"))) (and (floatp f) (= -1f-1 f))) +(let ((f (read-from-string "-1l-1"))) (and (floatp f) (= -1l-1 f))) +(let ((f (read-from-string "-1s-1"))) (and (floatp f) (= -1s-1 f))) +(LET ((F (READ-FROM-STRING "-1D-1"))) (AND (FLOATP F) (= -1D-1 F))) +(LET ((F (READ-FROM-STRING "-1E-1"))) (AND (FLOATP F) (= -1E-1 F))) +(LET ((F (READ-FROM-STRING "-1F-1"))) (AND (FLOATP F) (= -1F-1 F))) +(LET ((F (READ-FROM-STRING "-1L-1"))) (AND (FLOATP F) (= -1L-1 F))) +(LET ((F (READ-FROM-STRING "-1S-1"))) (AND (FLOATP F) (= -1S-1 F))) + + +(let ((f (read-from-string "1d10"))) (and (floatp f) (= 1d10 f))) +(let ((f (read-from-string "1e10"))) (and (floatp f) (= 1e10 f))) +(let ((f (read-from-string "1f10"))) (and (floatp f) (= 1f10 f))) +(let ((f (read-from-string "1l10"))) (and (floatp f) (= 1l10 f))) +(let ((f (read-from-string "1s10"))) (and (floatp f) (= 1s10 f))) +(LET ((F (READ-FROM-STRING "1D10"))) (AND (FLOATP F) (= 1D10 F))) +(LET ((F (READ-FROM-STRING "1E10"))) (AND (FLOATP F) (= 1E10 F))) +(LET ((F (READ-FROM-STRING "1F10"))) (AND (FLOATP F) (= 1F10 F))) +(LET ((F (READ-FROM-STRING "1L10"))) (AND (FLOATP F) (= 1L10 F))) +(LET ((F (READ-FROM-STRING "1S10"))) (AND (FLOATP F) (= 1S10 F))) + +(let ((f (read-from-string "1d+10"))) (and (floatp f) (= 1d10 f))) +(let ((f (read-from-string "1e+10"))) (and (floatp f) (= 1e10 f))) +(let ((f (read-from-string "1f+10"))) (and (floatp f) (= 1f10 f))) +(let ((f (read-from-string "1l+10"))) (and (floatp f) (= 1l10 f))) +(let ((f (read-from-string "1s+10"))) (and (floatp f) (= 1s10 f))) +(LET ((F (READ-FROM-STRING "1D+10"))) (AND (FLOATP F) (= 1D10 F))) +(LET ((F (READ-FROM-STRING "1E+10"))) (AND (FLOATP F) (= 1E10 F))) +(LET ((F (READ-FROM-STRING "1F+10"))) (AND (FLOATP F) (= 1F10 F))) +(LET ((F (READ-FROM-STRING "1L+10"))) (AND (FLOATP F) (= 1L10 F))) +(LET ((F (READ-FROM-STRING "1S+10"))) (AND (FLOATP F) (= 1S10 F))) + +(let ((f (read-from-string "1d-10"))) (and (floatp f) (= 1d-10 f))) +(let ((f (read-from-string "1e-10"))) (and (floatp f) (= 1e-10 f))) +(let ((f (read-from-string "1f-10"))) (and (floatp f) (= 1f-10 f))) +(let ((f (read-from-string "1l-10"))) (and (floatp f) (= 1l-10 f))) +(let ((f (read-from-string "1s-10"))) (and (floatp f) (= 1s-10 f))) +(LET ((F (READ-FROM-STRING "1D-10"))) (AND (FLOATP F) (= 1D-10 F))) +(LET ((F (READ-FROM-STRING "1E-10"))) (AND (FLOATP F) (= 1E-10 F))) +(LET ((F (READ-FROM-STRING "1F-10"))) (AND (FLOATP F) (= 1F-10 F))) +(LET ((F (READ-FROM-STRING "1L-10"))) (AND (FLOATP F) (= 1L-10 F))) +(LET ((F (READ-FROM-STRING "1S-10"))) (AND (FLOATP F) (= 1S-10 F))) + + +(let ((f (read-from-string "+1d10"))) (and (floatp f) (= 1d10 f))) +(let ((f (read-from-string "+1e10"))) (and (floatp f) (= 1e10 f))) +(let ((f (read-from-string "+1f10"))) (and (floatp f) (= 1f10 f))) +(let ((f (read-from-string "+1l10"))) (and (floatp f) (= 1l10 f))) +(let ((f (read-from-string "+1s10"))) (and (floatp f) (= 1s10 f))) +(LET ((F (READ-FROM-STRING "+1D10"))) (AND (FLOATP F) (= 1D10 F))) +(LET ((F (READ-FROM-STRING "+1E10"))) (AND (FLOATP F) (= 1E10 F))) +(LET ((F (READ-FROM-STRING "+1F10"))) (AND (FLOATP F) (= 1F10 F))) +(LET ((F (READ-FROM-STRING "+1L10"))) (AND (FLOATP F) (= 1L10 F))) +(LET ((F (READ-FROM-STRING "+1S10"))) (AND (FLOATP F) (= 1S10 F))) + +(let ((f (read-from-string "+1d+10"))) (and (floatp f) (= 1d10 f))) +(let ((f (read-from-string "+1e+10"))) (and (floatp f) (= 1e10 f))) +(let ((f (read-from-string "+1f+10"))) (and (floatp f) (= 1f10 f))) +(let ((f (read-from-string "+1l+10"))) (and (floatp f) (= 1l10 f))) +(let ((f (read-from-string "+1s+10"))) (and (floatp f) (= 1s10 f))) +(LET ((F (READ-FROM-STRING "+1D+10"))) (AND (FLOATP F) (= 1D10 F))) +(LET ((F (READ-FROM-STRING "+1E+10"))) (AND (FLOATP F) (= 1E10 F))) +(LET ((F (READ-FROM-STRING "+1F+10"))) (AND (FLOATP F) (= 1F10 F))) +(LET ((F (READ-FROM-STRING "+1L+10"))) (AND (FLOATP F) (= 1L10 F))) +(LET ((F (READ-FROM-STRING "+1S+10"))) (AND (FLOATP F) (= 1S10 F))) + +(let ((f (read-from-string "+1d-10"))) (and (floatp f) (= 1d-10 f))) +(let ((f (read-from-string "+1e-10"))) (and (floatp f) (= 1e-10 f))) +(let ((f (read-from-string "+1f-10"))) (and (floatp f) (= 1f-10 f))) +(let ((f (read-from-string "+1l-10"))) (and (floatp f) (= 1l-10 f))) +(let ((f (read-from-string "+1s-10"))) (and (floatp f) (= 1s-10 f))) +(LET ((F (READ-FROM-STRING "+1D-10"))) (AND (FLOATP F) (= 1D-10 F))) +(LET ((F (READ-FROM-STRING "+1E-10"))) (AND (FLOATP F) (= 1E-10 F))) +(LET ((F (READ-FROM-STRING "+1F-10"))) (AND (FLOATP F) (= 1F-10 F))) +(LET ((F (READ-FROM-STRING "+1L-10"))) (AND (FLOATP F) (= 1L-10 F))) +(LET ((F (READ-FROM-STRING "+1S-10"))) (AND (FLOATP F) (= 1S-10 F))) + + +(let ((f (read-from-string "-1d10"))) (and (floatp f) (= -1d10 f))) +(let ((f (read-from-string "-1e10"))) (and (floatp f) (= -1e10 f))) +(let ((f (read-from-string "-1f10"))) (and (floatp f) (= -1f10 f))) +(let ((f (read-from-string "-1l10"))) (and (floatp f) (= -1l10 f))) +(let ((f (read-from-string "-1s10"))) (and (floatp f) (= -1s10 f))) +(LET ((F (READ-FROM-STRING "-1D10"))) (AND (FLOATP F) (= -1D10 F))) +(LET ((F (READ-FROM-STRING "-1E10"))) (AND (FLOATP F) (= -1E10 F))) +(LET ((F (READ-FROM-STRING "-1F10"))) (AND (FLOATP F) (= -1F10 F))) +(LET ((F (READ-FROM-STRING "-1L10"))) (AND (FLOATP F) (= -1L10 F))) +(LET ((F (READ-FROM-STRING "-1S10"))) (AND (FLOATP F) (= -1S10 F))) + +(let ((f (read-from-string "-1d+10"))) (and (floatp f) (= -1d10 f))) +(let ((f (read-from-string "-1e+10"))) (and (floatp f) (= -1e10 f))) +(let ((f (read-from-string "-1f+10"))) (and (floatp f) (= -1f10 f))) +(let ((f (read-from-string "-1l+10"))) (and (floatp f) (= -1l10 f))) +(let ((f (read-from-string "-1s+10"))) (and (floatp f) (= -1s10 f))) +(LET ((F (READ-FROM-STRING "-1D+10"))) (AND (FLOATP F) (= -1D10 F))) +(LET ((F (READ-FROM-STRING "-1E+10"))) (AND (FLOATP F) (= -1E10 F))) +(LET ((F (READ-FROM-STRING "-1F+10"))) (AND (FLOATP F) (= -1F10 F))) +(LET ((F (READ-FROM-STRING "-1L+10"))) (AND (FLOATP F) (= -1L10 F))) +(LET ((F (READ-FROM-STRING "-1S+10"))) (AND (FLOATP F) (= -1S10 F))) + +(let ((f (read-from-string "-1d-10"))) (and (floatp f) (= -1d-10 f))) +(let ((f (read-from-string "-1e-10"))) (and (floatp f) (= -1e-10 f))) +(let ((f (read-from-string "-1f-10"))) (and (floatp f) (= -1f-10 f))) +(let ((f (read-from-string "-1l-10"))) (and (floatp f) (= -1l-10 f))) +(let ((f (read-from-string "-1s-10"))) (and (floatp f) (= -1s-10 f))) +(LET ((F (READ-FROM-STRING "-1D-10"))) (AND (FLOATP F) (= -1D-10 F))) +(LET ((F (READ-FROM-STRING "-1E-10"))) (AND (FLOATP F) (= -1E-10 F))) +(LET ((F (READ-FROM-STRING "-1F-10"))) (AND (FLOATP F) (= -1F-10 F))) +(LET ((F (READ-FROM-STRING "-1L-10"))) (AND (FLOATP F) (= -1L-10 F))) +(LET ((F (READ-FROM-STRING "-1S-10"))) (AND (FLOATP F) (= -1S-10 F))) + +(floatp (read-from-string "-1.23")) +(floatp (read-from-string "-823.0023D10")) +(floatp (read-from-string "-324.0293E10")) +(floatp (read-from-string "-12.0023F10")) +(floatp (read-from-string "-911.823L10")) +(floatp (read-from-string "-788.823S10")) + +(eq '|\256| (read-from-string "\\256")) +(eq '|25\64| (read-from-string "25\\64")) +(eq '|1.0\E6| (read-from-string "1.0\\E6")) +(eq '|100| (read-from-string "|100|")) +(eq '|3.14159| (read-from-string "3\\.14159")) +(eq '|3/4| (read-from-string "|3/4|")) +(eq '|3/4| (read-from-string "3\\/4")) +(eq '|5| (read-from-string "5||")) +(eq '|5| (read-from-string "||5")) +(eq '|567| (read-from-string "||567")) +(eq '|567| (read-from-string "5||67")) +(eq '|567| (read-from-string "56||7")) +(eq '|567| (read-from-string "567||")) +(eq '|567| (read-from-string "||5||6||7||")) +(eq '|567| (read-from-string "||||5||||6||||7||||")) +(eq '|567| (read-from-string "567||||||")) + + +(eq '|/| (read-from-string "/")) +(eq '|/5| (read-from-string "/5")) +(eq '|+| (read-from-string "+")) +(eq '|1+| (read-from-string "1+")) +(eq '|1-| (read-from-string "1-")) +(eq '|FOO+| (read-from-string "foo+")) +(eq '|AB.CD| (read-from-string "ab.cd")) +(eq '|_| (read-from-string "_")) +(eq '|^| (read-from-string "^")) +(eq '|^/-| (read-from-string "^/-")) + +(eq :a (read-from-string ":a")) +(eq :b (read-from-string ":b")) +(eq :c (read-from-string ":c")) +(eq :d (read-from-string ":d")) +(eq :keyword-symbol (read-from-string ":keyword-symbol")) +(eq 'cl::cdr (read-from-string "cl::cdr")) +(eq 'cl:append (read-from-string "cl:append")) +(eq 'cl-user::append (read-from-string "cl-user::append")) +(progn + (when (find-package 'test-foo) (delete-package 'test-foo)) + (make-package 'test-foo :use nil) + (handler-case (read-from-string "test-foo:no-such-symbol") + (error () t) + (:no-error (&rest rest) (declare (ignore rest)) nil))) +(progn + (when (find-package 'test-foo) (delete-package 'test-foo)) + (make-package 'test-foo :use nil) + (and (not (find-symbol "NEW-ONE" "TEST-FOO")) + (read-from-string "test-foo::new-one") + (find-symbol "NEW-ONE" "TEST-FOO"))) +(progn + (when (find-package 'test-foo) (delete-package 'test-foo)) + (let ((*package* (make-package 'test-foo :use nil))) + (read-from-string "my-symbol"))) +(string= " " (symbol-name (read-from-string "cl-user::\\ "))) +(progn + (when (find-package 'no-such-package) (delete-package 'no-such-package)) + (handler-case (read-from-string "no-such-package::bar") + (error () t) + (:no-error (&rest rest) (declare (ignore rest)) nil))) +(progn + (when (find-package 'no-such-package) (delete-package 'no-such-package)) + (handler-case (read-from-string "no-such-package::no-such-symbol") + (error () t) + (:no-error (&rest rest) (declare (ignore rest)) nil))) + + +(string= "FROBBOZ" (symbol-name (read-from-string "FROBBOZ"))) +(string= "FROBBOZ" (symbol-name (read-from-string "frobboz"))) +(string= "FROBBOZ" (symbol-name (read-from-string "fRObBoz"))) +(string= "UNWIND-PROTECT" (symbol-name (read-from-string "unwind-protect"))) +(string= "+$" (symbol-name (read-from-string "+$"))) +(string= "1+" (symbol-name (read-from-string "1+"))) +(= 1 (read-from-string "+1")) +(string= "PASCAL_STYLE" (symbol-name (read-from-string "pascal_style"))) +(string= "FILE.REL.43" (symbol-name (read-from-string "file.rel.43"))) +(string= "\(" (symbol-name (read-from-string "\\("))) +(string= "\+1" (symbol-name (read-from-string "\\+1"))) +(string= "+\1" (symbol-name (read-from-string "+\\1"))) +(string= "fROBBOZ" (symbol-name (read-from-string "\\frobboz"))) +(string= "3.14159265s0" (symbol-name (read-from-string "3.14159265\\s0"))) +(string= "3.14159265S0" (symbol-name (read-from-string "3.14159265\\S0"))) +(string= "FOo" (symbol-name (read-from-string "fo\\o"))) + +(string= "APL\\360" (symbol-name (read-from-string "APL\\\\360"))) +(string= "APL\\360" (symbol-name (read-from-string "apl\\\\360"))) +(string= "(B^2)-4*A*C" (symbol-name (read-from-string "\\(b^2\\)\\-\\4*a*c"))) +(string= "(b^2)-4*a*c" + (symbol-name (read-from-string "\\(\\b^2\\)\\-\\4*\\a*\\c"))) +(string= "\"" (symbol-name (read-from-string "|\"|"))) +(string= "(b^2) - 4*a*c" (symbol-name (read-from-string "|(b^2) - 4*a*c|"))) +(string= "frobboz" (symbol-name (read-from-string "|frobboz|"))) +(string= "APL360" (symbol-name (read-from-string "|APL\\360|"))) +(string= "APL\\360" (symbol-name (read-from-string "|APL\\\\360|"))) +(string= "apl\\360" (symbol-name (read-from-string "|apl\\\\360|"))) +(string= "||" (symbol-name (read-from-string "|\\|\\||"))) +(string= "(B^2) - 4*A*C" (symbol-name (read-from-string "|(B^2) - 4*A*C|"))) +(string= "(b^2) - 4*a*c" (symbol-name (read-from-string "|(b^2) - 4*a*c|"))) +(string= "." (symbol-name (read-from-string "\\."))) +(string= ".." (symbol-name (read-from-string "|..|"))) + + +(null (read-from-string "()")) +(null (read-from-string "( )")) +(null (read-from-string "( )")) +(equal (read-from-string "(a)") '(a)) +(equal (read-from-string "( a)") '(a)) +(equal (read-from-string "(a )") '(a)) +(equal (read-from-string "( a )") '(a)) +(equal (read-from-string "(a b)") '(a b)) +(equal (read-from-string "( a b)") '(a b)) +(equal (read-from-string "( a b )") '(a b)) +(equal (read-from-string "( a b )") '(a b)) +(equal (read-from-string "( a b )") '(a b)) +(equal (read-from-string "(a #| |# b)") '(a b)) +(equal (read-from-string "(a #| |# b #| |# )") '(a b)) +(equal (read-from-string "(a #| |# b +)") '(a b)) +(equal (read-from-string "( +a +b +)") '(a b)) +(equal (read-from-string "(a . b)") '(a . b)) +(equal (read-from-string "(a . nil)") '(a)) +(equal (read-from-string "(a . (b))") '(a b)) +(equal (read-from-string "(a . (b . (c . (d))))") '(a b c d)) +(let ((x (read-from-string "(a .$b)"))) + (and (= 2 (length x)) + (eq (first x) 'a) + (eq (second x) '|.$B|))) +(equal (read-from-string "(a b c . d)") + (cons 'a (cons 'b (cons 'c 'd)))) +(equal (read-from-string "(this-one . that-one)") + (cons 'this-one 'that-one)) +(equal (read-from-string "(a b c d . (e f . (g)))") '(a b c d e f g)) +(equal (read-from-string "(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30)") + '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30)) +(handler-case (read-from-string ")") + (error () t) + (:no-error (&rest rest) (declare (ignore rest)) nil)) + +(equal (read-from-string "(a (b (c d)))") '(a (b (c d)))) +(equal (read-from-string "'a") '(quote a)) +(equal (read-from-string "'(a b c)") '(quote (a b c))) +(equal (read-from-string "'''(a b c)") '(quote (quote (quote (a b c))))) +(equal (read-from-string "'(a 'b '('c))") + '(quote (a (quote b) (quote ((quote c)))))) +(equal (read-from-string "'('('a '('b 'c)))") + '(quote ((quote ((quote a) (quote ((quote b) (quote c)))))))) +(equal (read-from-string "''''''a") + '(quote (quote (quote (quote (quote (quote a))))))) +(equal (read-from-string "' a") '(quote a)) +(eq 'quote (eval (read-from-string "(car ''foo)"))) + + + +(eq (read-from-string "; comment +a") 'a) +(= 7 (eval (read-from-string "(+ 3 ; three +4)"))) +(eq 'a (read-from-string ";;;;;;; +a")) +(equal (read-from-string "(a ;;;;;;; +b ;; +;; +c;;;;;;;;;;;;;;;;;;;;;;;;;;; +d)") '(a b c d)) +(equal (read-from-string "(a ; comment + ; + ; +; +b)") '(a b)) +(equal (read-from-string "(a\\;b c)") '(|A;B| c)) + +(string= (read-from-string "\"hello\"") "hello") +(string= (read-from-string "\"\\\"hello\\\"\"") "\"hello\"") +(string= (read-from-string "\"|hello|\"") "|hello|") +(string= "string" (read-from-string " \"string\"")) +(let ((x (read-from-string "\"\\\\\""))) + (and (= 1 (length x)) (char= #\\ (char x 0)))) +(string= " This is a sentence. " (read-from-string "\" This is a sentence. \"")) +(simple-string-p (read-from-string "\"a simple string\"")) +(let ((x (read-from-string "\"\\\"\""))) + (and (= 1 (length x)) (char= #\" (char x 0)))) +(let ((x (read-from-string "\"|\""))) + (and (= 1 (length x)) (char= #\| (char x 0)))) + + +(eq (eval (read-from-string "`a")) 'a) +(equal (eval (read-from-string "(let ((x 1)) `(a ,x))")) '(a 1)) +(equal (eval (read-from-string "(let ((x 1)) `(a ,`(,x)))")) '(a (1))) +(equal (eval (read-from-string "(let ((a 0) (c 2) (d '(3))) `((,a b) ,c ,@d))")) + '((0 b) 2 3)) +(equal + (eval (read-from-string "(let ((a 0) (c 2) (d '(3 4 5))) `((,a b) ,c ,@d))")) + '((0 b) 2 3 4 5)) +(equal + (eval (read-from-string "(let ((a '(0 1)) (c 2) (d '(3 4 5))) + `((,a b) ,c ,@d))")) + '(((0 1) b) 2 3 4 5)) +(equal + (eval (read-from-string "(let ((a '(0 1)) (c 2) (d '(3 4 5))) + `((,@a b) ,c ,@d))")) + '((0 1 b) 2 3 4 5)) +(equal (eval (read-from-string "`(a b ,`c)")) '(a b c)) +(equal (eval (read-from-string "`(a ,@(map 'list #'char-upcase \"bcd\") e f)")) + '(a #\B #\C #\D E F)) +(equal (eval (read-from-string "(let ((x 1)) `(a . ,x))")) '(a . 1)) +(equal (eval (read-from-string "(let ((x '(b c))) `(a . ,x))")) '(a b c)) +(equalp (eval (read-from-string "(let ((x #(b c))) `(a . ,x))")) '(a . #(b c))) +(equalp (eval (read-from-string "(let ((x '(b c))) `#(a ,x))")) #(a (b c))) +(equalp (eval (read-from-string "(let ((x 'b ) (y 'c)) `#(a ,x ,y))")) + #(a b c)) +(equalp (eval (read-from-string "(let ((x '(b c))) `#(a ,@x))")) #(a b c)) +(equalp (eval (read-from-string "`\"abc\"")) "abc") +(equalp (eval (read-from-string "(let ((x '(b c)) (y '(d e)) (z '(f g))) `(a ,@x ,@y ,@z))")) '(a b c d e f g)) +(equalp (eval (read-from-string "(let ((x '(b c)) (y 'd) (z '(e f g h))) `(a ,@x ,y ,@z))")) '(a b c d e f g h)) +(equal (eval (read-from-string "`(a ,@(mapcar #'char-downcase `(,(char-upcase #\\b) ,(char-upcase #\\c) ,(char-upcase #\\d))) e f)")) + '(a #\b #\c #\d e f)) +(equal (eval (read-from-string "`(a ,@(map 'list #'char-downcase `#(,(char-upcase #\\b) ,(char-upcase #\\c) ,(char-upcase #\\d))) e f)")) + '(a #\b #\c #\d e f)) +(equal (eval (read-from-string "(let ((x 1)) `(a (,x)))")) '(a (1))) +(equal (eval (read-from-string "(let ((x 1)) `(a ((,x))))")) '(a ((1)))) +(equal (eval (read-from-string "(let ((x 1)) `(a (((,x)))))")) '(a (((1))))) +(equalp (eval (read-from-string "(let ((x 1)) `(a ((#(,x)))))")) '(a ((#(1))))) +(equalp (eval (read-from-string "(let ((x 1)) `(a #((#(,x)))))")) '(a #((#(1))))) +(equalp (eval (read-from-string "(let ((x 1)) `#(a #((#(,x)))))")) + '#(a #((#(1))))) +(equal (eval (read-from-string "(let ((x 1) (y 2) (z 3)) `(,x (,y) ((,z))))")) + '(1 (2) ((3)))) +(equal (eval (read-from-string + "(let ((x 1) (y 2) (z 3)) `((,x) ((,y)) (((,z)))))")) + '((1) ((2)) (((3))))) +(equal (eval (read-from-string + "(let ((x 1) (y 2) (z 3)) `(((,x)) (((,y))) ((((,z))))))")) + '(((1)) (((2))) ((((3)))))) +(equal (eval (read-from-string + "(let ((x 1) (y 2) (z 3)) `((((,x))) ((((,y)))) (((((,z)))))))")) + '((((1))) ((((2)))) (((((3))))))) +(equalp (eval (read-from-string "(let ((x 1) (y 2) (z 3)) `#(,x (,y) ((,z))))")) + '#(1 (2) ((3)))) +(equalp (eval (read-from-string + "(let ((x 1) (y 2) (z 3)) `#((,x) ((,y)) (((,z)))))")) + '#((1) ((2)) (((3))))) +(equalp (eval (read-from-string + "(let ((x 1) (y 2) (z 3)) `#(((,x)) (((,y))) ((((,z))))))")) + '#(((1)) (((2))) ((((3)))))) +(equalp (eval (read-from-string + "(let ((x 1) (y 2) (z 3)) `#((((,x))) ((((,y)))) (((((,z)))))))")) + '#((((1))) ((((2)))) (((((3))))))) +(equal (eval (read-from-string "(let ((x 1)) `'(,x))")) ''(1)) +(equal (eval (read-from-string "(let ((x 1)) `'(',x))")) ''('1)) +(equal (eval (read-from-string "`'(','x))")) ''('x)) +(equal (eval (read-from-string "`(a . b)")) '(a . b)) +(equal (eval (read-from-string "(let ((x 1)) `(a . ,x))")) '(a . 1)) +(equal (eval (read-from-string "(let ((x 1)) `(a . (b . (,x))))")) '(a b 1)) +(equal (eval (read-from-string "(let ((x 1)) `(a ,x . z))")) '(a 1 . z)) +(equalp (eval (read-from-string "(let ((x 1)) `(a #(#(#(,x))) . z))")) + '(a #(#(#(1))) . z)) + +(handler-case (read-from-string ",") + (error () t) + (:no-error (&rest rest) (declare (ignore rest)) nil)) + +(handler-case (read-from-string "'(,x)") + (error () t) + (:no-error (&rest rest) (declare (ignore rest)) nil)) + +(handler-case (read-from-string "`(,(append ,x y))") + (error () t) + (:no-error (&rest rest) (declare (ignore rest)) nil)) + +(char= (read-from-string "#\\a") #\a) +(char= (read-from-string "#\\b") #\b) +(char= (read-from-string "#\\c") #\c) +(char= (read-from-string "#\\d") #\d) +(char= (read-from-string "#\\e") #\e) +(char= (read-from-string "#\\f") #\f) +(char= (read-from-string "#\\g") #\g) +(char= (read-from-string "#\\h") #\h) +(char= (read-from-string "#\\i") #\i) +(char= (read-from-string "#\\j") #\j) +(char= (read-from-string "#\\k") #\k) +(char= (read-from-string "#\\l") #\l) +(char= (read-from-string "#\\m") #\m) +(char= (read-from-string "#\\n") #\n) +(char= (read-from-string "#\\o") #\o) +(char= (read-from-string "#\\p") #\p) +(char= (read-from-string "#\\q") #\q) +(char= (read-from-string "#\\r") #\r) +(char= (read-from-string "#\\s") #\s) +(char= (read-from-string "#\\t") #\t) +(char= (read-from-string "#\\u") #\u) +(char= (read-from-string "#\\v") #\v) +(char= (read-from-string "#\\w") #\w) +(char= (read-from-string "#\\x") #\x) +(char= (read-from-string "#\\y") #\y) +(char= (read-from-string "#\\z") #\z) +(CHAR= (READ-FROM-STRING "#\\A") #\A) +(CHAR= (READ-FROM-STRING "#\\B") #\B) +(CHAR= (READ-FROM-STRING "#\\C") #\C) +(CHAR= (READ-FROM-STRING "#\\D") #\D) +(CHAR= (READ-FROM-STRING "#\\E") #\E) +(CHAR= (READ-FROM-STRING "#\\F") #\F) +(CHAR= (READ-FROM-STRING "#\\G") #\G) +(CHAR= (READ-FROM-STRING "#\\H") #\H) +(CHAR= (READ-FROM-STRING "#\\I") #\I) +(CHAR= (READ-FROM-STRING "#\\J") #\J) +(CHAR= (READ-FROM-STRING "#\\K") #\K) +(CHAR= (READ-FROM-STRING "#\\L") #\L) +(CHAR= (READ-FROM-STRING "#\\M") #\M) +(CHAR= (READ-FROM-STRING "#\\N") #\N) +(CHAR= (READ-FROM-STRING "#\\O") #\O) +(CHAR= (READ-FROM-STRING "#\\P") #\P) +(CHAR= (READ-FROM-STRING "#\\Q") #\Q) +(CHAR= (READ-FROM-STRING "#\\R") #\R) +(CHAR= (READ-FROM-STRING "#\\S") #\S) +(CHAR= (READ-FROM-STRING "#\\T") #\T) +(CHAR= (READ-FROM-STRING "#\\U") #\U) +(CHAR= (READ-FROM-STRING "#\\V") #\V) +(CHAR= (READ-FROM-STRING "#\\W") #\W) +(CHAR= (READ-FROM-STRING "#\\X") #\X) +(CHAR= (READ-FROM-STRING "#\\Y") #\Y) +(CHAR= (READ-FROM-STRING "#\\Z") #\Z) +(not (char= (read-from-string "#\\Z") (read-from-string "#\\z"))) + +(char= (read-from-string "#\\0") #\0) +(char= (read-from-string "#\\1") #\1) +(char= (read-from-string "#\\2") #\2) +(char= (read-from-string "#\\3") #\3) +(char= (read-from-string "#\\4") #\4) +(char= (read-from-string "#\\5") #\5) +(char= (read-from-string "#\\6") #\6) +(char= (read-from-string "#\\7") #\7) +(char= (read-from-string "#\\8") #\8) +(char= (read-from-string "#\\9") #\9) + +(char= (read-from-string "#\\!") #\!) +(char= (read-from-string "#\\$") #\$) +(char= (read-from-string "#\\\"") #\") +(char= (read-from-string "#\\'") #\') +(char= (read-from-string "#\\(") #\() +(char= (read-from-string "#\\)") #\)) +(char= (read-from-string "#\\,") #\,) +(char= (read-from-string "#\\_") #\_) +(char= (read-from-string "#\\-") #\-) +(char= (read-from-string "#\\.") #\.) +(char= (read-from-string "#\\/") #\/) +(char= (read-from-string "#\\:") #\:) +(char= (read-from-string "#\\;") #\;) +(char= (read-from-string "#\\?") #\?) +(char= (read-from-string "#\\+") #\+) +(char= (read-from-string "#\\<") #\<) +(char= (read-from-string "#\\=") #\=) +(char= (read-from-string "#\\>") #\>) +(char= (read-from-string "#\\#") #\#) +(char= (read-from-string "#\\%") #\%) +(char= (read-from-string "#\\&") #\&) +(char= (read-from-string "#\\*") #\*) +(char= (read-from-string "#\\@") #\@) +(char= (read-from-string "#\\[") #\[) +(char= (read-from-string "#\\\\") #\\) +(char= (read-from-string "#\\]") #\]) +(char= (read-from-string "#\\{") #\{) +(char= (read-from-string "#\\|") #\|) +(char= (read-from-string "#\\}") #\}) +(char= (read-from-string "#\\`") #\`) +(char= (read-from-string "#\\^") #\^) +(char= (read-from-string "#\\~") #\~) + +(char= (read-from-string "#\\newline") #\newline) +(char= (read-from-string "#\\space") #\space) +(char= (read-from-string "#\\Newline") #\newline) +(char= (read-from-string "#\\Space") #\space) +(char= (read-from-string "#\\NeWlInE") #\newline) +(char= (read-from-string "#\\SpAcE") #\space) +(char= (read-from-string "#\\NEWLINE") #\newline) +(char= (read-from-string "#\\SPACE") #\space) + + +(equal (read-from-string "#'car") '(function car)) +(eq (eval (read-from-string "#'car")) #'car) + +(simple-vector-p (read-from-string "#(a)")) +(equalp (read-from-string "#(a)") #(a)) +(equalp (read-from-string "#()") #()) +(equalp (read-from-string "#(a b)") #(a b)) +(equalp (read-from-string "#(a b c)") #(a b c)) +(equalp (read-from-string "#(a b c d)") #(a b c d)) +(equalp (read-from-string "#(a b c d e)") #(a b c d e)) +(equalp (read-from-string "#(a b c d e f)") #(a b c d e f)) +(equalp (read-from-string "#(a b c d e f g)") #(a b c d e f g)) +(equalp (read-from-string "#(a b c c c c)") #(a b c c c c)) +(equalp (read-from-string "#6(a b c c c c)") #(a b c c c c)) +(equalp (read-from-string "#6(a b c)") #(a b c c c c)) +(equalp (read-from-string "#6(a b c c)") #(a b c c c c)) +(let ((x (read-from-string "#(a b c)"))) (= 3 (length x))) +(let ((x (read-from-string "#()"))) + (and (simple-vector-p x) + (zerop (length x)) + (equalp x #0()))) +(let ((x (read-from-string "#0()"))) + (and (simple-vector-p x) + (zerop (length x)) + (equalp x #()))) +(equalp (read-from-string "#1(a)") #(a)) +(equalp (read-from-string "#2(a b)") #(a b)) +(equalp (read-from-string "#3(a b c)") #(a b c)) +(equalp (read-from-string "#4(a b c d)") #(a b c d)) +(equalp (read-from-string "#5(a b c d e)") #(a b c d e)) +(equalp (read-from-string "#6(a b c d e f)") #(a b c d e f)) +(equalp (read-from-string "#2(a)") #(a a)) +(equalp (read-from-string "#3(a)") #(a a a)) +(equalp (read-from-string "#4(a)") #(a a a a)) +(equalp (read-from-string "#5(a)") #(a a a a a)) +(equalp (read-from-string "#6(a)") #(a a a a a a)) +(equalp (read-from-string "#7(a)") #(a a a a a a a)) +(equalp (read-from-string "#8(a)") #(a a a a a a a a)) +(equalp (read-from-string "#9(a)") #(a a a a a a a a a)) +(equalp (read-from-string "#10(a)") #(a a a a a a a a a a)) +(let ((x (read-from-string "#100(a)"))) + (and (simple-vector-p x) + (= 100 (length x)) + (every #'symbolp x) + (every #'(lambda (s) (eq s 'a)) x))) +(let ((x (read-from-string "#100(#\\z)"))) + (and (simple-vector-p x) + (= 100 (length x)) + (every #'characterp x) + (every #'(lambda (c) (char= c #\z)) x))) +(let ((x (read-from-string "#100(#())"))) + (and (simple-vector-p x) + (= 100 (length x)) + (every #'simple-vector-p x) + (every #'(lambda (v) (zerop (length v))) x))) + + +(equalp (read-from-string "#*0") #*0) +(equalp (read-from-string "#*1") #*1) +(equalp (read-from-string "#*01") #*01) +(equalp (read-from-string "#*10") #*10) +(equalp (read-from-string "#*11") #*11) +(equalp (read-from-string "#0*") #*) +(equalp (read-from-string "#*") #*) +(equalp (read-from-string "#3*1") #*111) +(equalp (read-from-string "#3*10") #*100) +(equalp (read-from-string "#*101111") #*101111) +(equalp (read-from-string "#6*101111") #*101111) +(equalp (read-from-string "#6*101") #*101111) +(equalp (read-from-string "#6*1011") #*101111) +(let ((x (read-from-string "#*10"))) + (and (simple-bit-vector-p x) + (= 2 (length x)) + (= 1 (bit x 0)) + (= 0 (bit x 1)))) +(let ((x (read-from-string "#*"))) + (and (simple-bit-vector-p x) + (zerop (length x)))) +(let ((x (read-from-string "#100*0"))) + (and (simple-bit-vector-p x) + (= 100 (length x)) + (every #'zerop x))) +(let ((x (read-from-string "#100*1"))) + (and (simple-bit-vector-p x) + (= 100 (length x)) + (every #'(lambda (n) (= 1 n)) x))) +(handler-case (read-from-string "#3*1110") + (reader-error () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)) +(handler-case (read-from-string "#3*") + (reader-error () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)) +(handler-case (read-from-string "#3*abc") + (reader-error () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)) + +(let ((symbol (read-from-string "#:ok"))) + (and (null (symbol-package symbol)) (string= (symbol-name symbol) "OK"))) +(let ((symbol (read-from-string "#:g10"))) + (and (null (symbol-package symbol)) (string= (symbol-name symbol) "G10"))) +(let ((symbol (read-from-string "#:10"))) + (and (null (symbol-package symbol)) (string= (symbol-name symbol) "10"))) +(let ((symbol (read-from-string "#:0"))) + (and (null (symbol-package symbol)) (string= (symbol-name symbol) "0"))) +(let ((symbol (read-from-string "#:-"))) + (and (null (symbol-package symbol)) (string= (symbol-name symbol) "-"))) +(let ((symbol (read-from-string "#:\\-"))) + (and (null (symbol-package symbol)) (string= (symbol-name symbol) "-"))) +(let ((symbol (read-from-string "#:$$-$$"))) + (and (null (symbol-package symbol)) (string= (symbol-name symbol) "$$-$$"))) + +(eq 'a (read-from-string "#.'a")) +(packagep (read-from-string "#.*package*")) +(= 11 (read-from-string "#.(let ((x 10)) (1+ x))")) +(= 4 (read-from-string "#.(1+ 3)")) +(handler-case (let ((*read-eval* nil)) (read-from-string "#.(1+ 3)")) + (reader-error () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)) +(equal '(a b . 3) (read-from-string "#.(let ((x 3)) `(a b . ,x))")) + + +(= (read-from-string "#b0") 0) +(= (read-from-string "#B0") 0) +(= (read-from-string "#b01") 1) +(= (read-from-string "#B01") 1) +(= (read-from-string "#B1101") 13) +(= (read-from-string "#b101/11") 5/3) +(= 172236929 (read-from-string "#b1010010001000010000010000001")) + +(= (read-from-string "#o0") 0) +(= (read-from-string "#O0") 0) +(= (read-from-string "#o37/15") 31/13) +(= (read-from-string "#o777") 511) +(= (read-from-string "#o105") 69) +(= (read-from-string "#O37/15") 31/13) +(= (read-from-string "#O777") 511) +(= (read-from-string "#O105") 69) +(= 342391 (read-from-string "#o1234567")) + +(= (read-from-string "#x0") 0) +(= (read-from-string "#xF00") 3840) +(= (read-from-string "#x105") 261) +(= (read-from-string "#X0") 0) +(= (read-from-string "#XF00") 3840) +(= (read-from-string "#Xf00") 3840) +(= (read-from-string "#X105") 261) +(= 81985529216486895 (read-from-string "#X0123456789ABCDEF")) + +(= (read-from-string "#3r0") 0) +(= (read-from-string "#2r11010101") 213) +(= (read-from-string "#b11010101") 213) +(= (read-from-string "#b+11010101") 213) +(= (read-from-string "#o325") 213) +(= (read-from-string "#xD5") 213) +(= (read-from-string "#16r+D5") 213) +(= (read-from-string "#o-300") -192) +(= (read-from-string "#3r-21010") -192) +(= (read-from-string "#25R-7H") -192) +(= (read-from-string "#xACCEDED") 181202413) + + + + + +(zerop (read-from-string "#c(0 0)")) +(= (read-from-string "#c(1 0)") #c(1 0)) +(complexp (read-from-string "#c(1 10)")) +(= (read-from-string "#c(1 0)") 1) +(= (read-from-string "#c(0 1)") #c(0 1)) +(= (read-from-string "#c(1 1)") #c(1 1)) +(= (read-from-string "#C(3.0s1 2.0s-1)") #C(3.0s1 2.0s-1)) +(= (read-from-string "#C(5 -3)") #c(5 -3)) +(= (read-from-string "#C(5/3 7.0)") #c(5/3 7.0)) +(let ((x (read-from-string "#C(5/3 7.0)"))) + (and (floatp (realpart x)) (floatp (imagpart x)))) + +(= (read-from-string "#C(0 1)") #C(0 1)) + +;; array +(equalp (read-from-string "#1A(0 1)") #(0 1)) +(let ((x (read-from-string "#1A(0 1)"))) + (and (vectorp x) + (= 2 (length x)) + (= 0 (aref x 0)) + (= 1 (aref x 1)))) +(equalp (read-from-string "#2A((0 1 5) (foo 2 (hot dog)))") + #2A((0 1 5) (foo 2 (hot dog)))) +(let ((x (read-from-string "#2A((0 1 5) (foo 2 (hot dog)))"))) + (and (arrayp x) + (equal (array-dimensions x) '(2 3)) + (zerop (aref x 0 0)) + (= (aref x 0 1) 1) + (= (aref x 0 2) 5) + (eq (aref x 1 0) 'foo) + (= (aref x 1 1) 2) + (equal (aref x 1 2) '(hot dog)))) +(equal (aref (read-from-string "#0A((0 1 5) (foo 2 (hot dog)))")) + '((0 1 5) (foo 2 (hot dog)))) +(let ((x (read-from-string "#0A((0 1 5) (foo 2 (hot dog)))"))) + (and (arrayp x) + (null (array-dimensions x)) + (equal (aref x) '((0 1 5) (foo 2 (hot dog)))))) +(equalp (read-from-string "#0A foo") #0Afoo) +(let ((x (read-from-string "#0A foo"))) + (and (arrayp x) + (null (array-dimensions x)) + (eq (aref x) 'foo))) + +(equal (array-dimensions (read-from-string "#3A((() ()) (() ()) (() ()))")) + '(3 2 0)) +(equal (array-dimensions (read-from-string "#10A(() ())")) + '(2 0 0 0 0 0 0 0 0 0)) +(let ((x (read-from-string " +#4A((((0 1 2 3) (4 5 6 7) (8 9 10 11)) + ((12 13 14 15) (16 17 18 19) (20 21 22 23))))"))) + (and (arrayp x) + (equal (array-dimensions x) '(1 2 3 4)) + (loop for i below 24 always (= i (row-major-aref x i))))) + +;; label +(eq (read-from-string "#1=a") 'a) +(equal (read-from-string "(#1=a #1#)") '(a a)) +(let ((x (read-from-string "#1=(a . #1#)"))) (eq x (cdr x))) +(let ((x (read-from-string "((a b) . #1=(#2=(p q) foo #2# . #1#))"))) + (and (eq (nthcdr 1 x) (nthcdr 4 x)) + (eq (nthcdr 4 x) (nthcdr 7 x)) + (eq (nthcdr 7 x) (nthcdr 10 x)) + (eq (nth 1 x) (nth 3 x)) + (eq (nth 3 x) (nth 6 x)) + (eq (nth 6 x) (nth 9 x)) + (eq (nth 9 x) (nth 12 x)))) +(let ((x (read-from-string "(#1=(a . #1#) #2=(#1# . #2#))"))) + (and (eq (car x) (caadr x)) + (eq (car x) (cdar x)) + (eq (cadr x) (cdadr x)))) +(let ((x (read-from-string "#1=#2=#3=(0 . #1#)"))) + (and (eq x (cdr x)) (zerop (car x)))) +(let ((x (read-from-string "#1=#2=#3=(0 . #2#)"))) + (and (eq x (cdr x)) (zerop (car x)))) +(let ((x (read-from-string "#1=#2=#3=(0 . #3#)"))) + (and (eq x (cdr x)) (zerop (car x)))) +(let ((x (read-from-string "#1=#2=#3=(0 #1# #2# #3#)"))) + (and (= 4 (length x)) + (zerop (first x)) + (eq x (second x)) + (eq x (third x)) + (eq x (fourth x)))) +(equal (read-from-string "(#1000=a #1000#)") '(a a)) +(let ((x (read-from-string "(#1=#:g10 #1#)"))) + (and (= 2 (length x)) + (string= (symbol-name (first x)) "G10") + (eq (first x) (second x)))) +(let ((x (read-from-string "#1=(a (b #2=(x y z) . #1#) . #2#)"))) + (and (eq (first x) 'a) + (eq x (cddr (second x))) + (eq (second (second x)) (cddr x)))) +(let ((x (read-from-string "(#1=(a (b #2=(x y z) . #1#) . #2#))"))) + (and (eq (caar x) 'a) + (eq (car x) (cddr (second (first x)))) + (eq (second (second (first x))) (cddr (first x))))) +(let ((x (read-from-string "#1=(a #2=(b #3=(c . #3#) . #2#) . #1#)"))) + (and (eq (first x) 'a) + (eq (first (second x)) 'b) + (eq (first (second (second x))) 'c) + (eq x (cddr x)) + (eq (second x) (cddr (second x))) + (eq (second (second x)) (cdr (second (second x)))))) +(let ((x (read-from-string "#1=(a #2=(b #3=(c . #1#) . #2#) . #3#)"))) + (and (eq (first x) 'a) + (eq (first (second x)) 'b) + (eq (first (second (second x))) 'c) + (eq x (cdr (second (second x)))) + (eq (second x) (cddr (second x))) + (eq (second (second x)) (cddr x)))) +(let ((x (read-from-string "(#1=#(0 1 2) #1#)"))) + (and (= 2 (length x)) + (eq (first x) (second x)) + (equalp (first x) #(0 1 2)))) + +(let ((x (read-from-string "#1=#(#1# 1 2)"))) + (and (= 3 (length x)) + (eq (aref x 0) x) + (= (aref x 1) 1) + (= (aref x 2) 2))) +(let ((x (read-from-string "#(#1=#:g00 a b #1#)"))) + (and (= 4 (length x)) + (string= (symbol-name (aref x 0)) "G00") + (eq (aref x 0) (aref x 3)) + (eq (aref x 1) 'a) + (eq (aref x 2) 'b))) +(let ((x (read-from-string "#1=#(#2=#:g00 a #2# #1#)"))) + (and (= 4 (length x)) + (string= (symbol-name (aref x 0)) "G00") + (eq x (aref x 3)) + (eq (aref x 0) (aref x 2)) + (eq (aref x 1) 'a))) +(let ((x (read-from-string "#1=#(#1# #1# #1#)"))) + (and (= 3 (length x)) + (eq x (aref x 0)) + (eq (aref x 0) (aref x 1)) + (eq (aref x 1) (aref x 2)))) +(let ((x (read-from-string "#1=#(#(#1#))"))) + (and (= 1 (length x)) + (= 1 (length (aref x 0))) + (eq x (aref (aref x 0) 0)))) +(let ((x (read-from-string "#1=#(#2=#(#3=#(#3# #2# #1#))))"))) + (and (= 1 (length x)) + (= 1 (length (aref x 0))) + (= 3 (length (aref (aref x 0) 0))) + (eq x (aref (aref (aref x 0) 0) 2)) + (eq (aref x 0) (aref (aref (aref x 0) 0) 1)) + (eq (aref (aref x 0) 0) (aref (aref (aref x 0) 0) 0)))) +(let ((x (read-from-string "#1=#(#2=#(#3=#(#1# #2# #3#))))"))) + (and (= 1 (length x)) + (= 1 (length (aref x 0))) + (= 3 (length (aref (aref x 0) 0))) + (eq x (aref (aref (aref x 0) 0) 0)) + (eq (aref x 0) (aref (aref (aref x 0) 0) 1)) + (eq (aref (aref x 0) 0) (aref (aref (aref x 0) 0) 2)))) +(let ((x (read-from-string "(#1=#(0 #2=#:g100 2) #2# #1#)"))) + (and (= 3 (length x)) + (eq (first x) (third x)) + (string= (symbol-name (aref (first x) 1)) "G100") + (null (symbol-package (aref (first x) 1))) + (eq (aref (first x) 1) (second x)))) +(let ((x (read-from-string "(a #1=#(0 (#1#) 2) c)"))) + (and (= 3 (length x)) + (eq (first x) 'a) + (eq (second x) (first (aref (second x) 1))) + (eq (third x) 'c) + (= 0 (aref (second x) 0)) + (= 2 (aref (second x) 2)))) +(let ((x (read-from-string "#1=#2A((a b) (c #1#))"))) + (and (= 4 (array-total-size x)) + (eq (aref x 0 0) 'a) + (eq (aref x 0 1) 'b) + (eq (aref x 1 0) 'c) + (eq (aref x 1 1) x))) +(let ((x (read-from-string "#2A((#1=#:G10 b) (#1# d))"))) + (and (= 4 (array-total-size x)) + (eq (aref x 0 0) (aref x 1 0)) + (null (symbol-package (aref x 0 0))) + (string= (symbol-name (aref x 0 0)) "G10") + (eq (aref x 0 1) 'b) + (eq (aref x 1 1) 'd))) +(let ((x (read-from-string "#1=#2A((#2=#:GG #1#) (#2# #1#))"))) + (and (= 4 (array-total-size x)) + (eq (aref x 0 0) (aref x 1 0)) + (null (symbol-package (aref x 0 0))) + (string= "GG" (symbol-name (aref x 0 0))) + (eq x (aref x 0 1)) + (eq x (aref x 1 1)))) +(let ((x (read-from-string "#1=#0A#1#"))) + (and (arrayp x) + (eq x (aref x)))) +(let ((x (read-from-string "#1=#0A(#1#)"))) + (and (arrayp x) + (consp (aref x)) + (= 1 (length (aref x))) + (eq x (first (aref x))))) +(let ((x (read-from-string "#1=#1A(#1#)"))) + (and (vectorp x) + (= 1 (length x)) + (eq x (aref x 0)))) +(let ((x (read-from-string "#1=#1A(#2=(a b c) #1# #2#)"))) + (and (vectorp x) + (= 3 (length x)) + (equal (aref x 0) '(a b c)) + (eq (aref x 0) (aref x 2)) + (eq x (aref x 1)))) +(let ((x (read-from-string + "#1=#3A(((0 a) (1 b) (2 c)) + ((3 d) (4 #2A((41 #2=#(x y z)) (43 #1#))) (5 f)) + ((6 g) (((#2#)) h) (9 i)))"))) + (and (= 18 (array-total-size x)) + (= 0 (aref x 0 0 0)) + (eq 'a (aref x 0 0 1)) + (= 1 (aref x 0 1 0)) + (eq 'b (aref x 0 1 1)) + (= 2 (aref x 0 2 0)) + (eq 'c (aref x 0 2 1)) + (= 3 (aref x 1 0 0)) + (eq 'd (aref x 1 0 1)) + (= 4 (aref x 1 1 0)) + (= (array-total-size (aref x 1 1 1)) 4) + (= 41 (aref (aref x 1 1 1) 0 0)) + (equalp (aref (aref x 1 1 1) 0 1) #(x y z)) + (= 43 (aref (aref x 1 1 1) 1 0)) + (eq x (aref (aref x 1 1 1) 1 1)) + (= 5 (aref x 1 2 0)) + (eq 'f (aref x 1 2 1)) + (= 6 (aref x 2 0 0)) + (eq 'g (aref x 2 0 1)) + (eq (caar (aref x 2 1 0)) (aref (aref x 1 1 1) 0 1)) + (eq 'h (aref x 2 1 1)) + (= 9 (aref x 2 2 0)) + (eq 'i (aref x 2 2 1)))) + + +(progn + #-CLISP ;Bruno: ANSI CL 2.2. refers to the spec of READ, which says that + ; an error of type end-of-file is signalled. + (handler-case (null (let ((*features* '())) (read-from-string "#+test1 a"))) + (error () nil)) + #+CLISP 'skipped) + +(let ((*features* '())) + (equal (with-input-from-string (stream "#+test1 a #-test1 b") + (loop + for x = (read stream nil 'end) + until (eq x 'end) + collecting x)) + '(b))) +(let ((*features* '(:test1))) + (equal (with-input-from-string (stream "#+test1 a #-test1 b") + (loop + for x = (read stream nil 'end) + until (eq x 'end) + collecting x)) + '(a))) +(let ((*features* '())) + (equal (with-input-from-string (stream "#+(not test1) eat-this") + (loop + for x = (read stream nil 'end) + until (eq x 'end) + collecting x)) + '(eat-this))) +(let ((*features* '(:test1))) + (equal (with-input-from-string (stream "#+(not test1) eat-this") + (loop + for x = (read stream nil 'end) + until (eq x 'end) + collecting x)) + '())) +(let ((*features* '(:test1))) + (equal (with-input-from-string (stream "#-(not test1) eat-this") + (loop + for x = (read stream nil 'end) + until (eq x 'end) + collecting x)) + '(eat-this))) +(let ((*features* '())) + (equal (with-input-from-string (stream "#-(not test1) eat-this") + (loop + for x = (read stream nil 'end) + until (eq x 'end) + collecting x)) + '())) + +(let ((*features* '(:test1 :test2))) + (equal (with-input-from-string (stream "#+(and test1 test2) eat-this") + (loop + for x = (read stream nil 'end) + until (eq x 'end) + collecting x)) + '(eat-this))) +(let ((*features* '(:test1))) + (equal (with-input-from-string (stream "#+(and test1 test2) eat-this") + (loop + for x = (read stream nil 'end) + until (eq x 'end) + collecting x)) + '())) +(let ((*features* '())) + (equal (with-input-from-string (stream "#+(and test1 test2) eat-this") + (loop + for x = (read stream nil 'end) + until (eq x 'end) + collecting x)) + '())) +(let ((*features* '())) + (equal (with-input-from-string (stream "#+(or test1 test2) eat-this") + (loop + for x = (read stream nil 'end) + until (eq x 'end) + collecting x)) + '())) +(let ((*features* '(:test1))) + (equal (with-input-from-string (stream "#+(or test1 test2) eat-this") + (loop + for x = (read stream nil 'end) + until (eq x 'end) + collecting x)) + '(eat-this))) +(let ((*features* '(:test2))) + (equal (with-input-from-string (stream "#+(or test1 test2) eat-this") + (loop + for x = (read stream nil 'end) + until (eq x 'end) + collecting x)) + '(eat-this))) +(let ((*features* '(:test1 :test2))) + (equal (with-input-from-string (stream "#+(or test1 test2) eat-this") + (loop + for x = (read stream nil 'end) + until (eq x 'end) + collecting x)) + '(eat-this))) +(let ((*features* '(:test1 :test2 :test3))) + (equal (with-input-from-string (stream "#+(or test1 test2) eat-this") + (loop + for x = (read stream nil 'end) + until (eq x 'end) + collecting x)) + '(eat-this))) + +(let ((*features* '(:test1 :test2))) + (equal (with-input-from-string (stream "#+(and test1 (not test2)) eat-this") + (loop + for x = (read stream nil 'end) + until (eq x 'end) + collecting x)) + '())) +(let ((*features* '())) + (equal (with-input-from-string (stream "#+(and test1 (not test2)) eat-this") + (loop + for x = (read stream nil 'end) + until (eq x 'end) + collecting x)) + '())) +(let ((*features* '(:test1))) + (equal (with-input-from-string (stream "#+(and test1 (not test2)) eat-this") + (loop + for x = (read stream nil 'end) + until (eq x 'end) + collecting x)) + '(eat-this))) +(let ((*features* '())) + (equal (with-input-from-string + (stream "#+(or (and test1 (not test2)) test3) eat-this") + (loop + for x = (read stream nil 'end) + until (eq x 'end) + collecting x)) + '())) +(let ((*features* '(:test1))) + (equal (with-input-from-string + (stream "#+(or (and test1 (not test2)) test3) eat-this") + (loop + for x = (read stream nil 'end) + until (eq x 'end) + collecting x)) + '(eat-this))) +(let ((*features* '(:test1 :test2))) + (equal (with-input-from-string + (stream "#+(or (and test1 (not test2)) test3) eat-this") + (loop + for x = (read stream nil 'end) + until (eq x 'end) + collecting x)) + '())) +(let ((*features* '(:test1 :test2 :test3))) + (equal (with-input-from-string + (stream "#+(or (and test1 (not test2)) test3) eat-this") + (loop + for x = (read stream nil 'end) + until (eq x 'end) + collecting x)) + '(eat-this))) +(let ((*features* '(:test1 :test3))) + (equal (with-input-from-string + (stream "#+(or (and test1 (not test2)) test3) eat-this") + (loop + for x = (read stream nil 'end) + until (eq x 'end) + collecting x)) + '(eat-this))) +(let ((*features* '(:test2 :test3))) + (equal (with-input-from-string + (stream "#+(or (and test1 (not test2)) test3) eat-this") + (loop + for x = (read stream nil 'end) + until (eq x 'end) + collecting x)) + '(eat-this))) + +(let ((*features* '())) + (equal (with-input-from-string + (stream "#+(and test1 (not test2) (or test3 test4)) eat-this") + (loop + for x = (read stream nil 'end) + until (eq x 'end) + collecting x)) + '())) +(let ((*features* '(:test1))) + (equal (with-input-from-string + (stream "#+(and test1 (not test2) (or test3 test4)) eat-this") + (loop + for x = (read stream nil 'end) + until (eq x 'end) + collecting x)) + '())) +(let ((*features* '(:test1 :test3))) + (equal (with-input-from-string + (stream "#+(and test1 (not test2) (or test3 test4)) eat-this") + (loop + for x = (read stream nil 'end) + until (eq x 'end) + collecting x)) + '(eat-this))) +(let ((*features* '(:test1 :test4))) + (equal (with-input-from-string + (stream "#+(and test1 (not test2) (or test3 test4)) eat-this") + (loop + for x = (read stream nil 'end) + until (eq x 'end) + collecting x)) + '(eat-this))) +(let ((*features* '(:test1 :test2))) + (equal (with-input-from-string + (stream "#+(and test1 (not test2) (or test3 test4)) eat-this") + (loop + for x = (read stream nil 'end) + until (eq x 'end) + collecting x)) + '())) +(let ((*features* '(:test1 :test2 :test3))) + (equal (with-input-from-string + (stream "#+(and test1 (not test2) (or test3 test4)) eat-this") + (loop + for x = (read stream nil 'end) + until (eq x 'end) + collecting x)) + '())) +(let ((*features* '(:test1 :test2 :test3 :test4))) + (equal (with-input-from-string + (stream "#+(and test1 (not test2) (or test3 test4)) eat-this") + (loop + for x = (read stream nil 'end) + until (eq x 'end) + collecting x)) + '())) +(let ((*features* '(:test1 :test3 :test4))) + (equal (with-input-from-string + (stream "#+(and test1 (not test2) (or test3 test4)) eat-this") + (loop + for x = (read stream nil 'end) + until (eq x 'end) + collecting x)) + '(eat-this))) + +(let ((*features* '())) + (equal (with-input-from-string + (stream "#-(not (and test1 (not test2) (or test3 test4))) eat-this") + (loop + for x = (read stream nil 'end) + until (eq x 'end) + collecting x)) + '())) +(let ((*features* '(:test1))) + (equal (with-input-from-string + (stream "#-(not (and test1 (not test2) (or test3 test4))) eat-this") + (loop + for x = (read stream nil 'end) + until (eq x 'end) + collecting x)) + '())) +(let ((*features* '(:test1 :test3))) + (equal (with-input-from-string + (stream "#-(not (and test1 (not test2) (or test3 test4))) eat-this") + (loop + for x = (read stream nil 'end) + until (eq x 'end) + collecting x)) + '(eat-this))) +(let ((*features* '(:test1 :test4))) + (equal (with-input-from-string + (stream "#-(not (and test1 (not test2) (or test3 test4))) eat-this") + (loop + for x = (read stream nil 'end) + until (eq x 'end) + collecting x)) + '(eat-this))) +(let ((*features* '(:test1 :test2))) + (equal (with-input-from-string + (stream "#-(not (and test1 (not test2) (or test3 test4))) eat-this") + (loop + for x = (read stream nil 'end) + until (eq x 'end) + collecting x)) + '())) +(let ((*features* '(:test1 :test2 :test3))) + (equal (with-input-from-string + (stream "#-(not (and test1 (not test2) (or test3 test4))) eat-this") + (loop + for x = (read stream nil 'end) + until (eq x 'end) + collecting x)) + '())) +(let ((*features* '(:test1 :test2 :test3 :test4))) + (equal (with-input-from-string + (stream "#-(not (and test1 (not test2) (or test3 test4))) eat-this") + (loop + for x = (read stream nil 'end) + until (eq x 'end) + collecting x)) + '())) +(let ((*features* '(:test1 :test3 :test4))) + (equal (with-input-from-string + (stream "#-(not (and test1 (not test2) (or test3 test4))) eat-this") + (loop + for x = (read stream nil 'end) + until (eq x 'end) + collecting x)) + '(eat-this))) + + +(eq (read-from-string "#| comment |# a") 'a) +(eq (read-from-string "#| #| nested comment |# |# a") 'a) +(eq (read-from-string "#| comment +comment + still comment +|# a") 'a) + +(handler-case (read-from-string "#<invalid-token>") + (reader-error () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)) +(handler-case (read-from-string "# ") + (reader-error () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)) +(handler-case (read-from-string "# +") + (reader-error () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)) +(handler-case (read-from-string "#)") + (reader-error () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :upcase) + (string= "ZEBRA" (symbol-name (read-from-string "ZEBRA")))) +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :upcase) + (string= "ZEBRA" (symbol-name (read-from-string "Zebra")))) +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :upcase) + (string= "ZEBRA" (symbol-name (read-from-string "zebra")))) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :downcase) + (string= "zebra" (symbol-name (read-from-string "ZEBRA")))) +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :downcase) + (string= "zebra" (symbol-name (read-from-string "Zebra")))) +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :downcase) + (string= "zebra" (symbol-name (read-from-string "zebra")))) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :preserve) + (string= "ZEBRA" (symbol-name (read-from-string "ZEBRA")))) +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :preserve) + (string= "Zebra" (symbol-name (read-from-string "Zebra")))) +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :preserve) + (string= "zebra" (symbol-name (read-from-string "zebra")))) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :invert) + (string= "zebra" (symbol-name (read-from-string "ZEBRA")))) +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :invert) + (string= "Zebra" (symbol-name (read-from-string "Zebra")))) +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :invert) + (string= "ZEBRA" (symbol-name (read-from-string "zebra")))) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :upcase) + (string= "CAT-AND-MOUSE" (symbol-name (read-from-string "cat-and-mouse")))) +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :upcase) + (string= "CAT-AND-MOUSE" (symbol-name (read-from-string "Cat-And-Mouse")))) +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :upcase) + (string= "CAT-AND-MOUSE" (symbol-name (read-from-string "CAT-AND-MOUSE")))) +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :downcase) + (string= "cat-and-mouse" (symbol-name (read-from-string "cat-and-mouse")))) +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :downcase) + (string= "cat-and-mouse" (symbol-name (read-from-string "Cat-And-Mouse")))) +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :downcase) + (string= "cat-and-mouse" (symbol-name (read-from-string "CAT-AND-MOUSE")))) +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :preserve) + (string= "cat-and-mouse" (symbol-name (read-from-string "cat-and-mouse")))) +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :preserve) + (string= "Cat-And-Mouse" (symbol-name (read-from-string "Cat-And-Mouse")))) +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :preserve) + (string= "CAT-AND-MOUSE" (symbol-name (read-from-string "CAT-AND-MOUSE")))) +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :invert) + (string= "CAT-AND-MOUSE" (symbol-name (read-from-string "cat-and-mouse")))) +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :invert) + (string= "Cat-And-Mouse" (symbol-name (read-from-string "Cat-And-Mouse")))) +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :invert) + (string= "cat-and-mouse" (symbol-name (read-from-string "CAT-AND-MOUSE")))) + +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :upcase) + (string= "CAT*AND*MOUSE" (symbol-name (read-from-string "cat*and*mouse")))) +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :upcase) + (string= "CAT*AND*MOUSE" (symbol-name (read-from-string "Cat*And*Mouse")))) +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :upcase) + (string= "CAT*AND*MOUSE" (symbol-name (read-from-string "CAT*AND*MOUSE")))) +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :downcase) + (string= "cat*and*mouse" (symbol-name (read-from-string "cat*and*mouse")))) +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :downcase) + (string= "cat*and*mouse" (symbol-name (read-from-string "Cat*And*Mouse")))) +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :downcase) + (string= "cat*and*mouse" (symbol-name (read-from-string "CAT*AND*MOUSE")))) +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :preserve) + (string= "cat*and*mouse" (symbol-name (read-from-string "cat*and*mouse")))) +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :preserve) + (string= "Cat*And*Mouse" (symbol-name (read-from-string "Cat*And*Mouse")))) +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :preserve) + (string= "CAT*AND*MOUSE" (symbol-name (read-from-string "CAT*AND*MOUSE")))) +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :invert) + (string= "CAT*AND*MOUSE" (symbol-name (read-from-string "cat*and*mouse")))) +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :invert) + (string= "Cat*And*Mouse" (symbol-name (read-from-string "Cat*And*Mouse")))) +(let ((*readtable* (copy-readtable nil))) + (setf (readtable-case *readtable*) :invert) + (string= "cat*and*mouse" (symbol-name (read-from-string "CAT*AND*MOUSE")))) + + +(with-input-from-string (stream "a b") + (and (eq 'a (read-preserving-whitespace stream)) + (eq #\Space (read-char stream)) + (eq #\b (read-char stream)))) + +(handler-case (with-input-from-string (stream " ") (read stream)) + (end-of-file () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)) + +(let ((x nil)) + (and (eq t (handler-case (with-input-from-string (stream "a") + (setq x (read stream)) + (read stream)) + (end-of-file () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil))) + (eq x 'a))) + +(progn + (let ((*readtable* (copy-readtable nil))) + (set-macro-character + #\/ + #'(lambda (stream char) + (declare (ignore char)) + `(path . ,(loop for dir = (read-preserving-whitespace stream t) + then (progn (read-char stream t nil t) + (read-preserving-whitespace stream t)) + collect dir + while (eql (peek-char nil stream nil nil t) #\/))))) + (equal (read-from-string "(zyedh /usr/games/zork /usr/games/boggle)") + '(zyedh (path usr games zork) (path usr games boggle))))) + +(progn + (let ((*readtable* (copy-readtable nil))) + (set-macro-character + #\/ + #'(lambda (stream char) + (declare (ignore char)) + `(path . ,(loop for dir = (read stream t) + then (progn (read-char stream t nil t) + (read stream t)) + collect dir + while (eql (peek-char nil stream nil nil t) #\/))))) + (equal (read-from-string "(zyedh /usr/games/zork /usr/games/boggle)") + '(zyedh (path usr games zork usr games boggle))))) + + +(let ((*readtable* (copy-readtable nil))) + (and (eq t (set-syntax-from-char #\7 #\;)) + (= 1235 (read-from-string "123579")))) + + + + + +(readtablep *readtable*) + +(readtablep (copy-readtable)) +(readtablep (copy-readtable nil)) +(readtablep (copy-readtable nil (copy-readtable))) +(let ((to (copy-readtable))) + (eq to (copy-readtable nil to))) + +(let ((zvar 123) + (table2 (copy-readtable))) + (declare (special zvar)) + (and (= zvar 123) + (set-syntax-from-char #\z #\' table2) + (= zvar 123) + (let ((*readtable* table2)) + (and (equal '(quote var) (read-from-string "zvar")) + (setq *readtable* (copy-readtable)) + (equal '(quote var) (read-from-string "zvar")) + (setq *readtable* (copy-readtable nil)) + (= 123 (eval (read-from-string "zvar"))))))) + +(not (eq (copy-readtable) *readtable*)) +(not (eq (copy-readtable) (copy-readtable))) +(not (eq (copy-readtable nil) *readtable*)) +(not (eq (copy-readtable nil) (copy-readtable nil))) + +(let ((*readtable* (copy-readtable nil))) + (and (handler-case (read-from-string "#<abc") + (reader-error () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)) + (set-dispatch-macro-character #\# #\< + #'(lambda (s c n) + (declare (ignore c n)) + (read-char s t nil t) + (read s t nil t))) + (eq 'bc (read-from-string "#<abc")) + (setq *readtable* (copy-readtable)) + (eq 'bc (read-from-string "#<abc")) + (setq *readtable* (copy-readtable nil)) + (handler-case (read-from-string "#<abc") + (reader-error () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)))) + +(let ((*readtable* (copy-readtable nil))) + (and (handler-case (read-from-string "#<abc") + (reader-error () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)) + (set-dispatch-macro-character #\# #\< + #'(lambda (s c n) + (declare (ignore c n)) + (read-char s t nil t) + (read s t nil t))) + (eq 'bc (read-from-string "#<abc")) + (setq *readtable* (copy-readtable)) + (eq 'bc (read-from-string "#<abc")) + (set-dispatch-macro-character #\# #\< + #'(lambda (s c n) + (declare (ignore c n)) + (read-char s t nil t) + (read-char s t nil t) + (read s t nil t))) + (eq 'c (read-from-string "#<abc")) + (setq *readtable* (copy-readtable nil)) + (handler-case (read-from-string "#<abc") + (reader-error () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)))) + + +(let ((table (copy-readtable nil))) + (and (eq :upcase (readtable-case table)) + (setf (readtable-case table) :invert) + (let ((copy (copy-readtable table))) + (and (not (eq table copy)) (eq (readtable-case copy) :invert))))) + +(let ((table (copy-readtable nil)) + copy) + (and (eq :upcase (readtable-case table)) + (setf (readtable-case table) :invert) + (eq (readtable-case table) :invert) + (setq copy (copy-readtable table)) + (eq (readtable-case copy) :invert) + (setf (readtable-case copy) :preserve) + (eq (readtable-case table) :invert))) + +(eq :upcase (let ((x (copy-readtable nil))) (readtable-case x))) +(let ((x (copy-readtable nil))) + (and (eq (setf (readtable-case x) :upcase) (readtable-case x)) + (eq (setf (readtable-case x) :downcase) (readtable-case x)) + (eq (setf (readtable-case x) :preserve) (readtable-case x)) + (eq (setf (readtable-case x) :invert) (readtable-case x)))) + +(handler-case (readtable-case 'not-a-readtable) + (type-error () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)) + +(handler-case (setf (readtable-case (copy-readtable nil)) :no-such-mode) + (type-error () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)) + +(let ((table (copy-readtable nil))) + (and (eq :upcase (readtable-case table)) + (setf (readtable-case table) :downcase) + (eq :downcase (readtable-case (copy-readtable table))))) + +(not (readtablep nil)) +(not (readtablep 'readtable)) +(readtablep *readtable*) +(readtablep (copy-readtable)) +(not (readtablep '*readtable*)) + +(null (get-dispatch-macro-character #\# #\0)) +(null (get-dispatch-macro-character #\# #\1)) +(null (get-dispatch-macro-character #\# #\2)) +(null (get-dispatch-macro-character #\# #\3)) +(null (get-dispatch-macro-character #\# #\4)) +(null (get-dispatch-macro-character #\# #\5)) +(null (get-dispatch-macro-character #\# #\6)) +(null (get-dispatch-macro-character #\# #\7)) +(null (get-dispatch-macro-character #\# #\8)) +(null (get-dispatch-macro-character #\# #\9)) + +(get-dispatch-macro-character #\# #\\) +(get-dispatch-macro-character #\# #\') +(get-dispatch-macro-character #\# #\() +(get-dispatch-macro-character #\# #\*) +(get-dispatch-macro-character #\# #\:) +(get-dispatch-macro-character #\# #\.) +(get-dispatch-macro-character #\# #\b) +(get-dispatch-macro-character #\# #\o) +(get-dispatch-macro-character #\# #\x) +(get-dispatch-macro-character #\# #\r) +(get-dispatch-macro-character #\# #\c) +(get-dispatch-macro-character #\# #\a) +(get-dispatch-macro-character #\# #\s) +(get-dispatch-macro-character #\# #\p) +(get-dispatch-macro-character #\# #\=) +(get-dispatch-macro-character #\# #\#) +(get-dispatch-macro-character #\# #\+) +(get-dispatch-macro-character #\# #\-) +(get-dispatch-macro-character #\# #\|) + +(get-dispatch-macro-character #\# #\newline) +(get-dispatch-macro-character #\# #\space) + +(handler-case (get-dispatch-macro-character #\a #\b) + (error () t) + (:no-error (&rest rest) (declare (ignore rest)) nil)) + +(handler-case (get-dispatch-macro-character #\a #\b nil) + (error () t) + (:no-error (&rest rest) (declare (ignore rest)) nil)) + +(handler-case (get-dispatch-macro-character #\a #\b *readtable*) + (error () t) + (:no-error (&rest rest) (declare (ignore rest)) nil)) + +(handler-case (set-dispatch-macro-character #\a #\b #'identity) + (error () t) + (:no-error (&rest rest) (declare (ignore rest)) nil)) + +(handler-case (set-dispatch-macro-character #\a #\b #'identity *readtable*) + (error () t) + (:no-error (&rest rest) (declare (ignore rest)) nil)) + + + +(let ((*readtable* (copy-readtable nil))) + (and (eq t (set-dispatch-macro-character + #\# #\{ ;dispatch on #{ + #'(lambda(s c n) + (declare (ignore c)) + (let ((list (read s nil (values) t))) ;list is object after #n{ + (when (consp list) ;return nth element of list + (unless (and n (< 0 n (length list))) (setq n 0)) + (setq list (nth n list))) + list)))) + (= 1 (read-from-string "#{(1 2 3 4)")) + (= 3 (read-from-string "#3{(0 1 2 3)")) + (= 123 (read-from-string "#{123")))) + +(let ((*readtable* (copy-readtable)) + (dollar #'(lambda (stream subchar arg) + (declare (ignore subchar arg)) + (list 'dollars (read stream t nil t))))) + (and (eq t (set-dispatch-macro-character #\# #\$ dollar)) + (equal '(dollars foo) (read-from-string "#$foo")))) + + + + +(and (let ((*readtable* (copy-readtable))) + (and (setf (readtable-case *readtable*) :invert) + (string= "ABC" (symbol-name (read-from-string "abc"))) + (string= "abc" (symbol-name (read-from-string "ABC"))) + (string= "AbC" (symbol-name (read-from-string "AbC"))) + (setf (readtable-case *readtable*) :preserve) + (string= "abc" (symbol-name (read-from-string "abc"))) + (string= "ABC" (symbol-name (read-from-string "ABC"))) + (string= "AbC" (symbol-name (read-from-string "AbC"))))) + (eq (readtable-case *readtable*) :upcase) + (string= "ABC" (symbol-name (read-from-string "abc"))) + (string= "ABC" (symbol-name (read-from-string "ABC"))) + (string= "ABC" (symbol-name (read-from-string "AbC")))) + + +(let ((*readtable* (copy-readtable))) + (and (setf (readtable-case *readtable*) :invert) + (set-macro-character #\< #'(lambda (stream c) + (declare (ignore c)) + (read-delimited-list #\> stream t)) + t) + (set-macro-character #\> (get-macro-character #\))) + (equal '(a b) (read-from-string "<a b>")))) + +(let ((*readtable* (copy-readtable))) + (and (setf (readtable-case *readtable*) :invert) + (set-macro-character #\< #'(lambda (stream c) + (declare (ignore c)) + (read-delimited-list #\> stream t))) + (set-macro-character #\> (get-macro-character #\))) + (with-input-from-string (stream "xyz<A b>jKl") + (and (eq 'xyz (read stream)) + (equal '(|a| b) (read stream)) + (eq '|jKl| (read stream)) + (eq 'end (read stream nil 'end)))))) + +(let ((*readtable* (copy-readtable nil))) + (and (equal (multiple-value-list (get-macro-character #\{)) '(nil nil)) + (eq t (make-dispatch-macro-character #\{)) + (get-macro-character #\{))) + +(let ((*readtable* (copy-readtable nil))) + (and (eq t (make-dispatch-macro-character #\{)) + (handler-case (read-from-string "{$a") + (reader-error () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)))) + + +(let ((*readtable* (copy-readtable nil))) + (and (eq t (make-dispatch-macro-character #\{)) + #-clisp (handler-case (read-from-string "{$a") + (reader-error () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)) + (set-dispatch-macro-character #\{ #\$ + #'(lambda (s c n) + (declare (ignore c n)) + (read s t nil t))) + (eq 'a (read-from-string "{$a")))) + + +(let ((*readtable* (copy-readtable nil))) + (and (eq t (make-dispatch-macro-character #\{)) + #-clisp (handler-case (read-from-string "{$a") + (reader-error () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)) + (set-dispatch-macro-character #\{ #\$ + #'(lambda (s c n) + (declare (ignore c n)) + (read s t nil t))) + (with-input-from-string (stream "xyz{$a") + (and (eq 'xyz (read stream)) + (eq 'a (read stream)) + (eq 'end (read stream nil 'end)))))) + +(let ((*readtable* (copy-readtable nil))) + (and (eq t (make-dispatch-macro-character #\{ t)) + #-clisp (handler-case (read-from-string "{$a") + (reader-error () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)) + (set-dispatch-macro-character #\{ #\$ + #'(lambda (s c n) + (declare (ignore c n)) + (read s t nil t))) + (with-input-from-string (stream "xyz{$a") + (and (eq '|XYZ{$A| (read stream)) + (eq 'end (read stream nil 'end)))))) + + +(let ((table (copy-readtable nil))) + (and (eq t (make-dispatch-macro-character #\{ nil table)) + #-clisp (let ((*readtable* table)) + (handler-case (read-from-string "{$a") + (reader-error () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil))) + (set-dispatch-macro-character #\{ #\$ + #'(lambda (s c n) + (declare (ignore c n)) + (read s t nil t)) + table) + (let ((*readtable* table)) + (with-input-from-string (stream "xyz{$a") + (and (eq 'xyz (read stream)) + (eq 'a (read stream)) + (eq 'end (read stream nil 'end))))))) + + +(let ((table (copy-readtable nil))) + (and (eq t (make-dispatch-macro-character #\{ t table)) + #-clisp (let ((*readtable* table)) + (handler-case (read-from-string "{$a") + (reader-error () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil))) + (set-dispatch-macro-character #\{ #\$ + #'(lambda (s c n) + (declare (ignore c n)) + (read s t nil t)) + table) + (let ((*readtable* table)) + (with-input-from-string (stream "xyz{$a") + (and (eq '|XYZ{$A| (read stream)) + (eq 'end (read stream nil 'end))))))) + + +(with-input-from-string (stream "") + (handler-case (read stream t) + (end-of-file () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil))) + +(with-input-from-string (stream "") + (handler-case (read-preserving-whitespace stream t) + (end-of-file () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil))) + +(with-input-from-string (stream "") + (handler-case (read stream t 'ignored) + (end-of-file () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil))) + +(with-input-from-string (stream "") + (handler-case (read-preserving-whitespace stream t 'ignored) + (end-of-file () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil))) + + +(with-input-from-string (stream "") + (eq 'end (read stream nil 'end))) + +(with-input-from-string (stream "") + (eq 'end (read-preserving-whitespace stream nil 'end))) + +(with-input-from-string (stream "a b") + (and (eq 'a (read-preserving-whitespace stream t nil nil)) + (equal (loop for c = (read-char stream nil nil) + while c collecting c) + '(#\space #\space #\b)))) + +(with-input-from-string (stream "a b") + (and (eq 'a (read-preserving-whitespace stream t nil)) + (equal (loop for c = (read-char stream nil nil) + while c collecting c) + '(#\space #\space #\b)))) + + +(with-input-from-string (stream "ok") + (let ((*standard-input* stream)) + (eq 'ok (read)))) + +(with-input-from-string (stream "ok") + (let ((*standard-input* stream)) + (eq 'ok (read-preserving-whitespace)))) + + +(with-input-from-string (stream "") + (let ((*standard-input* stream)) + (handler-case (read) + (end-of-file () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)))) + +(with-input-from-string (stream "") + (let ((*standard-input* stream)) + (handler-case (read-preserving-whitespace) + (end-of-file () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)))) + + +(with-input-from-string (stream "") + (let ((*standard-input* stream)) + (null (read nil nil)))) + +(with-input-from-string (stream "") + (let ((*standard-input* stream)) + (null (read-preserving-whitespace nil nil)))) + + +(with-input-from-string (*standard-input* "(a b") + (handler-case (read) + (end-of-file () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil))) + +(with-input-from-string (*standard-input* "(a b") + (handler-case (read-preserving-whitespace) + (end-of-file () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil))) + +(with-input-from-string (*standard-input* "(a (b") + (handler-case (read) + (end-of-file () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil))) + +(with-input-from-string (*standard-input* "(a (b") + (handler-case (read-preserving-whitespace) + (end-of-file () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil))) + +;; read-delimited-list +(with-input-from-string (*standard-input* "a b)") + (equal '(a b) (read-delimited-list #\)))) +(with-input-from-string (*standard-input* ")") + (null (read-delimited-list #\)))) +(with-input-from-string (*standard-input* "a b )") + (equal '(a b) (read-delimited-list #\)))) +(with-input-from-string (*standard-input* " a b )") + (equal '(a b) (read-delimited-list #\)))) +(with-input-from-string (*standard-input* " a b ) ") + (equal '(a b) (read-delimited-list #\)))) +(with-input-from-string (*standard-input* "a b c d e f g h i j k l m n o p q r)") + (equal '(a b c d e f g h i j k l m n o p q r) (read-delimited-list #\)))) + +(with-input-from-string + (*standard-input* "a (b) c (d) e f g h i j (k l m ) n o p q r)") + (equal '(a (b) c (d) e f g h i j (k l m) n o p q r) (read-delimited-list #\)))) +(with-input-from-string (*standard-input* "a x\\)x b)") + (equal '(a |X)X| b) (read-delimited-list #\)))) + +(with-input-from-string (*standard-input* "a b) xyz") + (and (equal '(a b) (read-delimited-list #\))) + (eq 'xyz (read)))) + +(with-input-from-string (*standard-input* "a #'car)") + (equal '(a #'car) (read-delimited-list #\)))) + +(with-input-from-string (*standard-input* "a #'car ;; +d #| e f |# g +z)") + (equal '(a #'car d g z) (read-delimited-list #\)))) + +(with-input-from-string (*standard-input* "a #'car ;; +d #| e f |# g +z) +xyz") + (and (equal '(a #'car d g z) (read-delimited-list #\))) + (eq 'xyz (read)))) + +(with-input-from-string (*standard-input* "1 2 3 4 5 6 ]") + (equal (read-delimited-list #\]) + '(1 2 3 4 5 6))) + +(get-macro-character #\) nil) + +(let ((*readtable* (copy-readtable nil)) + (f #'(lambda (stream char arg) + (declare (ignore char arg)) + (mapcon #'(lambda (x) + (mapcar #'(lambda (y) (list (car x) y)) (cdr x))) + (read-delimited-list #\} stream t))))) + (set-dispatch-macro-character #\# #\{ f) + (get-macro-character #\) nil) + (set-macro-character #\} (get-macro-character #\) nil)) + (with-input-from-string (*standard-input* "#{ p q z a}") + (equal (read) '((p q) (p z) (p a) (q z) (q a) (z a))))) +(handler-case (with-input-from-string (stream "1 2 3 . 4)") + (read-delimited-list #\) stream t)) + (error () t) + (:no-error (&rest rest) (declare (ignore rest)) nil)) + + +(get-dispatch-macro-character #\# #\( nil) +(set-syntax-from-char #\z #\' (copy-readtable nil) nil) + + +(equal '(abc 3) (multiple-value-list (read-from-string "abc"))) + +(handler-case (read-from-string "") + (end-of-file () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)) + +(handler-case (read-from-string "" t 'ignored) + (end-of-file () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)) + +(eq 'end (read-from-string "" nil 'end)) + +(equal '(b 5) (multiple-value-list (read-from-string "(a b c)" t nil + :start 2 :end 6))) + +(equal '(b 4) (multiple-value-list (read-from-string "(a b c)" t nil + :start 2 + :preserve-whitespace t))) + +(null (read-from-string "" nil)) + +(multiple-value-bind (thing pos) (read-from-string " a b" t nil :start 3) + (and (eq thing 'b) + (or (= pos 4) (= pos 5)))) + +(multiple-value-bind (thing pos) (read-from-string "abcdefg" t nil :end 2) + (and (eq thing 'ab) + (or (= pos 2) (= pos 3)))) + +(equal '(ijk 3) + (multiple-value-list (read-from-string "ijk xyz" t nil + :preserve-whitespace t))) + +(equal '(def 7) + (multiple-value-list (read-from-string "abc def ghi" t nil + :start 4 :end 9 + :preserve-whitespace t))) + +(= 3 (read-from-string " 1 3 5" t nil :start 2)) +(multiple-value-bind (thing pos) (read-from-string "(a b c)") + (and (equal thing '(A B C)) + (or (= pos 7) (= pos 8)))) + +(handler-case (read-from-string "(a b") + (error () t) + (:no-error (&rest rest) (declare (ignore rest)) nil)) + + +(let ((*readtable* (copy-readtable))) + (and (progn + #-clisp (handler-case (read-from-string "#<abc") + (reader-error () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)) + #+clisp t) + (set-dispatch-macro-character #\# #\< + #'(lambda (s c n) + (declare (ignore c n)) + (read-char s t nil t) + (read s t nil t))) + (eq 'bc (read-from-string "#<abc")) + (setq *readtable* (copy-readtable)) + (eq 'bc (read-from-string "#<abc")) + (set-dispatch-macro-character #\# #\< + #'(lambda (s c n) + (declare (ignore c n)) + (read-char s t nil t) + (read-char s t nil t) + (read s t nil t))) + (eq 'c (read-from-string "#<abc")) + (setq *readtable* (copy-readtable nil)) + (progn + #-clisp + (handler-case (read-from-string "#<abc") + (reader-error () t) + (error () nil) + (:no-error (&rest rest) (declare (ignore rest)) nil)) + #+clisp t))) + + +(let ((*readtable* (copy-readtable))) + (and (eq t (make-dispatch-macro-character #\{)) + (eq t (set-dispatch-macro-character + #\{ #\s #'(lambda (s c n) + (declare (ignore c n)) + `(section ,(read s t nil t))))) + (equal '(section (x y z)) (read-from-string "{s (x y z)")) + (equal '(section (x y z)) (read-from-string "{S (x y z)")))) + + +(multiple-value-bind (function non-terminating-p) (get-macro-character #\") + (and function (not non-terminating-p))) +(multiple-value-bind (function non-terminating-p) (get-macro-character #\#) + (and function non-terminating-p)) +(multiple-value-bind (function non-terminating-p) (get-macro-character #\') + (and function (not non-terminating-p))) +(multiple-value-bind (function non-terminating-p) (get-macro-character #\() + (and function (not non-terminating-p))) +(multiple-value-bind (function non-terminating-p) (get-macro-character #\)) + (and function (not non-terminating-p))) +(multiple-value-bind (function non-terminating-p) (get-macro-character #\,) + (and function (not non-terminating-p))) +(multiple-value-bind (function non-terminating-p) (get-macro-character #\;) + (and function (not non-terminating-p))) +(multiple-value-bind (function non-terminating-p) (get-macro-character #\`) + (and function (not non-terminating-p))) + +(multiple-value-bind (function non-terminating-p) (get-macro-character #\a) + (and (null function) (not non-terminating-p))) +(multiple-value-bind (function non-terminating-p) (get-macro-character #\z) + (and (null function) (not non-terminating-p))) +(multiple-value-bind (function non-terminating-p) (get-macro-character #\Space) + (and (null function) (not non-terminating-p))) +(multiple-value-bind (function non-terminating-p) (get-macro-character #\Tab) + (and (null function) (not non-terminating-p))) + +(multiple-value-bind (function non-terminating-p) (get-macro-character #\" nil) + (and function (not non-terminating-p))) +(multiple-value-bind (function non-terminating-p) (get-macro-character #\# nil) + (and function non-terminating-p)) +(multiple-value-bind (function non-terminating-p) (get-macro-character #\' nil) + (and function (not non-terminating-p))) +(multiple-value-bind (function non-terminating-p) (get-macro-character #\( nil) + (and function (not non-terminating-p))) +(multiple-value-bind (function non-terminating-p) (get-macro-character #\) nil) + (and function (not non-terminating-p))) +(multiple-value-bind (function non-terminating-p) (get-macro-character #\, nil) + (and function (not non-terminating-p))) +(multiple-value-bind (function non-terminating-p) (get-macro-character #\; nil) + (and function (not non-terminating-p))) +(multiple-value-bind (function non-terminating-p) (get-macro-character #\` nil) + (and function (not non-terminating-p))) + +(multiple-value-bind (function non-terminating-p) (get-macro-character #\a nil) + (and (null function) (not non-terminating-p))) +(multiple-value-bind (function non-terminating-p) (get-macro-character #\z nil) + (and (null function) (not non-terminating-p))) +(multiple-value-bind (function non-terminating-p) + (get-macro-character #\Space nil) + (and (null function) (not non-terminating-p))) +(multiple-value-bind (function non-terminating-p) (get-macro-character #\Tab nil) + (and (null function) (not non-terminating-p))) + +(and (let ((*readtable* (copy-readtable))) + (and (eq t (set-macro-character #\$ + #'(lambda (s c) + (declare (ignore c)) + `(dollars ,(read s t nil t))))) + (equal '(dollars 100) (read-from-string "$100")) + (eq '|$100| (read-from-string "\\$100")) + (eq '|$100| (read-from-string "|$|100")))) + (null (get-macro-character #\$)) + (eq '|$100| (read-from-string "$100"))) + + +(let ((*readtable* (copy-readtable))) + (and (eq t (set-syntax-from-char #\[ #\()) + (equal '(0 1 2 3) (read-from-string "[0 1 2 3)")))) + +(let ((table1 (copy-readtable nil)) + (table2 (copy-readtable nil))) + (and (eq t (set-syntax-from-char #\[ #\( table1 table1)) + (equal '(0 1 2 3) (let ((*readtable* table1)) + (read-from-string "[0 1 2 3)"))) + (eq t (set-syntax-from-char #\{ #\[ table2 table1)) + (equal '(0 1 2 3) (let ((*readtable* table2)) + (read-from-string "{0 1 2 3)"))))) + +(let ((*readtable* (copy-readtable))) + (and (eq t (set-syntax-from-char #\[ #\.)) + (eq '|3[0| (read-from-string "3[0")))) + +(let* ((str (concatenate 'string + (loop repeat 100 collecting #\() + "kernel" + (loop repeat 100 collecting #\)))) + (thing (read-from-string str))) + (and (= 1 (length thing)) + (eq 'kernel (loop repeat 101 + for x = thing then (car x) + finally (return x))))) + + + + +(null (let ((*read-suppress* t)) (read-from-string "abc"))) +(null (let ((*read-suppress* t)) + (with-input-from-string (stream "abc") + (read stream)))) +(null (let ((*read-suppress* t)) + (with-input-from-string (stream "abc") + (read-preserving-whitespace stream)))) +(null (let ((*read-suppress* t)) + ;; http://www.lispworks.com/reference/HyperSpec/Body/v_rd_sup.htm + ;; If the value of *read-suppress* is true, read, + ;; read-preserving-whitespace, read-delimited-list, + ;; and read-from-string all return a primary value of nil + ;; when they complete successfully; + (with-input-from-string (stream "abc xyz)") + (read-delimited-list #\) stream)))) + +(flet ((num2str (n base) + (let* ((base-digits "0123456789ABCDEFGHIJKLMNOPQRSTUV") + (minus-p (< n 0)) + (n (if minus-p (- n) n)) + digits) + (loop with x = n + do (multiple-value-bind (q r) (floor x base) + (push (aref base-digits r) digits) + (setq x q) + (when (zerop q) (return)))) + (when minus-p (push #\- digits)) + (make-array (length digits) + :element-type 'character :initial-contents digits)))) + (loop for base from 2 upto 32 + always (loop for n from -100 upto 100 + always (= n (let ((*read-base* base)) + (read-from-string (num2str n base))))))) + +(labels ((int2str (n base) + (let* ((base-digits "0123456789ABCDEFGHIJKLMNOPQRSTUV") + (minus-p (< n 0)) + (n (if minus-p (- n) n)) + digits) + (loop with x = n + do (multiple-value-bind (q r) (floor x base) + (push (aref base-digits r) digits) + (setq x q) + (when (zerop q) (return)))) + (when minus-p (push #\- digits)) + (make-array (length digits) + :element-type 'character :initial-contents digits))) + (ratio2str (r base) + (concatenate 'string + (int2str (numerator r) base) + "/" + (int2str (denominator r) base)))) + (loop for base from 2 upto 32 + always (loop for numerator from -100 upto 100 by 23 + always (loop for denominator from 1 upto 300 by 51 + always (= (/ numerator denominator) + (let ((*read-base* base)) + (read-from-string + (ratio2str (/ numerator + denominator) + base)))))))) diff --git a/Sacla/tests/must-reader.patch b/Sacla/tests/must-reader.patch new file mode 100644 index 0000000..a2db10f --- /dev/null +++ b/Sacla/tests/must-reader.patch @@ -0,0 +1,26 @@ +*** sacla/lisp/test/must-reader.lisp 2004-08-03 08:34:55.000000000 +0200 +--- CLISP/clisp-20040712/sacla-tests/must-reader.lisp 2004-08-07 02:10:05.000000000 +0200 +*************** +*** 1828,1837 **** + + + (progn +! #-clisp + (handler-case (null (let ((*features* '())) (read-from-string "#+test1 a"))) + (error () nil)) +! #+clisp 'skipped) + + (let ((*features* '())) + (equal (with-input-from-string (stream "#+test1 a #-test1 b") +--- 1828,1838 ---- + + + (progn +! #-CLISP ; ANSI CL 2.2. refers to the spec of READ, which says that an error +! ; of type end-of-file is signalled. + (handler-case (null (let ((*features* '())) (read-from-string "#+test1 a"))) + (error () nil)) +! #+CLISP 'skipped) + + (let ((*features* '())) + (equal (with-input-from-string (stream "#+test1 a #-test1 b") diff --git a/Sacla/tests/must-sequence.lisp b/Sacla/tests/must-sequence.lisp new file mode 100644 index 0000000..6871d31 --- /dev/null +++ b/Sacla/tests/must-sequence.lisp @@ -0,0 +1,10165 @@ +;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp> +;; ALL RIGHTS RESERVED. +;; +;; $Id: must-sequence.lisp,v 1.31 2004/08/09 02:49:54 yuji Exp $ +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; * Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; * Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(eql (length "abc") 3) +(let ((str (make-array '(3) :element-type 'character + :initial-contents "abc" + :fill-pointer t))) + (and (eql (length str) 3) + (eql (setf (fill-pointer str) 2) 2) + (eql (length str) 2))) +(zerop (length #*)) +(zerop (length "")) +(zerop (length #())) +(zerop (length ())) +(eql (length '(0)) 1) +(eql (length '(0 1)) 2) +(eql (length '(0 1 2)) 3) +(eql (length '(0 1 2 3)) 4) +(eql (length '(0 1 2 3 4)) 5) +(eql (length '(0 1 2 3 4 5)) 6) +(eql (length '(0 1 2 3 4 5 6)) 7) +(eql (length #(0)) 1) +(eql (length #(0 1)) 2) +(eql (length #(0 1 2)) 3) +(eql (length #(0 1 2 3)) 4) +(eql (length #(0 1 2 3 4)) 5) +(eql (length #(0 1 2 3 4 5)) 6) +(eql (length #(0 1 2 3 4 5 6)) 7) +(eql (length (make-array 100)) 100) +(eql (length (make-sequence 'list 20)) 20) +(eql (length (make-sequence 'string 10)) 10) +(eql (length (make-sequence 'bit-vector 3)) 3) +(eql (length (make-sequence 'bit-vector 64)) 64) +(eql (length (make-sequence 'simple-vector 64)) 64) + + + +(string= (copy-seq "love") "love") +(equalp (copy-seq '#(a b c d)) '#(a b c d)) +(equalp (copy-seq '#*01010101) '#*01010101) +(equal (copy-seq '(love)) '(love)) +(equal (copy-seq '(love hate war peace)) '(love hate war peace)) +(null (copy-seq nil)) +(string= (copy-seq "") "") +(let* ((seq0 "love&peace") + (seq (copy-seq seq0))) + (and (not (eq seq0 seq)) + (string= seq0 seq))) +(let* ((seq0 (list 'love 'and 'peace)) + (seq (copy-seq seq0))) + (and (not (eq seq0 seq)) + (equal seq0 seq))) +(let* ((c0 (list 'love)) + (c1 (list 'peace)) + (seq (copy-seq (list c0 c1)))) + (and (equal seq '((love) (peace))) + (eq (car seq) c0) + (eq (cadr seq) c1))) +(let* ((seq0 '#(t nil t nil)) + (seq (copy-seq seq0))) + (and (not (eq seq0 seq)) + (equalp seq seq0))) +(vectorp (copy-seq (vector))) +(simple-bit-vector-p (copy-seq #*)) +(simple-vector-p (copy-seq (vector))) +(simple-vector-p (copy-seq (make-array 10 + :fill-pointer 3 + :initial-element nil))) +(simple-vector-p (copy-seq (vector 0 1))) +(simple-string-p (copy-seq "xyz")) +(simple-string-p (copy-seq (make-array 3 + :displaced-to "0123456789" + :displaced-index-offset 3 + :element-type 'base-char))) +(simple-string-p (copy-seq (make-array 20 + :fill-pointer t + :element-type 'base-char + :initial-element #\Space))) +(simple-bit-vector-p (copy-seq #*0101)) +(simple-bit-vector-p (copy-seq (make-array 30 + :fill-pointer 3 + :element-type 'bit + :initial-element 0))) +(let* ((vec0 (make-array 10 :fill-pointer 3 :initial-contents "0123456789")) + (vec (copy-seq vec0))) + (and (simple-vector-p vec) + (= (length vec) 3) + (equalp vec #(#\0 #\1 #\2)))) + + +(char= (elt "0123456789" 6) #\6) +(eq (elt #(a b c d e f g) 0) 'a) +(eq (elt '(a b c d e f g) 4) 'e) +(zerop (elt #*0101010 0)) + +(dotimes (i 10 t) + (unless (char= (elt "0123456789" i) (digit-char i)) + (return nil))) + +(let ((str (copy-seq "0123456789"))) + (and (char= (elt str 6) #\6) + (setf (elt str 0) #\#) + (string= str "#123456789"))) + +(let ((list (list 0 1 2 3))) + (and (= (elt list 2) 2) + (setf (elt list 1) 9) + (= (elt list 1) 9) + (equal list '(0 9 2 3)))) + +(let ((bv #*0101010101)) + (dotimes (i 10 t) + (unless (= (elt bv i) (if (evenp i) 0 1)) + (return nil)))) + +(let ((vec (vector 'a 'b 'c))) + (and (eq (elt vec 0) 'a) + (eq (elt vec 1) 'b) + (eq (elt vec 2) 'c))) + + +(let ((list (list 0 1 2 3))) + (and (eq (fill list 'nil) list) + (every 'null list))) + +(let ((vector (vector 'x 'y 'z))) + (and (eq (fill vector 'a) vector) + (every #'(lambda (arg) (eq arg 'a)) vector))) + +(let ((list (list 0 1 2 3))) + (and (eq (fill list '9 :start 2) list) + (equal list '(0 1 9 9)))) + +(let ((list (list 0 1 2 3))) + (and (eq (fill list '9 :start 1 :end 3) list) + (equal list '(0 9 9 3)))) + +(let ((list (list 0 1 2 3))) + (and (eq (fill list '9 :start 1 :end nil) list) + (equal list '(0 9 9 9)))) + +(let ((list (list 0 1 2 3))) + (and (eq (fill list '9 :end 1) list) + (equal list '(9 1 2 3)))) + +(let ((vector (vector 0 1 2 3))) + (and (eq (fill vector 't :start 3) vector) + (equalp vector '#(0 1 2 t)))) + +(let ((vector (vector 0 1 2 3))) + (and (eq (fill vector 't :start 2 :end 4) vector) + (equalp vector '#(0 1 t t)))) + +(let ((vector (vector 0 1 2 3))) + (and (eq (fill vector 't :start 2 :end nil) vector) + (equalp vector '#(0 1 t t)))) + +(let ((vector (vector 0 1 2 3))) + (and (eq (fill vector 't :end 3) vector) + (equalp vector '#(t t t 3)))) + + + +(null (make-sequence 'list 0)) +(string= (make-sequence 'string 26 :initial-element #\.) + "..........................") +(equalp (make-sequence '(vector double-float) 2 + :initial-element 1d0) + #(1.0d0 1.0d0)) + + +(equal (make-sequence 'list 3 :initial-element 'a) + '(a a a)) + +(equal (make-sequence 'cons 3 :initial-element 'a) + '(a a a)) + +(null (make-sequence 'null 0 :initial-element 'a)) + +(equalp (make-sequence 'vector 3 :initial-element 'z) + '#(z z z)) + +(equalp (make-sequence '(vector * *) 3 :initial-element 'z) + '#(z z z)) + +(equalp (make-sequence '(vector t *) 3 :initial-element 'z) + '#(z z z)) + +(string= (make-sequence '(string 3) 3 :initial-element '#\a) + "aaa") + +(string= (make-sequence 'string 4 :initial-element '#\z) + "zzzz") + +(string= (make-sequence '(vector character 3) 3 :initial-element '#\a) + "aaa") + +(equalp (make-sequence '(array t 1) 3 :initial-element 'z) + '#(z z z)) + +(equalp (make-sequence '(array t (3)) 3 :initial-element 'z) + '#(z z z)) + +(vectorp (make-sequence 'vector 10)) + + +(string= (subseq "012345" 2) "2345") +(string= (subseq "012345" 3 5) "34") +(let ((str (copy-seq "012345"))) + (and (setf (subseq str 4) "abc") + (string= str "0123ab"))) +(let ((str (copy-seq "012345"))) + (setf (subseq str 0 2) "A") + (string= str "A12345")) + +(equal (subseq '(0 1 2 3) 0) '(0 1 2 3)) +(equal (subseq '(0 1 2 3) 1) '(1 2 3)) +(equal (subseq '(0 1 2 3) 2) '(2 3)) +(equal (subseq '(0 1 2 3) 3) '(3)) +(equal (subseq '(0 1 2 3) 4) '()) +(equalp (subseq #(a b c d) 0) #(a b c d)) +(equalp (subseq #(a b c d) 1) #(b c d)) +(equalp (subseq #(a b c d) 2) #(c d)) +(equalp (subseq #(a b c d) 3) #(d)) +(equalp (subseq #(a b c d) 4) #()) +(string= (subseq "0123" 0) "0123") +(string= (subseq "0123" 1) "123") +(string= (subseq "0123" 2) "23") +(string= (subseq "0123" 3) "3") +(string= (subseq "0123" 4) "") +(equalp (subseq #*1010 0) #*1010) +(equalp (subseq #*1010 1) #*010) +(equalp (subseq #*1010 2) #*10) +(equalp (subseq #*1010 3) #*0) +(equalp (subseq #*1010 4) #*) + +(equal (subseq '(0 1 2 3) 0 4) '(0 1 2 3)) +(equal (subseq '(0 1 2 3) 0 nil) '(0 1 2 3)) +(let* ((list0 '(0 1 2 3)) + (list (subseq list0 0 4))) + (and (not (eq list0 list)) + (equal list0 list))) +(let* ((list0 '(0 1 2 3)) + (list (subseq list0 0 nil))) + (and (not (eq list0 list)) + (equal list0 list))) +(equal (subseq '(0 1 2 3) 1 3) '(1 2)) +(equal (subseq '(0 1 2 3) 2 2) '()) +(equal (subseq '(0 1 2 3) 0 0) '()) +(equal (subseq '(0 1 2 3) 1 1) '()) +(equal (subseq '(0 1 2 3) 2 2) '()) +(equal (subseq '(0 1 2 3) 3 3) '()) +(equal (subseq '(0 1 2 3) 4 4) '()) + +(let ((list (list 0 1 2 3 4 5 6 7))) + (setf (subseq list 0) '(a b c d)) + (equal list '(a b c d 4 5 6 7))) + +(let ((list (list 0 1 2 3))) + (setf (subseq list 0) '(a b c d)) + (equal list '(a b c d))) + +(let ((list (list 0 1 2 3))) + (setf (subseq list 2) '(a b c d)) + (equal list '(0 1 a b))) + +(let ((list (list 0 1 2 3))) + (setf (subseq list 2 nil) '(a b c d)) + (equal list '(0 1 a b))) + +(let ((list (list 0 1 2 3))) + (setf (subseq list 1 3) '(a b c d)) + (equal list '(0 a b 3))) + +(let ((list (list 0 1 2 3))) + (setf (subseq list 0) '()) + (equal list '(0 1 2 3))) + +(let ((list '())) + (setf (subseq list 0) '(a b c d e)) + (null list)) + +(let ((list '(0 1 2 3))) + (setf (subseq list 0 0) '(a b c d e)) + (equal list '(0 1 2 3))) + +(let ((list '(0 1 2 3))) + (setf (subseq list 1 1) '(a b c d e)) + (equal list '(0 1 2 3))) + +(let ((list '(0 1 2 3))) + (setf (subseq list 2 2) '(a b c d e)) + (equal list '(0 1 2 3))) + +(let ((list '(0 1 2 3))) + (setf (subseq list 3 3) '(a b c d e)) + (equal list '(0 1 2 3))) + +(let ((list '(0 1 2 3))) + (setf (subseq list 4 4) '(a b c d e)) + (equal list '(0 1 2 3))) + + + +(let ((list (list 0 1 2 3 4 5 6 7))) + (setf (subseq list 0) #(a b c d)) + (equal list '(a b c d 4 5 6 7))) + +(let ((list (list 0 1 2 3))) + (setf (subseq list 0) #(a b c d)) + (equal list '(a b c d))) + +(let ((list (list 0 1 2 3))) + (setf (subseq list 2) #(a b c d)) + (equal list '(0 1 a b))) + +(let ((list (list 0 1 2 3))) + (setf (subseq list 2 nil) #(a b c d)) + (equal list '(0 1 a b))) + +(let ((list (list 0 1 2 3))) + (setf (subseq list 1 3) #(a b c d)) + (equal list '(0 a b 3))) + +(let ((list (list 0 1 2 3))) + (setf (subseq list 0) #()) + (equal list '(0 1 2 3))) + +(let ((list (list 0 1 2 3 4 5 6 7))) + (setf (subseq list 0) "abcd") + (equal list '(#\a #\b #\c #\d 4 5 6 7))) + +(let ((list (list 0 1 2 3))) + (setf (subseq list 0) "abcd") + (equal list '(#\a #\b #\c #\d))) + +(let ((list (list 0 1 2 3))) + (setf (subseq list 2) "abcd") + (equal list '(0 1 #\a #\b))) + +(let ((list (list 0 1 2 3))) + (setf (subseq list 2 nil) "abcd") + (equal list '(0 1 #\a #\b))) + +(let ((list (list 0 1 2 3))) + (setf (subseq list 1 3) "abcd") + (equal list '(0 #\a #\b 3))) + +(let ((list (list 0 1 2 3))) + (setf (subseq list 0) "") + (equal list '(0 1 2 3))) + + +(equalp (subseq #(0 1 2 3) 0 4) #(0 1 2 3)) +(equalp (subseq #(0 1 2 3) 0 nil) #(0 1 2 3)) +(let* ((vec0 #(0 1 2 3)) + (vec (subseq vec0 0 4))) + (and (not (eq vec0 vec)) + (equalp vec0 vec))) +(let* ((vec0 #(0 1 2 3)) + (vec (subseq vec0 0 nil))) + (and (not (eq vec0 vec)) + (equalp vec0 vec))) +(equalp (subseq #(0 1 2 3) 1 3) #(1 2)) +(equalp (subseq #(0 1 2 3) 2 2) #()) +(equalp (subseq #(0 1 2 3) 0 0) #()) +(equalp (subseq #(0 1 2 3) 1 1) #()) +(equalp (subseq #(0 1 2 3) 2 2) #()) +(equalp (subseq #(0 1 2 3) 3 3) #()) +(equalp (subseq #(0 1 2 3) 4 4) #()) + +(let ((vec (vector 0 1 2 3 4 5 6 7))) + (setf (subseq vec 0) #(a b c d)) + (equalp vec #(a b c d 4 5 6 7))) + +(let ((vec (vector 0 1 2 3))) + (setf (subseq vec 0) #(a b c d)) + (equalp vec #(a b c d))) + +(let ((vec (vector 0 1 2 3))) + (setf (subseq vec 2) #(a b c d)) + (equalp vec #(0 1 a b))) + +(let ((vec (vector 0 1 2 3))) + (setf (subseq vec 1 3) #(a b c d)) + (equalp vec #(0 a b 3))) + +(let ((vec (vector 0 1 2 3))) + (setf (subseq vec 0) #()) + (equalp vec #(0 1 2 3))) + +(let ((vec (vector))) + (setf (subseq vec 0) #(a b c d e)) + (equalp vec #())) + +(let ((vec (vector 0 1 2 3))) + (setf (subseq vec 0 0) #(a b c d e)) + (equalp vec #(0 1 2 3))) + +(let ((vec (vector 0 1 2 3))) + (setf (subseq vec 1 1) #(a b c d e)) + (equalp vec #(0 1 2 3))) + +(let ((vec (vector 0 1 2 3))) + (setf (subseq vec 2 2) #(a b c d e)) + (equalp vec #(0 1 2 3))) + +(let ((vec (vector 0 1 2 3))) + (setf (subseq vec 3 3) #(a b c d e)) + (equalp vec #(0 1 2 3))) + +(let ((vec (vector 0 1 2 3))) + (setf (subseq vec 4 4) #(a b c d e)) + (equalp vec #(0 1 2 3))) + + +(let ((vec (vector 0 1 2 3 4 5 6 7))) + (setf (subseq vec 0) #(a b c d)) + (equalp vec #(a b c d 4 5 6 7))) + +(let ((vec (vector 0 1 2 3))) + (setf (subseq vec 0) #(a b c d)) + (equalp vec #(a b c d))) + +(let ((vec (vector 0 1 2 3))) + (setf (subseq vec 2) #(a b c d)) + (equalp vec #(0 1 a b))) + +(let ((vec (vector 0 1 2 3))) + (setf (subseq vec 2 nil) #(a b c d)) + (equalp vec #(0 1 a b))) + +(let ((vec (vector 0 1 2 3))) + (setf (subseq vec 1 3) #(a b c d)) + (equalp vec #(0 a b 3))) + +(let ((vec (vector 0 1 2 3))) + (setf (subseq vec 0) #()) + (equalp vec #(0 1 2 3))) + +(HANDLER-CASE (PROGN (MAP 'SYMBOL #'+ '(0 1) '(1 0))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (MAP 'HASH-TABLE #'+ '(0 1) '(1 0))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + + +(string= (map 'string #'(lambda (x y) + (char "01234567890ABCDEF" (mod (+ x y) 16))) + '(1 2 3 4) + '(10 9 8 7)) + "AAAA") + +(let ((seq (list "lower" "UPPER" "" "123"))) + (and (null (map nil #'nstring-upcase seq)) + (equal seq '("LOWER" "UPPER" "" "123")))) + +(equal (map 'list #'- '(1 2 3 4)) '(-1 -2 -3 -4)) + +(string= (map 'string + #'(lambda (x) (if (oddp x) #\1 #\0)) + '(1 2 3 4)) + "1010") + + + +(equal (map 'list '+ '(0 1) '(1 0)) '(1 1)) +(equal (map 'list '- '(0 1) '(1 0)) '(-1 1)) + +(every 'null (list (map 'list #'+ '()) + (map 'list #'+ '() '()) + (map 'list #'+ '() '() '()) + (map 'list #'+ '() '() '() '()) + (map 'list #'+ '() '() '() '() '()))) +(every 'null (list (map 'list #'+ '()) + (map 'list #'+ #() '()) + (map 'list #'+ '() #() '()) + (map 'list #'+ #() '() #() '()) + (map 'list #'+ '() #() '() #() '()))) + +(equal (map 'list #'+ '(0 1 2)) '(0 1 2)) +(equal (map 'list #'+ '(0 1 2) '(1 2 3)) '(1 3 5)) +(equal (map 'list #'+ '(0 1 2) '(1 2 3) '(2 3 4)) '(3 6 9)) +(equal (map 'list #'+ '(0 1 2) '(1 2 3) '(2 3 4) '(3 4 5)) '(6 10 14)) + +(equal (map 'list #'+ '(1 2) '(1 2 3)) '(2 4)) +(equal (map 'list #'+ '(0 1 2) '(2 3) '(2 3 4)) '(4 7)) +(equal (map 'list #'+ '(0 1 2) '(1 2 3) '(2) '(3 4 5)) '(6)) +(equal (map 'list #'+ '(0 1 2) '(1 2 3) '(2 3 4) '(3 4 5) '()) '()) + +(equal (map 'cons #'+ '(0 1 2) '(2 1 0)) '(2 2 2)) +(equal (map '(cons number cons) #'+ '(0 1 2) '(2 1 0)) '(2 2 2)) +(equal (map '(cons number (cons number *)) #'+ '(0 1 2) '(2 1 0)) '(2 2 2)) +(null (map 'null #'+ '())) + + +(equalp (map 'vector #'+ #()) #()) +(equalp (map 'vector #'+ #() #()) #()) +(equalp (map 'vector #'+ #() #() #()) #()) +(equalp (map 'vector #'+ #() #() #() #()) #()) +(equalp (map 'vector #'+ #() #() #() #() #()) #()) +(equalp (map 'vector #'+ '() #()) #()) +(equalp (map 'vector #'+ '() #() "") #()) + +(equalp (map 'vector #'+ '(0 1 2)) #(0 1 2)) +(equalp (map 'vector #'+ '(0 1 2) #(1 2 3)) #(1 3 5)) +(equalp (map 'vector #'+ #(0 1 2) '(1 2 3) #(2 3 4)) #(3 6 9)) +(equalp (map 'vector #'+ '(0 1 2) #(1 2 3) '(2 3 4) #(3 4 5)) #(6 10 14)) + +(equalp (map 'vector #'+ '(1 2) '(1 2 3)) #(2 4)) +(equalp (map 'vector #'+ '(0 1 2) '(2 3) '(2 3 4)) #(4 7)) +(equalp (map 'vector #'+ '(0 1 2) '(1 2 3) '(2) '(3 4 5)) #(6)) +(equalp (map 'vector #'+ '(0 1 2) '(1 2 3) '(2 3 4) '(3 4 5) '()) #()) + +(equalp (map 'vector #'+ #(1 2) #(1 2 3)) #(2 4)) +(equalp (map 'vector #'+ #(0 1 2) #(2 3) #(2 3 4)) #(4 7)) +(equalp (map 'vector #'+ #(0 1 2) '(1 2 3) #(2) '(3 4 5)) #(6)) +(equalp (map 'vector #'+ '(0 1 2) #(1 2 3) '(2 3 4) '(3 4 5) '()) #()) + +(string= (map 'string #'(lambda (&rest rest) (char-upcase (car rest))) "") "") +(string= (map 'string #'(lambda (&rest rest) (char-upcase (car rest))) "" "") + "") +(string= (map 'string + #'(lambda (&rest rest) (char-upcase (car rest))) + "" "" "") + "") +(string= (map 'string + #'(lambda (&rest rest) (char-upcase (car rest))) + "" "" "" "") + "") +(string= (map 'string + #'(lambda (&rest rest) (char-upcase (car rest))) + "" "" "" "" "") + "") + +(string= (map 'string #'(lambda (&rest rest) (char-upcase (car rest))) "") "") +(string= (map 'string #'(lambda (&rest rest) (char-upcase (car rest))) "" '()) + "") +(string= (map 'string #'(lambda (&rest rest) (char-upcase (car rest))) + "" #() '()) "") +(string= (map 'string #'(lambda (&rest rest) (char-upcase (car rest))) + '() '() "" "") "") +(string= (map 'string #'(lambda (&rest rest) (char-upcase (car rest))) + #() #() #() #() #()) "") + + +(string= (map 'string + #'(lambda (a b) (if (char< a b) b a)) + "axbycz" + "xaybzc") + "xxyyzz") + +(string= (map 'string + #'(lambda (a b) (if (char< a b) b a)) + "axbycz" + "xayb") + "xxyy") + +(string= (map 'string + #'(lambda (&rest rest) (if (zerop (apply #'logand rest)) #\0 #\1)) + '(0 1 0 1) + #*1010101) + "0000") + +(string= (map 'string + #'(lambda (&rest rest) (if (zerop (apply #'logand rest)) #\0 #\1)) + #*1111 + #*1010101 + #*001) + "001") + +(string= (map 'string + #'(lambda (&rest rest) (if (zerop (apply #'logand rest)) #\0 #\1)) + #*1111 + #*1010101 + #*0) + "0") + +(string= (map 'string + #'(lambda (&rest rest) (if (zerop (apply #'logand rest)) #\0 #\1)) + #*1111 + #*1000 + #*1011) + "1000") + + +(let ((list ())) + (and (null (map nil + #'(lambda (&rest rest) + (setq list (cons (apply #'+ rest) list))) + '(0 1 2 3) + '(1 2 3 4))) + (equal list '(7 5 3 1)))) + +(let ((list ())) + (and (null (map nil + #'(lambda (&rest rest) + (setq list (cons (apply #'+ rest) list))) + '(0 1 2 3) + '(1 2 3 4) + '(2 3 4 5))) + (equal list (reverse '(3 6 9 12))))) + +(let ((list ())) + (and (null (map nil + #'(lambda (&rest rest) + (setq list (cons (apply #'+ rest) list))) + '(0 1 2 3) + '(1) + '(2 3 4 5))) + (equal list '(3)))) + + + +(equalp (map '(vector * 2) #'+ #*01 #*10) #(1 1)) +(equalp (map '(simple-vector 2) #'+ #*01 #*10) #(1 1)) +(equalp (map '(array * 1) #'+ #*01 #*10) #(1 1)) +(equalp (map '(simple-array * 1) #'+ #*01 #*10) #(1 1)) +(equalp (map '(array * (2)) #'+ #*01 #*10) #(1 1)) +(equalp (map '(simple-array * (2)) #'+ #*01 #*10) #(1 1)) +(string= (map 'string #'char-upcase "abc") "ABC") +(string= (map 'base-string #'char-upcase "abc") "ABC") +(string= (map 'simple-string #'char-upcase "abc") "ABC") +(string= (map '(string 3) #'char-upcase "abc") "ABC") +(string= (map '(base-string 3) #'char-upcase "abc") "ABC") +(string= (map '(simple-string 3) #'char-upcase "abc") "ABC") +(string= (map '(vector character) #'char-upcase "abc") "ABC") +(string= (map '(vector character 3) #'char-upcase "abc") "ABC") +(string= (map '(vector base-char) #'char-upcase "abc") "ABC") +(string= (map '(vector base-char 3) #'char-upcase "abc") "ABC") +(string= (map '(vector standard-char) #'char-upcase "abc") "ABC") +(string= (map '(vector standard-char 3) #'char-upcase "abc") "ABC") +(string= (map '(array character 1) #'char-upcase "abc") "ABC") +(string= (map '(array character (3)) #'char-upcase "abc") "ABC") +(string= (map '(array base-char 1) #'char-upcase "abc") "ABC") +(string= (map '(array base-char (3)) #'char-upcase "abc") "ABC") +(string= (map '(array standard-char 1) #'char-upcase "abc") "ABC") +(string= (map '(array standard-char (3)) #'char-upcase "abc") "ABC") +(equalp (map 'bit-vector #'logand '(0 1 0 1) #*1010) #*0000) +(equalp (map 'simple-bit-vector #'logand '(0 1 0 1) #*1010) #*0000) +(equalp (map '(bit-vector 4) #'logand '(0 1 0 1) #*1010) #*0000) +(equalp (map '(simple-bit-vector 4) #'logand '(0 1 0 1) #*1010) #*0000) +(equalp (map '(array bit 1) #'logand '(0 1 0 1) #*1010) #*0000) +(equalp (map '(array bit (4)) #'logand '(0 1 0 1) #*1010) #*0000) +(equalp (map '(simple-array bit 1) #'logand '(0 1 0 1) #*1010) #*0000) +(equalp (map '(simple-array bit (4)) #'logand '(0 1 0 1) #*1010) #*0000) +(equalp (map '(vector bit) #'logand '(0 1 0 1) #*1010) #*0000) +(equalp (map '(vector bit 4) #'logand '(0 1 0 1) #*1010) #*0000) + +(equal (map 'list #'+ '(0 1 2 3) #(3 2 1 0) #*0101) '(3 4 3 4)) +(equalp (map 'vector #'+ '(0 1 2 3) #(3 2 1 0) #*0101) #(3 4 3 4)) + + + +(let ((a (list 1 2 3 4)) + (b (list 10 10 10 10))) + (and (equal (map-into a #'+ a b) '(11 12 13 14)) + (equal a '(11 12 13 14)) + (equal b '(10 10 10 10)))) +(let ((a '(11 12 13 14)) + (k '(one two three))) + (equal (map-into a #'cons k a) '((ONE . 11) (TWO . 12) (THREE . 13) 14))) + + +(null (map-into nil 'identity)) +(null (map-into nil #'identity)) +(null (map-into nil #'identity '())) +(null (map-into nil #'identity '(0 1 2) '(9 8 7))) + + +(let ((list (list 0 1 2))) + (and (eq (map-into list 'identity) list) + (equal list '(0 1 2)))) +(let ((list (list 0 1 2))) + (and (eq (map-into list 'identity '()) list) + (equal list '(0 1 2)))) + +(let ((vec (vector 0 1 2))) + (and (eq (map-into vec 'identity) vec) + (equalp vec #(0 1 2)))) +(let ((vec (vector 0 1 2))) + (and (eq (map-into vec 'identity #()) vec) + (equalp vec #(0 1 2)))) +(let ((vec (vector 0 1 2))) + (and (eq (map-into vec #'+ #() '() #()) vec) + (equalp vec #(0 1 2)))) + + +(equal (map-into (list nil nil) '+ '(0 1) '(1 0)) '(1 1)) +(equal (map-into (list nil nil) '- '(0 1) '(1 0)) '(-1 1)) +(let ((list (make-list 3 :initial-element nil))) + (and (eq (map-into list #'+ '(0 1 2)) list) + (equal list '(0 1 2)))) +(let ((list (make-list 3 :initial-element nil))) + (and (eq (map-into list #'+ '(0 1 2) '(1 2 3)) list) + (equal list '(1 3 5)))) +(let ((list (make-list 3 :initial-element nil))) + (and (eq (map-into list #'+ '(0 1 2) '(1 2 3) '(2 3 4)) list) + (equal list '(3 6 9)))) + +(let ((list (make-list 3 :initial-element nil))) + (and (eq (map-into list #'+ '(1 2) '(1 2 3)) list) + (equal list '(2 4 nil)))) +(let ((list (make-list 1 :initial-element nil))) + (and (eq (map-into list #'+ '(1 2 3) '(1 2 3)) list) + (equal list '(2)))) +(let ((list (make-list 3 :initial-element nil))) + (and (eq (map-into list #'+ '(1 2 3 4) '(1 2 3) '(0)) list) + (equal list '(2 nil nil)))) + + +(let ((vec (make-sequence 'vector 3 :initial-element nil))) + (and (eq (map-into vec #'+ '(0 1 2)) vec) + (equalp vec #(0 1 2)))) +(let ((vec (make-sequence 'vector 3 :initial-element nil))) + (and (eq (map-into vec #'+ '(0 1 2) #(1 2 3)) vec) + (equalp vec #(1 3 5)))) +(let ((vec (make-sequence 'vector 3 :initial-element nil))) + (and (eq (map-into vec #'+ '(0 1 2) '(1 2 3) #(2 3 4)) vec) + (equalp vec #(3 6 9)))) + +(let ((vec (make-sequence 'vector 3 :initial-element nil))) + (and (eq (map-into vec #'+ '(1 2) #(1 2 3)) vec) + (equalp vec #(2 4 nil)))) +(let ((vec (make-sequence 'vector 1 :initial-element nil))) + (and (eq (map-into vec #'+ '(1 2) #(1 2 3)) vec) + (equalp vec #(2)))) +(let ((vec (make-sequence 'vector 3 :initial-element nil))) + (and (eq (map-into vec #'+ '(1 2 3 4) #(1 2 3) '(0)) vec) + (equalp vec #(2 nil nil)))) + + +(let ((str (make-array 10 + :element-type 'character + :initial-contents "0123456789" + :fill-pointer 3))) + (and (eq (map-into str #'char-upcase "abcde") str) + (string= str "ABCDE") + (= (fill-pointer str) 5))) + +(let ((vec (make-array 5 + :initial-contents #(0 1 2 3 4) + :fill-pointer 3))) + (and (eq (map-into vec #'+ '(0 1 2 3 4 5 6 7 8 9) '(9 8 7 6 5 4 3 2 1 0)) vec) + (equalp vec #(9 9 9 9 9)))) + +(let ((vec (make-array 5 + :initial-contents #(0 1 2 3 4) + :fill-pointer 3))) + (and (eq (map-into vec #'+ '(0 1) '(9 8 7 6 5 4 3 2 1 0)) vec) + (equalp vec #(9 9)))) + + +(let ((vec (make-array 5 + :element-type 'bit + :initial-contents #(1 1 1 1 1) + :fill-pointer 3))) + (and (eq (map-into vec #'logand '(0 1) '(1 0 1 0 1 0)) vec) + (equalp vec #*00))) + + +(eql (reduce #'* '(1 2 3 4 5)) 120) +(equal (reduce #'append '((1) (2)) :initial-value '(i n i t)) '(I N I T 1 2)) +(equal (reduce #'append '((1) (2)) + :from-end t + :initial-value '(i n i t)) + '(1 2 I N I T)) +(eql (reduce #'- '(1 2 3 4)) -8) +(eql (reduce #'- '(1 2 3 4) :from-end t) -2) +(eql (reduce #'+ '()) 0) +(eql (reduce #'+ '(3)) 3) +(eq (reduce #'+ '(foo)) 'foo) +(equal (reduce #'list '(1 2 3 4)) '(((1 2) 3) 4)) +(equal (reduce #'list '(1 2 3 4) :from-end t) '(1 (2 (3 4)))) +(equal (reduce #'list '(1 2 3 4) :initial-value 'foo) '((((foo 1) 2) 3) 4)) +(equal (reduce #'list '(1 2 3 4) :from-end t :initial-value 'foo) + '(1 (2 (3 (4 foo))))) + + +(equal (reduce #'list '(0 1 2 3)) '(((0 1) 2) 3)) +(equal (reduce #'list '(0 1 2 3) :start 1) '((1 2) 3)) +(equal (reduce #'list '(0 1 2 3) :start 1 :end nil) '((1 2) 3)) +(equal (reduce #'list '(0 1 2 3) :start 2) '(2 3)) +(eq (reduce #'list '(0 1 2 3) :start 0 :end 0) '()) +(eq (reduce #'list '(0 1 2 3) :start 0 :end 0 :initial-value 'initial-value) + 'initial-value) +(eq (reduce #'list '(0 1 2 3) :start 2 :end 2) '()) +(eq (reduce #'list '(0 1 2 3) :start 2 :end 2 :initial-value 'initial-value) + 'initial-value) +(eq (reduce #'list '(0 1 2 3) :start 4 :end 4) '()) +(eq (reduce #'list '(0 1 2 3) :start 4 :end 4 :initial-value 'initial-value) + 'initial-value) +(eql (reduce #'list '(0 1 2 3) :start 2 :end 3) 2) +(equal (reduce #'list '(0 1 2 3) :start 2 :end 3 :initial-value 'initial-value) + '(initial-value 2)) +(eql (reduce #'+ '(0 1 2 3 4 5 6 7 8 9)) 45) +(eql (reduce #'- '(0 1 2 3 4 5 6 7 8 9)) -45) +(eql (reduce #'- '(0 1 2 3 4 5 6 7 8 9) :from-end t) -5) +(equal (reduce #'list '(0 1 2 3) :initial-value 'initial-value) + '((((initial-value 0) 1) 2) 3)) +(equal (reduce #'list '(0 1 2 3) :from-end t) '(0 (1 (2 3)))) +(equal (reduce #'list '((1) (2) (3) (4)) :key #'car) '(((1 2) 3) 4)) +(equal (reduce #'list '((1) (2) (3) (4)) :key #'car :from-end nil) + '(((1 2) 3) 4)) +(equal (reduce #'list '((1) (2) (3) (4)) :key #'car :initial-value 0) + '((((0 1) 2) 3) 4)) +(equal (reduce #'list '((1) (2) (3) (4)) :key #'car :from-end t) + '(1 (2 (3 4)))) +(equal (reduce #'list '((1) (2) (3) (4)) + :key #'car :from-end t :initial-value 5) + '(1 (2 (3 (4 5))))) + + + + +(equal (reduce #'list #(0 1 2 3)) '(((0 1) 2) 3)) +(equal (reduce #'list #(0 1 2 3) :start 1) '((1 2) 3)) +(equal (reduce #'list #(0 1 2 3) :start 1 :end nil) '((1 2) 3)) +(equal (reduce #'list #(0 1 2 3) :start 2) '(2 3)) +(eq (reduce #'list #(0 1 2 3) :start 0 :end 0) '()) +(eq (reduce #'list #(0 1 2 3) :start 0 :end 0 :initial-value 'initial-value) + 'initial-value) +(eq (reduce #'list #(0 1 2 3) :start 2 :end 2) '()) +(eq (reduce #'list #(0 1 2 3) :start 2 :end 2 :initial-value 'initial-value) + 'initial-value) +(eq (reduce #'list #(0 1 2 3) :start 4 :end 4) '()) +(eq (reduce #'list #(0 1 2 3) :start 4 :end 4 :initial-value 'initial-value) + 'initial-value) +(eql (reduce #'list #(0 1 2 3) :start 2 :end 3) 2) +(equal (reduce #'list #(0 1 2 3) :start 2 :end 3 :initial-value 'initial-value) + '(initial-value 2)) +(eql (reduce #'+ #(0 1 2 3 4 5 6 7 8 9)) 45) +(eql (reduce #'- #(0 1 2 3 4 5 6 7 8 9)) -45) +(eql (reduce #'- #(0 1 2 3 4 5 6 7 8 9) :from-end t) -5) +(equal (reduce #'list #(0 1 2 3) :initial-value 'initial-value) + '((((initial-value 0) 1) 2) 3)) +(equal (reduce #'list #(0 1 2 3) :from-end t) '(0 (1 (2 3)))) +(equal (reduce #'list #((1) (2) (3) (4)) :key #'car) '(((1 2) 3) 4)) +(equal (reduce #'list #((1) (2) (3) (4)) :key #'car :from-end nil) + '(((1 2) 3) 4)) +(equal (reduce #'list #((1) (2) (3) (4)) :key #'car :initial-value 0) + '((((0 1) 2) 3) 4)) +(equal (reduce #'list #((1) (2) (3) (4)) :key #'car :from-end t) + '(1 (2 (3 4)))) +(equal (reduce #'list #((1) (2) (3) (4)) + :key #'car :from-end t :initial-value 5) + '(1 (2 (3 (4 5))))) + +(string= (reduce #'(lambda (&rest rest) + (concatenate 'string + (string (car rest)) + (string (char-upcase (cadr rest))))) + "abcdefg" + :initial-value #\Z) + "ZABCDEFG") + + +(eql (count #\a "how many A's are there in here?") 2) +(eql (count-if-not #'oddp '((1) (2) (3) (4)) :key #'car) 2) +(eql (count-if #'upper-case-p "The Crying of Lot 49" :start 4) 2) +(eql (count #\a (concatenate 'list "how many A's are there in here?")) 2) +(eql (count-if #'alpha-char-p "-a-b-c-0-1-2-3-4-") 3) +(eql (count-if #'alphanumericp "-a-b-c-0-1-2-3-4-") 8) + +(eql (count 'nil '(t nil t nil t nil)) 3) +(eql (count 'nil #(t nil t nil t nil)) 3) +(zerop (count 9 '(0 1 2 3 4))) +(zerop (count 'a '(0 1 2 3 4))) +(eql (count 0 '(0 0 0 0 0) :start 1) 4) +(eql (count 0 '(0 0 0 0 0) :start 1 :end nil) 4) +(eql (count 0 '(0 0 0 0 0) :start 2) 3) +(zerop (count 0 '(0 0 0 0) :start 0 :end 0)) +(zerop (count 0 '(0 0 0 0) :start 2 :end 2)) +(zerop (count 0 '(0 0 0 0) :start 4 :end 4)) +(eql (count 0 '(0 0 0 0) :start 2 :end 3) 1) +(eql (count #\a "abcABC" :test #'equalp) 2) +(eql (count #\a "abcABC" :test #'char-equal) 2) +(eql (count '(a) '((x) (y) (z) (a) (b) (c)) :test #'equalp) 1) +(eql (count #\a "abcABC" :test-not (complement #'equalp)) 2) +(eql (count #\a "abcABC" :test-not (complement #'char-equal)) 2) +(eql (count '(a) '((x) (y) (z) (a) (b) (c)) :test-not (complement #'equalp)) 1) +(eql (count 'a '((x) (y) (z) (a) (b) (c)) :key #'car :test #'eq) 1) +(eql (count 'nil '((x . x) (y) (z . z) (a) (b . b) (c)) :key #'cdr :test #'eq) + 3) +(let ((list nil)) + (and (eql (count 'a '(a b c d) + :test #'(lambda (a b) (setq list (cons b list)) (eq a b))) + 1) + (equal list '(d c b a)))) + +(let ((list nil)) + (and (eql (count 'a '(a b c d) + :test #'(lambda (a b) (setq list (cons b list)) (eq a b)) + :from-end t) + 1) + (equal list '(a b c d)))) + + +(zerop (count 9 #(0 1 2 3 4))) +(zerop (count 'a #(0 1 2 3 4))) +(eql (count 0 #(0 0 0 0 0) :start 1) 4) +(eql (count 0 #(0 0 0 0 0) :start 1 :end nil) 4) +(eql (count 0 #(0 0 0 0 0) :start 2) 3) +(zerop (count 0 #(0 0 0 0) :start 0 :end 0)) +(zerop (count 0 #(0 0 0 0) :start 2 :end 2)) +(zerop (count 0 #(0 0 0 0) :start 4 :end 4)) +(eql (count 0 #(0 0 0 0) :start 2 :end 3) 1) +(eql (count '(a) #((x) (y) (z) (a) (b) (c)) :test #'equalp) 1) +(eql (count '(a) #((x) (y) (z) (a) (b) (c)) :test-not (complement #'equalp)) 1) +(eql (count 'a #((x) (y) (z) (a) (b) (c)) :key #'car :test #'eq) 1) +(eql (count 'nil #((x . x) (y) (z . z) (a) (b . b) (c)) :key #'cdr :test #'eq) + 3) +(let ((list nil)) + (and (eql (count 'a #(a b c d) + :test #'(lambda (a b) (setq list (cons b list)) (eq a b))) + 1) + (equal list '(d c b a)))) + +(let ((list nil)) + (and (eql (count 'a #(a b c d) + :test #'(lambda (a b) (setq list (cons b list)) (eq a b)) + :from-end t) + 1) + (equal list '(a b c d)))) + + +(eql (count-if #'null '(t nil t nil t nil)) 3) +(zerop (count-if #'(lambda (x) (eql x 9)) #(0 1 2 3 4))) +(zerop (count-if #'(lambda (a) (eq 'x a)) #(0 1 2 3 4))) +(eql (count-if #'zerop '(0 0 0 0 0) :start 1) 4) +(eql (count-if #'zerop '(0 0 0 0 0) :start 1 :end nil) 4) +(eql (count-if #'zerop '(0 0 0 0 0) :start 2) 3) +(zerop (count-if #'zerop '(0 0 0 0) :start 0 :end 0)) +(zerop (count-if #'zerop '(0 0 0 0) :start 2 :end 2)) +(zerop (count-if #'zerop '(0 0 0 0) :start 4 :end 4)) +(eql (count-if #'zerop '(0 0 0 0) :start 2 :end 3) 1) +(eql (count-if #'(lambda (x) (equalp #\a x)) "abcABC") 2) +(eql (count-if #'(lambda (x) (char-equal #\a x)) "abcABC") 2) +(eql (count-if #'(lambda (x) (equal x '(a))) + '((x) (y) (z) (a) (b) (c))) 1) +(eql (count-if #'(lambda (x) (eq x 'a)) + '((x) (y) (z) (a) (b) (c)) :key #'car) + 1) +(eql (count-if 'null '((x . x) (y) (z . z) (a) (b . b) (c)) :key #'cdr) + 3) +(eql (count-if #'(lambda (x) (equal x '(a))) + '((x) (y) (z) (a) (b) (c))) + 1) +(eql (count-if #'(lambda (x) (eq x 'a)) '((x) (y) (z) (a) (b) (c)) :key #'car) + 1) +(eql (count-if #'null '((x . x) (y) (z . z) (a) (b . b) (c)) :key #'cdr) + 3) +(let ((list nil)) + (and (eql (count-if #'(lambda (x) (setq list (cons x list)) (eq x 'a)) + '(a b c d)) + 1) + (equal list '(d c b a)))) +(let ((list nil)) + (and (eql (count-if #'(lambda (x) (setq list (cons x list)) (eq x 'a)) + '(a b c d) + :from-end t) + 1) + (equal list '(a b c d)))) +(eql (count-if #'null #(t nil t nil t nil)) 3) +(eql (count-if #'zerop #(0 0 0 0 0) :start 1) 4) +(eql (count-if #'zerop #(0 0 0 0 0) :start 1 :end nil) 4) +(eql (count-if #'zerop #(0 0 0 0 0) :start 2) 3) +(zerop (count-if #'zerop #(0 0 0 0) :start 0 :end 0)) +(zerop (count-if #'zerop #(0 0 0 0) :start 2 :end 2)) +(zerop (count-if #'zerop #(0 0 0 0) :start 4 :end 4)) +(eql (count-if #'zerop #(0 0 0 0) :start 2 :end 3) 1) +(eql (count-if #'(lambda (x) (equal x '(a))) + #((x) (y) (z) (a) (b) (c))) 1) +(eql (count-if #'(lambda (x) (eq x 'a)) + #((x) (y) (z) (a) (b) (c)) :key #'car) + 1) +(eql (count-if #'null #((x . x) (y) (z . z) (a) (b . b) (c)) :key #'cdr) + 3) +(eql (count-if #'(lambda (x) (equal x '(a))) + #((x) (y) (z) (a) (b) (c))) + 1) +(eql (count-if #'(lambda (x) (eq x 'a)) #((x) (y) (z) (a) (b) (c)) :key #'car) + 1) +(eql (count-if #'null #((x . x) (y) (z . z) (a) (b . b) (c)) :key #'cdr) + 3) +(let ((list nil)) + (and (eql (count-if #'(lambda (x) (setq list (cons x list)) (eq x 'a)) + #(a b c d)) + 1) + (equal list '(d c b a)))) +(let ((list nil)) + (and (eql (count-if #'(lambda (x) (setq list (cons x list)) (eq x 'a)) + #(a b c d) + :from-end t) + 1) + (equal list '(a b c d)))) + + + +(eql (count-if-not (complement #'null) '(t nil t nil t nil)) 3) +(zerop (count-if-not #'(lambda (x) (not (eql x 9))) #(0 1 2 3 4))) +(zerop (count-if-not #'(lambda (a) (not (eq 'x a))) #(0 1 2 3 4))) +(eql (count-if-not (complement #'zerop) '(0 0 0 0 0) :start 1) 4) +(eql (count-if-not (complement #'zerop) '(0 0 0 0 0) :start 1 :end nil) 4) +(eql (count-if-not (complement #'zerop) '(0 0 0 0 0) :start 2) 3) +(zerop (count-if-not (complement #'zerop) '(0 0 0 0) :start 0 :end 0)) +(zerop (count-if-not (complement #'zerop) '(0 0 0 0) :start 2 :end 2)) +(zerop (count-if-not (complement #'zerop) '(0 0 0 0) :start 4 :end 4)) +(eql (count-if-not (complement #'zerop) '(0 0 0 0) :start 2 :end 3) 1) +(eql (count-if-not #'(lambda (x) (not (equalp #\a x))) "abcABC") 2) +(eql (count-if-not #'(lambda (x) (not (char-equal #\a x))) "abcABC") 2) +(eql (count-if-not #'(lambda (x) (not (equal x '(a)))) + '((x) (y) (z) (a) (b) (c))) 1) +(eql (count-if-not #'(lambda (x) (not (eq x 'a))) + '((x) (y) (z) (a) (b) (c)) :key #'car) + 1) +(eql (count-if-not (complement #'null) + '((x . x) (y) (z . z) (a) (b . b) (c)) :key #'cdr) + 3) +(eql (count-if-not #'(lambda (x) (not (equal x '(a)))) + '((x) (y) (z) (a) (b) (c))) + 1) +(eql (count-if-not #'(lambda (x) (not (eq x 'a))) + '((x) (y) (z) (a) (b) (c)) :key #'car) + 1) +(eql (count-if-not (complement #'null) + '((x . x) (y) (z . z) (a) (b . b) (c)) :key #'cdr) + 3) +(let ((list nil)) + (and (eql (count-if-not #'(lambda (x) + (setq list (cons x list)) + (not (eq x 'a))) + '(a b c d)) + 1) + (equal list '(d c b a)))) +(let ((list nil)) + (and (eql (count-if-not #'(lambda (x) + (setq list (cons x list)) + (not (eq x 'a))) + '(a b c d) + :from-end t) + 1) + (equal list '(a b c d)))) +(eql (count-if-not (complement #'null) #(t nil t nil t nil)) 3) +(eql (count-if-not (complement #'zerop) #(0 0 0 0 0) :start 1) 4) +(eql (count-if-not (complement #'zerop) #(0 0 0 0 0) :start 1 :end nil) 4) +(eql (count-if-not (complement #'zerop) #(0 0 0 0 0) :start 2) 3) +(zerop (count-if-not (complement #'zerop) #(0 0 0 0) :start 0 :end 0)) +(zerop (count-if-not (complement #'zerop) #(0 0 0 0) :start 2 :end 2)) +(zerop (count-if-not (complement #'zerop) #(0 0 0 0) :start 4 :end 4)) +(eql (count-if-not (complement #'zerop) #(0 0 0 0) :start 2 :end 3) 1) +(eql (count-if-not #'(lambda (x) (not (equal x '(a)))) + #((x) (y) (z) (a) (b) (c))) 1) +(eql (count-if-not #'(lambda (x) (not (eq x 'a))) + #((x) (y) (z) (a) (b) (c)) :key #'car) + 1) +(eql (count-if-not (complement #'null) + #((x . x) (y) (z . z) (a) (b . b) (c)) :key #'cdr) + 3) +(eql (count-if-not #'(lambda (x) (not (equal x '(a)))) + #((x) (y) (z) (a) (b) (c))) + 1) +(eql (count-if-not #'(lambda (x) (not (eq x 'a))) + #((x) (y) (z) (a) (b) (c)) :key #'car) + 1) +(eql (count-if-not (complement #'null) + #((x . x) (y) (z . z) (a) (b . b) (c)) :key #'cdr) + 3) +(let ((list nil)) + (and (eql (count-if-not #'(lambda (x) + (setq list (cons x list)) + (not (eq x 'a))) + #(a b c d)) + 1) + (equal list '(d c b a)))) +(let ((list nil)) + (and (eql (count-if-not #'(lambda (x) + (setq list (cons x list)) + (not (eq x 'a))) + #(a b c d) + :from-end t) + 1) + (equal list '(a b c d)))) + + +(null (reverse nil)) +(string= (reverse "") "") +(equalp (reverse #*) #*) +(equalp (reverse #()) #()) +(equal (reverse '(0 1 2 3)) '(3 2 1 0)) +(string= (reverse "0123") "3210") +(equalp (reverse #*1100) #*0011) +(equalp (reverse #(a b c d)) #(d c b a)) + +(null (nreverse nil)) +(string= (nreverse (copy-seq "")) "") +(equalp (nreverse (copy-seq #*)) #*) +(equalp (nreverse (copy-seq #())) #()) +(equal (nreverse (list 0 1 2 3)) '(3 2 1 0)) +(string= (nreverse (copy-seq "0123")) "3210") +(equalp (reverse (copy-seq #*1100)) #*0011) +(equalp (reverse (copy-seq #(a b c d))) #(d c b a)) + + + +(char= (find #\d "edcba" :test #'char>) #\c) +(eql (find-if #'oddp '(1 2 3 4 5) :end 3 :from-end t) 3) +(null (find-if-not #'complexp + '#(3.5 2 #C(1.0 0.0) #C(0.0 1.0)) + :start 2)) + + +(eq (find 'a '(a b c)) 'a) +(eq (find 'b '(a b c)) 'b) +(eq (find 'c '(a b c)) 'c) +(null (find 'x '(a b c))) +(null (find 'a '(a b c) :start 1)) +(null (find 'b '(a b c) :start 2)) +(null (find 'c '(a b c) :start 3)) +(null (find 'a '(a b c) :start 0 :end 0)) +(null (find 'a '(a b c) :start 0 :end 0 :from-end t)) +(null (find 'a '(a b c) :start 1 :end 1)) +(null (find 'a '(a b c) :start 1 :end 1 :from-end t)) +(null (find 'a '(a b c) :start 2 :end 2)) +(null (find 'a '(a b c) :start 2 :end 2 :from-end t)) +(null (find 'a '(a b c) :start 3 :end 3)) +(null (find 'a '(a b c) :start 3 :end 3 :from-end t)) +(eq (find 'a '(a b c) :end nil) 'a) +(eq (find 'b '(a b c) :end nil) 'b) +(eq (find 'c '(a b c) :end nil) 'c) +(eq (find 'a '(a b c) :end 1) 'a) +(eq (find 'b '(a b c) :end 2) 'b) +(eq (find 'c '(a b c) :end 3) 'c) +(null (find 'a '(a b c) :end 0)) +(null (find 'b '(a b c) :end 1)) +(null (find 'c '(a b c) :end 2)) + +(null (find 'a '((a) (b) (c)))) +(equal (find 'a '((a) (b) (c)) :key #'car) '(a)) +(equal (find 'b '((a) (b) (c)) :key #'car) '(b)) +(equal (find 'c '((a) (b) (c)) :key #'car) '(c)) +(null (find 'z '((a) (b) (c)) :key #'car)) +(let ((list '((a) (b) (c)))) + (and (eq (find 'a list :key #'car) (car list)) + (eq (find 'b list :key #'car) (cadr list)) + (eq (find 'c list :key #'car) (caddr list)) + (null (find 'z list :key #'car)))) +(null (find '(a) '((a) (b) (c)))) +(equal (find '(a) '((a) (b) (c)) :test #'equal) '(a)) +(null (find '("a") '(("a") ("b") ("c")))) +(null (find '("a") '(("A") ("B") ("c")) :test #'equal)) +(equal (find '("a") '(("A") ("B") ("c")) :test #'equalp) '("A")) +(eq (find 'nil '(first second third) :test (constantly t)) 'first) +(eql (find 3 '(0 1 2 3 4 5)) 3) +(eql (find 3 '(0 1 2 3 4 5) :test #'<) 4) +(eql (find 3 '(0 1 2 3 4 5) :test #'>) 0) + +(equal (find '(a) '((a) (b) (c)) :test-not (complement #'equal)) '(a)) +(null (find '("a") '(("A") ("B") ("c")) :test-not (complement #'equal))) +(equal (find '("a") '(("A") ("B") ("c")) :test-not (complement #'equalp)) + '("A")) +(eq (find 'nil '(first second third) :test-not (constantly nil)) 'first) +(eql (find 3 '(0 1 2 3 4 5) :test-not #'>=) 4) +(eql (find 3 '(0 1 2 3 4 5) :test-not #'<=) 0) + +(equal (find 'a '((a) (b) (c) (a a) (b b) (c c)) :key #'car) + '(a)) +(equal (find 'a '((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t) + '(a a)) +(equal (find 'b '((a) (b) (c) (a a) (b b) (c c)) :key #'car) + '(b)) +(equal (find 'b '((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t) + '(b b)) +(equal (find 'c '((a) (b) (c) (a a) (b b) (c c)) :key #'car) + '(c)) +(equal (find 'c '((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t) + '(c c)) +(null (find 'z '((a) (b) (c) (a a) (b b) (c c)) :key #'car)) +(null (find 'z '((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t)) + +(equal (find 'a '((a) (b) (c) (a a) (b b) (c c) (a a a)) + :key #'car + :from-end t) + '(a a a)) +(equal (find 'a '((a) (b) (c) (a a) (b b) (c c) (a a a)) + :key #'car + :from-end t + :end nil) + '(a a a)) +(equal (find 'a '((a) (b) (c) (a a) (b b) (c c) (a a a)) + :key #'car + :from-end t + :end 6) + '(a a)) +(null (find 'a '((a) (b) (c) (a a) (b b) (c c) (a a a)) + :key #'car + :from-end t + :start 1 + :end 3)) +(null (find #\c '("abc" "bcd" "cde"))) +(string= (find #\c '("abc" "bcd" "cde") + :key #'(lambda (arg) (char arg 0)) + :test #'char=) + "cde") +(string= (find #\c '("abc" "bcd" "cde") + :key #'(lambda (arg) (char arg 0)) + :test #'char>) + "abc") +(string= (find #\c '("abc" "bcd" "cde") + :start 1 + :key #'(lambda (arg) (char arg 0)) + :test #'char>) + "bcd") + + +(eq (find 'a #(a b c)) 'a) +(eq (find 'b #(a b c)) 'b) +(eq (find 'c #(a b c)) 'c) +(null (find 'x #(a b c))) +(null (find 'a #(a b c) :start 1)) +(null (find 'b #(a b c) :start 2)) +(null (find 'c #(a b c) :start 3)) +(null (find 'a #(a b c) :start 0 :end 0)) +(null (find 'a #(a b c) :start 0 :end 0 :from-end t)) +(null (find 'a #(a b c) :start 1 :end 1)) +(null (find 'a #(a b c) :start 1 :end 1 :from-end t)) +(null (find 'a #(a b c) :start 2 :end 2)) +(null (find 'a #(a b c) :start 2 :end 2 :from-end t)) +(null (find 'a #(a b c) :start 3 :end 3)) +(null (find 'a #(a b c) :start 3 :end 3 :from-end t)) +(eq (find 'a #(a b c) :end nil) 'a) +(eq (find 'b #(a b c) :end nil) 'b) +(eq (find 'c #(a b c) :end nil) 'c) +(eq (find 'a #(a b c) :end 1) 'a) +(eq (find 'b #(a b c) :end 2) 'b) +(eq (find 'c #(a b c) :end 3) 'c) +(null (find 'a #(a b c) :end 0)) +(null (find 'b #(a b c) :end 1)) +(null (find 'c #(a b c) :end 2)) +(null (find 'a #((a) (b) (c)))) +(equal (find 'a #((a) (b) (c)) :key #'car) '(a)) +(equal (find 'b #((a) (b) (c)) :key #'car) '(b)) +(equal (find 'c #((a) (b) (c)) :key #'car) '(c)) +(null (find 'z #((a) (b) (c)) :key #'car)) +(let ((vector #((a) (b) (c)))) + (and (eq (find 'a vector :key #'car) (aref vector 0)) + (eq (find 'b vector :key #'car) (aref vector 1)) + (eq (find 'c vector :key #'car) (aref vector 2)) + (null (find 'z vector :key #'car)))) +(null (find '(a) #((a) (b) (c)))) +(equal (find '(a) #((a) (b) (c)) :test #'equal) '(a)) +(null (find '("a") #(("a") ("b") ("c")))) +(null (find '("a") #(("A") ("B") ("c")) :test #'equal)) +(equal (find '("a") #(("A") ("B") ("c")) :test #'equalp) '("A")) +(eq (find 'nil #(first second third) :test (constantly t)) 'first) +(eql (find 3 #(0 1 2 3 4 5)) 3) +(eql (find 3 #(0 1 2 3 4 5) :test #'<) 4) +(eql (find 3 #(0 1 2 3 4 5) :test #'>) 0) +(equal (find '(a) #((a) (b) (c)) :test-not (complement #'equal)) '(a)) +(null (find '("a") #(("A") ("B") ("c")) :test-not (complement #'equal))) +(equal (find '("a") #(("A") ("B") ("c")) :test-not (complement #'equalp)) + '("A")) +(eq (find 'nil #(first second third) :test-not (constantly nil)) 'first) +(eql (find 3 #(0 1 2 3 4 5) :test-not #'>=) 4) +(eql (find 3 #(0 1 2 3 4 5) :test-not #'<=) 0) +(equal (find 'a #((a) (b) (c) (a a) (b b) (c c)) :key #'car) + '(a)) +(equal (find 'a #((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t) + '(a a)) +(equal (find 'b #((a) (b) (c) (a a) (b b) (c c)) :key #'car) + '(b)) +(equal (find 'b #((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t) + '(b b)) +(equal (find 'c #((a) (b) (c) (a a) (b b) (c c)) :key #'car) + '(c)) +(equal (find 'c #((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t) + '(c c)) +(null (find 'z #((a) (b) (c) (a a) (b b) (c c)) :key #'car)) +(null (find 'z #((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t)) + +(equal (find 'a #((a) (b) (c) (a a) (b b) (c c) (a a a)) + :key #'car + :from-end t) + '(a a a)) +(equal (find 'a #((a) (b) (c) (a a) (b b) (c c) (a a a)) + :key #'car + :from-end t + :end nil) + '(a a a)) +(equal (find 'a #((a) (b) (c) (a a) (b b) (c c) (a a a)) + :key #'car + :from-end t + :end 6) + '(a a)) +(null (find 'a #((a) (b) (c) (a a) (b b) (c c) (a a a)) + :key #'car + :from-end t + :start 1 + :end 3)) +(null (find #\c #("abc" "bcd" "cde"))) +(string= (find #\c #("abc" "bcd" "cde") + :key #'(lambda (arg) (char arg 0)) + :test #'char=) + "cde") +(string= (find #\c #("abc" "bcd" "cde") + :key #'(lambda (arg) (char arg 0)) + :test #'char>) + "abc") +(string= (find #\c #("abc" "bcd" "cde") + :start 1 + :key #'(lambda (arg) (char arg 0)) + :test #'char>) + "bcd") +(null (find #\z "abcABC")) +(eql (find #\a "abcABC") #\a) +(eql (find #\A "abcABC") #\A) +(eql (find #\A "abcABC" :test #'char-equal) #\a) +(eql (find #\A "abcABC" :test #'char-equal :from-end t) #\A) +(eql (find #\a "abcABC" :test #'char-equal :from-end t) #\A) +(eql (find #\a "abcABC" :test #'char-equal :from-end t :end 4) #\A) +(eql (find #\a "abcABC" :test #'char-equal :from-end t :end 3) #\a) +(zerop (find 0 #*01)) +(eql (find 1 #*01) 1) +(null (find 0 #*01 :start 1)) +(null (find 1 #*01 :end 0)) +(null (find 0 #*000001 :start 5)) + + + +(eq (find-if #'(lambda (x) (eq x 'a)) '(a b c)) 'a) +(eq (find-if #'(lambda (x) (eq x 'b)) '(a b c)) 'b) +(eq (find-if #'(lambda (x) (eq x 'c)) '(a b c)) 'c) +(null (find-if #'(lambda (arg) (eq arg 'x)) '(a b c))) +(null (find-if #'(lambda (x) (eq x 'a)) '(a b c) :start 1)) +(null (find-if #'(lambda (x) (eq x 'b)) '(a b c) :start 2)) +(null (find-if #'(lambda (x) (eq x 'c)) '(a b c) :start 3)) +(null (find-if #'(lambda (x) (eq x 'a)) '(a b c) :start 0 :end 0)) +(null (find-if #'(lambda (x) (eq x 'a)) '(a b c) :start 0 :end 0 :from-end t)) +(null (find-if #'(lambda (x) (eq x 'a)) '(a b c) :start 1 :end 1)) +(null (find-if #'(lambda (x) (eq x 'a)) '(a b c) :start 1 :end 1 :from-end t)) +(null (find-if #'(lambda (x) (eq x 'a)) '(a b c) :start 2 :end 2)) +(null (find-if #'(lambda (x) (eq x 'a)) '(a b c) :start 2 :end 2 :from-end t)) +(null (find-if #'(lambda (x) (eq x 'a)) '(a b c) :start 3 :end 3)) +(null (find-if #'(lambda (x) (eq x 'a)) '(a b c) :start 3 :end 3 :from-end t)) +(eq (find-if #'(lambda (x) (eq x 'a)) '(a b c) :end nil) 'a) +(eq (find-if #'(lambda (x) (eq x 'b)) '(a b c) :end nil) 'b) +(eq (find-if #'(lambda (x) (eq x 'c)) '(a b c) :end nil) 'c) +(eq (find-if #'(lambda (x) (eq x 'a)) '(a b c) :end 1) 'a) +(eq (find-if #'(lambda (x) (eq x 'b)) '(a b c) :end 2) 'b) +(eq (find-if #'(lambda (x) (eq x 'c)) '(a b c) :end 3) 'c) +(null (find-if #'(lambda (x) (eq x 'a)) '(a b c) :end 0)) +(null (find-if #'(lambda (x) (eq x 'b)) '(a b c) :end 1)) +(null (find-if #'(lambda (x) (eq x 'c)) '(a b c) :end 2)) +(null (find-if #'(lambda (x) (eq x 'a)) '((a) (b) (c)))) +(equal (find-if #'(lambda (x) (eq x 'a)) '((a) (b) (c)) :key #'car) '(a)) +(equal (find-if #'(lambda (x) (eq x 'b)) '((a) (b) (c)) :key #'car) '(b)) +(equal (find-if #'(lambda (x) (eq x 'c)) '((a) (b) (c)) :key #'car) '(c)) +(null (find-if #'(lambda (x) (eq x 'z)) '((a) (b) (c)) :key #'car)) +(let ((list '((a) (b) (c)))) + (and (eq (find-if #'(lambda (x) (eq x 'a)) list :key #'car) (car list)) + (eq (find-if #'(lambda (x) (eq x 'b)) list :key #'car) (cadr list)) + (eq (find-if #'(lambda (x) (eq x 'c)) list :key #'car) (caddr list)) + (null (find-if #'(lambda (x) (eq x 'z)) list :key #'car)))) +(equal (find-if #'(lambda (x) (eq x 'a)) + '((a) (b) (c) (a a) (b b) (c c)) :key #'car) + '(a)) +(equal (find-if #'(lambda (x) (eq x 'a)) + '((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t) + '(a a)) +(equal (find-if #'(lambda (x) (eq x 'b)) + '((a) (b) (c) (a a) (b b) (c c)) :key #'car) + '(b)) +(equal (find-if #'(lambda (x) (eq x 'b)) + '((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t) + '(b b)) +(equal (find-if #'(lambda (x) (eq x 'c)) + '((a) (b) (c) (a a) (b b) (c c)) :key #'car) + '(c)) +(equal (find-if #'(lambda (x) (eq x 'c)) + '((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t) + '(c c)) +(null (find-if #'(lambda (x) (eq x 'z)) + '((a) (b) (c) (a a) (b b) (c c)) :key #'car)) +(null (find-if #'(lambda (x) (eq x 'z)) + '((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t)) +(equal (find-if #'(lambda (x) (eq x 'a)) + '((a) (b) (c) (a a) (b b) (c c) (a a a)) + :key #'car + :from-end t) + '(a a a)) +(equal (find-if #'(lambda (x) (eq x 'a)) + '((a) (b) (c) (a a) (b b) (c c) (a a a)) + :key #'car + :from-end t + :end nil) + '(a a a)) +(equal (find-if #'(lambda (x) (eq x 'a)) + '((a) (b) (c) (a a) (b b) (c c) (a a a)) + :key #'car + :from-end t + :end 6) + '(a a)) +(null (find-if #'(lambda (x) (eq x 'a)) + '((a) (b) (c) (a a) (b b) (c c) (a a a)) + :key #'car + :from-end t + :start 1 + :end 3)) +(null (find-if #'(lambda (x) (eql x #\c)) '("abc" "bcd" "cde"))) +(string= (find-if #'(lambda (x) (eql x #\c)) '("abc" "bcd" "cde") + :key #'(lambda (arg) (char arg 0))) + "cde") +(string= (find-if #'(lambda (x) (char> #\c x)) '("abc" "bcd" "cde") + :key #'(lambda (arg) (char arg 0))) + "abc") +(string= (find-if #'(lambda (x) (char> #\c x)) '("abc" "bcd" "cde") + :start 1 + :key #'(lambda (arg) (char arg 0))) + "bcd") + + +(eq (find-if #'(lambda (x) (eq x 'a)) #(a b c)) 'a) +(eq (find-if #'(lambda (x) (eq x 'b)) #(a b c)) 'b) +(eq (find-if #'(lambda (x) (eq x 'c)) #(a b c)) 'c) +(null (find-if #'(lambda (arg) (eq arg 'x)) #(a b c))) +(null (find-if #'(lambda (x) (eq x 'a)) #(a b c) :start 1)) +(null (find-if #'(lambda (x) (eq x 'b)) #(a b c) :start 2)) +(null (find-if #'(lambda (x) (eq x 'c)) #(a b c) :start 3)) +(null (find-if #'(lambda (x) (eq x 'a)) #(a b c) :start 0 :end 0)) +(null (find-if #'(lambda (x) (eq x 'a)) #(a b c) :start 0 :end 0 :from-end t)) +(null (find-if #'(lambda (x) (eq x 'a)) #(a b c) :start 1 :end 1)) +(null (find-if #'(lambda (x) (eq x 'a)) #(a b c) :start 1 :end 1 :from-end t)) +(null (find-if #'(lambda (x) (eq x 'a)) #(a b c) :start 2 :end 2)) +(null (find-if #'(lambda (x) (eq x 'a)) #(a b c) :start 2 :end 2 :from-end t)) +(null (find-if #'(lambda (x) (eq x 'a)) #(a b c) :start 3 :end 3)) +(null (find-if #'(lambda (x) (eq x 'a)) #(a b c) :start 3 :end 3 :from-end t)) +(eq (find-if #'(lambda (x) (eq x 'a)) #(a b c) :end nil) 'a) +(eq (find-if #'(lambda (x) (eq x 'b)) #(a b c) :end nil) 'b) +(eq (find-if #'(lambda (x) (eq x 'c)) #(a b c) :end nil) 'c) +(eq (find-if #'(lambda (x) (eq x 'a)) #(a b c) :end 1) 'a) +(eq (find-if #'(lambda (x) (eq x 'b)) #(a b c) :end 2) 'b) +(eq (find-if #'(lambda (x) (eq x 'c)) #(a b c) :end 3) 'c) +(null (find-if #'(lambda (x) (eq x 'a)) #(a b c) :end 0)) +(null (find-if #'(lambda (x) (eq x 'b)) #(a b c) :end 1)) +(null (find-if #'(lambda (x) (eq x 'c)) #(a b c) :end 2)) +(null (find-if #'(lambda (x) (eq x 'a)) #((a) (b) (c)))) +(equal (find-if #'(lambda (x) (eq x 'a)) #((a) (b) (c)) :key #'car) '(a)) +(equal (find-if #'(lambda (x) (eq x 'b)) #((a) (b) (c)) :key #'car) '(b)) +(equal (find-if #'(lambda (x) (eq x 'c)) #((a) (b) (c)) :key #'car) '(c)) +(null (find-if #'(lambda (x) (eq x 'z)) #((a) (b) (c)) :key #'car)) +(let ((vector #((a) (b) (c)))) + (and (eq (find-if #'(lambda (x) (eq x 'a)) vector :key #'car) (aref vector 0)) + (eq (find-if #'(lambda (x) (eq x 'b)) vector :key #'car) (aref vector 1)) + (eq (find-if #'(lambda (x) (eq x 'c)) vector :key #'car) (aref vector 2)) + (null (find-if #'(lambda (x) (eq x 'z)) vector :key #'car)))) +(equal (find-if #'(lambda (x) (eq x 'a)) + #((a) (b) (c) (a a) (b b) (c c)) :key #'car) + '(a)) +(equal (find-if #'(lambda (x) (eq x 'a)) + #((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t) + '(a a)) +(equal (find-if #'(lambda (x) (eq x 'b)) + #((a) (b) (c) (a a) (b b) (c c)) :key #'car) + '(b)) +(equal (find-if #'(lambda (x) (eq x 'b)) + #((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t) + '(b b)) +(equal (find-if #'(lambda (x) (eq x 'c)) + #((a) (b) (c) (a a) (b b) (c c)) :key #'car) + '(c)) +(equal (find-if #'(lambda (x) (eq x 'c)) + #((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t) + '(c c)) +(null (find-if #'(lambda (x) (eq x 'z)) + #((a) (b) (c) (a a) (b b) (c c)) :key #'car)) +(null (find-if #'(lambda (x) (eq x 'z)) + #((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t)) +(equal (find-if #'(lambda (x) (eq x 'a)) + #((a) (b) (c) (a a) (b b) (c c) (a a a)) + :key #'car + :from-end t) + '(a a a)) +(equal (find-if #'(lambda (x) (eq x 'a)) + #((a) (b) (c) (a a) (b b) (c c) (a a a)) + :key #'car + :from-end t + :end nil) + '(a a a)) +(equal (find-if #'(lambda (x) (eq x 'a)) + #((a) (b) (c) (a a) (b b) (c c) (a a a)) + :key #'car + :from-end t + :end 6) + '(a a)) +(null (find-if #'(lambda (x) (eq x 'a)) + #((a) (b) (c) (a a) (b b) (c c) (a a a)) + :key #'car + :from-end t + :start 1 + :end 3)) +(null (find-if #'(lambda (x) (eql x #\c)) #("abc" "bcd" "cde"))) +(string= (find-if #'(lambda (x) (eql x #\c)) #("abc" "bcd" "cde") + :key #'(lambda (arg) (char arg 0))) + "cde") +(string= (find-if #'(lambda (x) (char> #\c x)) #("abc" "bcd" "cde") + :key #'(lambda (arg) (char arg 0))) + "abc") +(string= (find-if #'(lambda (x) (char> #\c x)) #("abc" "bcd" "cde") + :start 1 + :key #'(lambda (arg) (char arg 0))) + "bcd") + + +(eq (find-if-not #'(lambda (x) (not (eq x 'a))) '(a b c)) 'a) +(eq (find-if-not #'(lambda (x) (not (eq x 'b))) '(a b c)) 'b) +(eq (find-if-not #'(lambda (x) (not (eq x 'c))) '(a b c)) 'c) +(null (find-if-not #'(lambda (arg) (not (eq arg 'x))) '(a b c))) +(null (find-if-not #'(lambda (x) (not (eq x 'a))) '(a b c) :start 1)) +(null (find-if-not #'(lambda (x) (not (eq x 'b))) '(a b c) :start 2)) +(null (find-if-not #'(lambda (x) (not (eq x 'c))) '(a b c) :start 3)) +(null (find-if-not #'(lambda (x) (not (eq x 'a))) '(a b c) :start 0 :end 0)) +(null (find-if-not #'(lambda (x) (not (eq x 'a))) '(a b c) + :start 0 :end 0 :from-end t)) +(null (find-if-not #'(lambda (x) (not (eq x 'a))) '(a b c) :start 1 :end 1)) +(null (find-if-not #'(lambda (x) (not (eq x 'a))) '(a b c) + :start 1 :end 1 :from-end t)) +(null (find-if-not #'(lambda (x) (not (eq x 'a))) '(a b c) :start 2 :end 2)) +(null (find-if-not #'(lambda (x) (not (eq x 'a))) '(a b c) + :start 2 :end 2 :from-end t)) +(null (find-if-not #'(lambda (x) (not (eq x 'a))) '(a b c) :start 3 :end 3)) +(null (find-if-not #'(lambda (x) (not (eq x 'a))) '(a b c) + :start 3 :end 3 :from-end t)) +(eq (find-if-not #'(lambda (x) (not (eq x 'a))) '(a b c) :end nil) 'a) +(eq (find-if-not #'(lambda (x) (not (eq x 'b))) '(a b c) :end nil) 'b) +(eq (find-if-not #'(lambda (x) (not (eq x 'c))) '(a b c) :end nil) 'c) +(eq (find-if-not #'(lambda (x) (not (eq x 'a))) '(a b c) :end 1) 'a) +(eq (find-if-not #'(lambda (x) (not (eq x 'b))) '(a b c) :end 2) 'b) +(eq (find-if-not #'(lambda (x) (not (eq x 'c))) '(a b c) :end 3) 'c) +(null (find-if-not #'(lambda (x) (not (eq x 'a))) '(a b c) :end 0)) +(null (find-if-not #'(lambda (x) (not (eq x 'b))) '(a b c) :end 1)) +(null (find-if-not #'(lambda (x) (not (eq x 'c))) '(a b c) :end 2)) +(null (find-if-not #'(lambda (x) (not (eq x 'a))) '((a) (b) (c)))) +(equal (find-if-not #'(lambda (x) (not (eq x 'a))) '((a) (b) (c)) :key #'car) + '(a)) +(equal (find-if-not #'(lambda (x) (not (eq x 'b))) '((a) (b) (c)) :key #'car) + '(b)) +(equal (find-if-not #'(lambda (x) (not (eq x 'c))) '((a) (b) (c)) :key #'car) + '(c)) +(null (find-if-not #'(lambda (x) (not (eq x 'z))) '((a) (b) (c)) :key #'car)) +(let ((list '((a) (b) (c)))) + (and (eq (find-if-not #'(lambda (x) (not (eq x 'a))) list :key #'car) + (car list)) + (eq (find-if-not #'(lambda (x) (not (eq x 'b))) list :key #'car) + (cadr list)) + (eq (find-if-not #'(lambda (x) (not (eq x 'c))) list :key #'car) + (caddr list)) + (null (find-if-not #'(lambda (x) (not (eq x 'z))) list :key #'car)))) +(equal (find-if-not #'(lambda (x) (not (eq x 'a))) + '((a) (b) (c) (a a) (b b) (c c)) :key #'car) + '(a)) +(equal (find-if-not #'(lambda (x) (not (eq x 'a))) + '((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t) + '(a a)) +(equal (find-if-not #'(lambda (x) (not (eq x 'b))) + '((a) (b) (c) (a a) (b b) (c c)) :key #'car) + '(b)) +(equal (find-if-not #'(lambda (x) (not (eq x 'b))) + '((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t) + '(b b)) +(equal (find-if-not #'(lambda (x) (not (eq x 'c))) + '((a) (b) (c) (a a) (b b) (c c)) :key #'car) + '(c)) +(equal (find-if-not #'(lambda (x) (not (eq x 'c))) + '((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t) + '(c c)) +(null (find-if-not #'(lambda (x) (not (eq x 'z))) + '((a) (b) (c) (a a) (b b) (c c)) :key #'car)) +(null (find-if-not #'(lambda (x) (not (eq x 'z))) + '((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t)) +(equal (find-if-not #'(lambda (x) (not (eq x 'a))) + '((a) (b) (c) (a a) (b b) (c c) (a a a)) + :key #'car + :from-end t) + '(a a a)) +(equal (find-if-not #'(lambda (x) (not (eq x 'a))) + '((a) (b) (c) (a a) (b b) (c c) (a a a)) + :key #'car + :from-end t + :end nil) + '(a a a)) +(equal (find-if-not #'(lambda (x) (not (eq x 'a))) + '((a) (b) (c) (a a) (b b) (c c) (a a a)) + :key #'car + :from-end t + :end 6) + '(a a)) +(null (find-if-not #'(lambda (x) (not (eq x 'a))) + '((a) (b) (c) (a a) (b b) (c c) (a a a)) + :key #'car + :from-end t + :start 1 + :end 3)) +(null (find-if-not #'(lambda (x) (not (eql x #\c))) '("abc" "bcd" "cde"))) +(string= (find-if-not #'(lambda (x) (not (eql x #\c))) '("abc" "bcd" "cde") + :key #'(lambda (arg) (char arg 0))) + "cde") +(string= (find-if-not #'(lambda (x) (not (char> #\c x))) '("abc" "bcd" "cde") + :key #'(lambda (arg) (char arg 0))) + "abc") +(string= (find-if-not #'(lambda (x) (not (char> #\c x))) '("abc" "bcd" "cde") + :start 1 + :key #'(lambda (arg) (char arg 0))) + "bcd") + +(eq (find-if-not #'(lambda (x) (not (eq x 'a))) #(a b c)) 'a) +(eq (find-if-not #'(lambda (x) (not (eq x 'b))) #(a b c)) 'b) +(eq (find-if-not #'(lambda (x) (not (eq x 'c))) #(a b c)) 'c) +(null (find-if-not #'(lambda (arg) (not (eq arg 'x))) #(a b c))) +(null (find-if-not #'(lambda (x) (not (eq x 'a))) #(a b c) :start 1)) +(null (find-if-not #'(lambda (x) (not (eq x 'b))) #(a b c) :start 2)) +(null (find-if-not #'(lambda (x) (not (eq x 'c))) #(a b c) :start 3)) +(null (find-if-not #'(lambda (x) (not (eq x 'a))) #(a b c) :start 0 :end 0)) +(null (find-if-not #'(lambda (x) (not (eq x 'a))) #(a b c) :start 0 :end 0 + :from-end t)) +(null (find-if-not #'(lambda (x) (not (eq x 'a))) #(a b c) :start 1 :end 1)) +(null (find-if-not #'(lambda (x) (not (eq x 'a))) #(a b c) :start 1 :end 1 + :from-end t)) +(null (find-if-not #'(lambda (x) (not (eq x 'a))) #(a b c) :start 2 :end 2)) +(null (find-if-not #'(lambda (x) (not (eq x 'a))) #(a b c) :start 2 :end 2 + :from-end t)) +(null (find-if-not #'(lambda (x) (not (eq x 'a))) #(a b c) :start 3 :end 3)) +(null (find-if-not #'(lambda (x) (not (eq x 'a))) #(a b c) :start 3 :end 3 + :from-end t)) +(eq (find-if-not #'(lambda (x) (not (eq x 'a))) #(a b c) :end nil) 'a) +(eq (find-if-not #'(lambda (x) (not (eq x 'b))) #(a b c) :end nil) 'b) +(eq (find-if-not #'(lambda (x) (not (eq x 'c))) #(a b c) :end nil) 'c) +(eq (find-if-not #'(lambda (x) (not (eq x 'a))) #(a b c) :end 1) 'a) +(eq (find-if-not #'(lambda (x) (not (eq x 'b))) #(a b c) :end 2) 'b) +(eq (find-if-not #'(lambda (x) (not (eq x 'c))) #(a b c) :end 3) 'c) +(null (find-if-not #'(lambda (x) (not (eq x 'a))) #(a b c) :end 0)) +(null (find-if-not #'(lambda (x) (not (eq x 'b))) #(a b c) :end 1)) +(null (find-if-not #'(lambda (x) (not (eq x 'c))) #(a b c) :end 2)) +(null (find-if-not #'(lambda (x) (not (eq x 'a))) #((a) (b) (c)))) +(equal (find-if-not #'(lambda (x) (not (eq x 'a))) #((a) (b) (c)) :key #'car) + '(a)) +(equal (find-if-not #'(lambda (x) (not (eq x 'b))) #((a) (b) (c)) :key #'car) + '(b)) +(equal (find-if-not #'(lambda (x) (not (eq x 'c))) #((a) (b) (c)) :key #'car) + '(c)) +(null (find-if-not #'(lambda (x) (not (eq x 'z))) #((a) (b) (c)) :key #'car)) +(let ((vector #((a) (b) (c)))) + (and (eq (find-if-not #'(lambda (x) (not (eq x 'a))) vector :key #'car) + (aref vector 0)) + (eq (find-if-not #'(lambda (x) (not (eq x 'b))) vector :key #'car) + (aref vector 1)) + (eq (find-if-not #'(lambda (x) (not (eq x 'c))) vector :key #'car) + (aref vector 2)) + (null (find-if-not #'(lambda (x) (not (eq x 'z))) vector :key #'car)))) +(equal (find-if-not #'(lambda (x) (not (eq x 'a))) + #((a) (b) (c) (a a) (b b) (c c)) :key #'car) + '(a)) +(equal (find-if-not #'(lambda (x) (not (eq x 'a))) + #((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t) + '(a a)) +(equal (find-if-not #'(lambda (x) (not (eq x 'b))) + #((a) (b) (c) (a a) (b b) (c c)) :key #'car) + '(b)) +(equal (find-if-not #'(lambda (x) (not (eq x 'b))) + #((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t) + '(b b)) +(equal (find-if-not #'(lambda (x) (not (eq x 'c))) + #((a) (b) (c) (a a) (b b) (c c)) :key #'car) + '(c)) +(equal (find-if-not #'(lambda (x) (not (eq x 'c))) + #((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t) + '(c c)) +(null (find-if-not #'(lambda (x) (not (eq x 'z))) + #((a) (b) (c) (a a) (b b) (c c)) :key #'car)) +(null (find-if-not #'(lambda (x) (not (eq x 'z))) + #((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t)) +(equal (find-if-not #'(lambda (x) (not (eq x 'a))) + #((a) (b) (c) (a a) (b b) (c c) (a a a)) + :key #'car + :from-end t) + '(a a a)) +(equal (find-if-not #'(lambda (x) (not (eq x 'a))) + #((a) (b) (c) (a a) (b b) (c c) (a a a)) + :key #'car + :from-end t + :end nil) + '(a a a)) +(equal (find-if-not #'(lambda (x) (not (eq x 'a))) + #((a) (b) (c) (a a) (b b) (c c) (a a a)) + :key #'car + :from-end t + :end 6) + '(a a)) +(null (find-if-not #'(lambda (x) (not (eq x 'a))) + #((a) (b) (c) (a a) (b b) (c c) (a a a)) + :key #'car + :from-end t + :start 1 + :end 3)) +(string= (find-if-not #'(lambda (x) (not (eql x #\c))) #("abc" "bcd" "cde") + :key #'(lambda (arg) (char arg 0))) + "cde") +(string= (find-if-not #'(lambda (x) (not (char> #\c x))) #("abc" "bcd" "cde") + :key #'(lambda (arg) (char arg 0))) + "abc") +(string= (find-if-not #'(lambda (x) (not (char> #\c x))) #("abc" "bcd" "cde") + :start 1 + :key #'(lambda (arg) (char arg 0))) + "bcd") + + + + +(eql (position #\a "baobab" :from-end t) 4) +(eql (position-if #'oddp '((1) (2) (3) (4)) :start 1 :key #'car) 2) +(null (position 595 '())) +(eql (position-if-not #'integerp '(1 2 3 4 5.0)) 4) + +(eql (position 'a '(a b c)) 0) +(eql (position 'b '(a b c)) 1) +(eql (position 'c '(a b c)) 2) +(null (position 'x '(a b c))) +(null (position 'a '(a b c) :start 1)) +(null (position 'b '(a b c) :start 2)) +(null (position 'c '(a b c) :start 3)) +(null (position 'a '(a b c) :start 0 :end 0)) +(null (position 'a '(a b c) :start 0 :end 0 :from-end t)) +(null (position 'a '(a b c) :start 1 :end 1)) +(null (position 'a '(a b c) :start 1 :end 1 :from-end t)) +(null (position 'a '(a b c) :start 2 :end 2)) +(null (position 'a '(a b c) :start 2 :end 2 :from-end t)) +(null (position 'a '(a b c) :start 3 :end 3)) +(null (position 'a '(a b c) :start 3 :end 3 :from-end t)) +(eql (position 'a '(a b c) :end nil) '0) +(eql (position 'b '(a b c) :end nil) '1) +(eql (position 'c '(a b c) :end nil) '2) +(eql (position 'a '(a b c) :end 1) '0) +(eql (position 'b '(a b c) :end 2) '1) +(eql (position 'c '(a b c) :end 3) '2) +(null (position 'a '(a b c) :end 0)) +(null (position 'b '(a b c) :end 1)) +(null (position 'c '(a b c) :end 2)) +(null (position 'a '((a) (b) (c)))) +(eql (position 'a '((a) (b) (c)) :key #'car) 0) +(eql (position 'b '((a) (b) (c)) :key #'car) 1) +(eql (position 'c '((a) (b) (c)) :key #'car) 2) +(null (position 'z '((a) (b) (c)) :key #'car)) +(null (position '(a) '((a) (b) (c)))) +(eql (position '(a) '((a) (b) (c)) :test #'equal) 0) +(null (position '("a") '(("a") ("b") ("c")))) +(null (position '("a") '(("A") ("B") ("c")) :test #'equal)) +(eql (position '("a") '(("A") ("B") ("c")) :test #'equalp) 0) +(eql (position 'nil '(first second third) :test (constantly t)) 0) +(eql (position 3 '(0 1 2 3 4 5)) 3) +(eql (position 3 '(0 1 2 3 4 5) :test #'<) 4) +(eql (position 3 '(0 1 2 3 4 5) :test #'>) 0) +(eql (position '(a) '((a) (b) (c)) :test-not (complement #'equal)) 0) +(null (position '("a") '(("A") ("B") ("c")) :test-not (complement #'equal))) +(eql (position '("a") '(("A") ("B") ("c")) :test-not (complement #'equalp)) + 0) +(eql (position 'nil '(first second third) :test-not (constantly nil)) 0) +(eql (position 3 '(0 1 2 3 4 5) :test-not #'>=) 4) +(eql (position 3 '(0 1 2 3 4 5) :test-not #'<=) 0) +(eql (position 'a '((a) (b) (c) (a a) (b b) (c c)) :key #'car) 0) +(eql (position 'a '((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t) 3) +(eql (position 'b '((a) (b) (c) (a a) (b b) (c c)) :key #'car) 1) +(eql (position 'b '((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t) 4) +(eql (position 'c '((a) (b) (c) (a a) (b b) (c c)) :key #'car) 2) +(eql (position 'c '((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t) 5) +(null (position 'z '((a) (b) (c) (a a) (b b) (c c)) :key #'car)) +(null (position 'z '((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t)) +(eql (position 'a '((a) (b) (c) (a a) (b b) (c c) (a a a)) + :key #'car + :from-end t) + 6) +(eql (position 'a '((a) (b) (c) (a a) (b b) (c c) (a a a)) + :key #'car + :from-end t + :end nil) + 6) +(eql (position 'a '((a) (b) (c) (a a) (b b) (c c) (a a a)) + :key #'car + :from-end t + :end 6) + 3) +(null (position 'a '((a) (b) (c) (a a) (b b) (c c) (a a a)) + :key #'car + :from-end t + :start 1 + :end 3)) +(null (position #\c '("abc" "bcd" "cde"))) +(eql (position #\c '("abc" "bcd" "cde") + :key #'(lambda (arg) (char arg 0)) + :test #'char=) + 2) +(eql (position #\c '("abc" "bcd" "cde") + :key #'(lambda (arg) (char arg 0)) + :test #'char>) + 0) +(eql (position #\c '("abc" "bcd" "cde") + :start 1 + :key #'(lambda (arg) (char arg 0)) + :test #'char>) + 1) +(eql (position 'a #(a b c)) 0) +(eql (position 'b #(a b c)) 1) +(eql (position 'c #(a b c)) 2) +(null (position 'x #(a b c))) +(null (position 'a #(a b c) :start 1)) +(null (position 'b #(a b c) :start 2)) +(null (position 'c #(a b c) :start 3)) +(null (position 'a #(a b c) :start 0 :end 0)) +(null (position 'a #(a b c) :start 0 :end 0 :from-end t)) +(null (position 'a #(a b c) :start 1 :end 1)) +(null (position 'a #(a b c) :start 1 :end 1 :from-end t)) +(null (position 'a #(a b c) :start 2 :end 2)) +(null (position 'a #(a b c) :start 2 :end 2 :from-end t)) +(null (position 'a #(a b c) :start 3 :end 3)) +(null (position 'a #(a b c) :start 3 :end 3 :from-end t)) +(eql (position 'a #(a b c) :end nil) 0) +(eql (position 'b #(a b c) :end nil) 1) +(eql (position 'c #(a b c) :end nil) 2) +(eql (position 'a #(a b c) :end 1) 0) +(eql (position 'b #(a b c) :end 2) 1) +(eql (position 'c #(a b c) :end 3) 2) +(null (position 'a #(a b c) :end 0)) +(null (position 'b #(a b c) :end 1)) +(null (position 'c #(a b c) :end 2)) +(null (position 'a #((a) (b) (c)))) +(eql (position 'a #((a) (b) (c)) :key #'car) 0) +(eql (position 'b #((a) (b) (c)) :key #'car) 1) +(eql (position 'c #((a) (b) (c)) :key #'car) 2) +(null (position 'z #((a) (b) (c)) :key #'car)) +(null (position '(a) #((a) (b) (c)))) +(eql (position '(a) #((a) (b) (c)) :test #'equal) 0) +(null (position '("a") #(("a") ("b") ("c")))) +(null (position '("a") #(("A") ("B") ("c")) :test #'equal)) +(eql (position '("a") #(("A") ("B") ("c")) :test #'equalp) 0) +(eql (position 'nil #(first second third) :test (constantly t)) 0) +(eql (position 'nil #(first second third) :test (constantly t) :from-end t) 2) +(eql (position 3 #(0 1 2 3 4 5)) 3) +(eql (position 3 #(0 1 2 3 4 5) :test #'<) 4) +(eql (position 3 #(0 1 2 3 4 5) :test #'>) 0) +(eql (position '(a) #((a) (b) (c)) :test-not (complement #'equal)) 0) +(null (position '("a") #(("A") ("B") ("c")) :test-not (complement #'equal))) +(eql (position '("a") #(("A") ("B") ("c")) :test-not (complement #'equalp)) + 0) +(eql (position 'nil #(first second third) :test-not (constantly nil)) 0) +(eql (position 3 #(0 1 2 3 4 5) :test-not #'>=) 4) +(eql (position 3 #(0 1 2 3 4 5) :test-not #'<=) 0) +(eql (position 'a #((a) (b) (c) (a a) (b b) (c c)) :key #'car) 0) +(eql (position 'a #((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t) 3) +(eql (position 'b #((a) (b) (c) (a a) (b b) (c c)) :key #'car) 1) +(eql (position 'b #((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t) 4) +(eql (position 'c #((a) (b) (c) (a a) (b b) (c c)) :key #'car) 2) +(eql (position 'c #((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t) 5) +(null (position 'z #((a) (b) (c) (a a) (b b) (c c)) :key #'car)) +(null (position 'z #((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t)) +(eql (position 'a #((a) (b) (c) (a a) (b b) (c c) (a a a)) + :key #'car + :from-end t) + 6) +(eql (position 'a #((a) (b) (c) (a a) (b b) (c c) (a a a)) + :key #'car + :from-end t + :end nil) + 6) +(eql (position 'a #((a) (b) (c) (a a) (b b) (c c) (a a a)) + :key #'car + :from-end t + :end 6) + 3) +(null (position 'a #((a) (b) (c) (a a) (b b) (c c) (a a a)) + :key #'car + :from-end t + :start 1 + :end 3)) +(null (position #\c #("abc" "bcd" "cde"))) +(eql (position #\c #("abc" "bcd" "cde") + :key #'(lambda (arg) (char arg 0)) + :test #'char=) + 2) +(eql (position #\c #("abc" "bcd" "cde") + :key #'(lambda (arg) (char arg 0)) + :test #'char>) + 0) +(eql (position #\c #("abc" "bcd" "cde") + :start 1 + :key #'(lambda (arg) (char arg 0)) + :test #'char>) + 1) +(null (position #\z "abcABC")) +(eql (position #\a "abcABC") 0) +(eql (position #\A "abcABC") 3) +(eql (position #\A "abcABC" :test #'char-equal) 0) +(eql (position #\A "abcABC" :test #'char-equal :from-end t) 3) +(eql (position #\a "abcABC" :test #'char-equal :from-end t) 3) +(eql (position #\a "abcABC" :test #'char-equal :from-end t :end 4) 3) +(eql (position #\a "abcABC" :test #'char-equal :from-end t :end 3) 0) +(zerop (position 0 #*01)) +(eql (position 1 #*01) 1) +(null (position 0 #*01 :start 1)) +(null (position 1 #*01 :end 0)) +(null (position 0 #*000001 :start 5)) + + +(eql (position-if #'(lambda (x) (eq x 'a)) '(a b c)) 0) +(eql (position-if #'(lambda (x) (eq x 'b)) '(a b c)) 1) +(eql (position-if #'(lambda (x) (eq x 'c)) '(a b c)) 2) +(null (position-if #'(lambda (arg) (eq arg 'x)) '(a b c))) +(null (position-if #'(lambda (x) (eq x 'a)) '(a b c) :start 1)) +(null (position-if #'(lambda (x) (eq x 'b)) '(a b c) :start 2)) +(null (position-if #'(lambda (x) (eq x 'c)) '(a b c) :start 3)) +(null (position-if #'(lambda (x) (eq x 'a)) '(a b c) :start 0 :end 0)) +(null (position-if #'(lambda (x) (eq x 'a)) '(a b c) :start 0 :end 0 + :from-end t)) +(null (position-if #'(lambda (x) (eq x 'a)) '(a b c) :start 1 :end 1)) +(null (position-if #'(lambda (x) (eq x 'a)) '(a b c) :start 1 :end 1 + :from-end t)) +(null (position-if #'(lambda (x) (eq x 'a)) '(a b c) :start 2 :end 2)) +(null (position-if #'(lambda (x) (eq x 'a)) '(a b c) :start 2 :end 2 + :from-end t)) +(null (position-if #'(lambda (x) (eq x 'a)) '(a b c) :start 3 :end 3)) +(null (position-if #'(lambda (x) (eq x 'a)) '(a b c) :start 3 :end 3 + :from-end t)) +(eql (position-if #'(lambda (x) (eq x 'a)) '(a b c) :end nil) 0) +(eql (position-if #'(lambda (x) (eq x 'b)) '(a b c) :end nil) 1) +(eql (position-if #'(lambda (x) (eq x 'c)) '(a b c) :end nil) 2) +(eql (position-if #'(lambda (x) (eq x 'a)) '(a b c) :end 1) 0) +(eql (position-if #'(lambda (x) (eq x 'b)) '(a b c) :end 2) 1) +(eql (position-if #'(lambda (x) (eq x 'c)) '(a b c) :end 3) 2) +(null (position-if #'(lambda (x) (eq x 'a)) '(a b c) :end 0)) +(null (position-if #'(lambda (x) (eq x 'b)) '(a b c) :end 1)) +(null (position-if #'(lambda (x) (eq x 'c)) '(a b c) :end 2)) +(null (position-if #'(lambda (x) (eq x 'a)) '((a) (b) (c)))) +(eql (position-if #'(lambda (x) (eq x 'a)) '((a) (b) (c)) :key #'car) 0) +(eql (position-if #'(lambda (x) (eq x 'b)) '((a) (b) (c)) :key #'car) 1) +(eql (position-if #'(lambda (x) (eq x 'c)) '((a) (b) (c)) :key #'car) 2) +(null (position-if #'(lambda (x) (eq x 'z)) '((a) (b) (c)) :key #'car)) +(eql (position-if #'(lambda (x) (eq x 'a)) + '((a) (b) (c) (a a) (b b) (c c)) :key #'car) + 0) +(eql (position-if #'(lambda (x) (eq x 'a)) + '((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t) + 3) +(eql (position-if #'(lambda (x) (eq x 'b)) + '((a) (b) (c) (a a) (b b) (c c)) :key #'car) + 1) +(eql (position-if #'(lambda (x) (eq x 'b)) + '((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t) + 4) +(eql (position-if #'(lambda (x) (eq x 'c)) + '((a) (b) (c) (a a) (b b) (c c)) :key #'car) + 2) +(eql (position-if #'(lambda (x) (eq x 'c)) + '((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t) + 5) +(null (position-if #'(lambda (x) (eq x 'z)) + '((a) (b) (c) (a a) (b b) (c c)) :key #'car)) +(null (position-if #'(lambda (x) (eq x 'z)) + '((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t)) +(eql (position-if #'(lambda (x) (eq x 'a)) + '((a) (b) (c) (a a) (b b) (c c) (a a a)) + :key #'car + :from-end t) + 6) +(eql (position-if #'(lambda (x) (eq x 'a)) + '((a) (b) (c) (a a) (b b) (c c) (a a a)) + :key #'car + :from-end t + :end nil) + 6) +(eql (position-if #'(lambda (x) (eq x 'a)) + '((a) (b) (c) (a a) (b b) (c c) (a a a)) + :key #'car + :from-end t + :end 6) + 3) +(null (position-if #'(lambda (x) (eq x 'a)) + '((a) (b) (c) (a a) (b b) (c c) (a a a)) + :key #'car + :from-end t + :start 1 + :end 3)) +(null (position-if #'(lambda (x) (eql x #\c)) '("abc" "bcd" "cde"))) +(eql (position-if #'(lambda (x) (eql x #\c)) '("abc" "bcd" "cde") + :key #'(lambda (arg) (char arg 0))) + 2) +(eql (position-if #'(lambda (x) (char> #\c x)) '("abc" "bcd" "cde") + :key #'(lambda (arg) (char arg 0))) + 0) +(eql (position-if #'(lambda (x) (char> #\c x)) '("abc" "bcd" "cde") + :start 1 + :key #'(lambda (arg) (char arg 0))) + 1) +(eql (position-if #'(lambda (x) (eq x 'a)) #(a b c)) 0) +(eql (position-if #'(lambda (x) (eq x 'b)) #(a b c)) 1) +(eql (position-if #'(lambda (x) (eq x 'c)) #(a b c)) 2) +(null (position-if #'(lambda (arg) (eq arg 'x)) #(a b c))) +(null (position-if #'(lambda (x) (eq x 'a)) #(a b c) :start 1)) +(null (position-if #'(lambda (x) (eq x 'b)) #(a b c) :start 2)) +(null (position-if #'(lambda (x) (eq x 'c)) #(a b c) :start 3)) +(null (position-if #'(lambda (x) (eq x 'a)) #(a b c) :start 0 :end 0)) +(null (position-if #'(lambda (x) (eq x 'a)) #(a b c) :start 0 :end 0 + :from-end t)) +(null (position-if #'(lambda (x) (eq x 'a)) #(a b c) :start 1 :end 1)) +(null (position-if #'(lambda (x) (eq x 'a)) #(a b c) :start 1 :end 1 + :from-end t)) +(null (position-if #'(lambda (x) (eq x 'a)) #(a b c) :start 2 :end 2)) +(null (position-if #'(lambda (x) (eq x 'a)) #(a b c) :start 2 :end 2 + :from-end t)) +(null (position-if #'(lambda (x) (eq x 'a)) #(a b c) :start 3 :end 3)) +(null (position-if #'(lambda (x) (eq x 'a)) #(a b c) :start 3 :end 3 + :from-end t)) +(eql (position-if #'(lambda (x) (eq x 'a)) #(a b c) :end nil) 0) +(eql (position-if #'(lambda (x) (eq x 'b)) #(a b c) :end nil) 1) +(eql (position-if #'(lambda (x) (eq x 'c)) #(a b c) :end nil) 2) +(eql (position-if #'(lambda (x) (eq x 'a)) #(a b c) :end 1) 0) +(eql (position-if #'(lambda (x) (eq x 'b)) #(a b c) :end 2) 1) +(eql (position-if #'(lambda (x) (eq x 'c)) #(a b c) :end 3) 2) +(null (position-if #'(lambda (x) (eq x 'a)) #(a b c) :end 0)) +(null (position-if #'(lambda (x) (eq x 'b)) #(a b c) :end 1)) +(null (position-if #'(lambda (x) (eq x 'c)) #(a b c) :end 2)) +(null (position-if #'(lambda (x) (eq x 'a)) #((a) (b) (c)))) +(eql (position-if #'(lambda (x) (eq x 'a)) #((a) (b) (c)) :key #'car) 0) +(eql (position-if #'(lambda (x) (eq x 'b)) #((a) (b) (c)) :key #'car) 1) +(eql (position-if #'(lambda (x) (eq x 'c)) #((a) (b) (c)) :key #'car) 2) +(null (position-if #'(lambda (x) (eq x 'z)) #((a) (b) (c)) :key #'car)) +(eql (position-if #'(lambda (x) (eq x 'a)) + #((a) (b) (c) (a a) (b b) (c c)) :key #'car) + 0) +(eql (position-if #'(lambda (x) (eq x 'a)) + #((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t) + 3) +(eql (position-if #'(lambda (x) (eq x 'b)) + #((a) (b) (c) (a a) (b b) (c c)) :key #'car) + 1) +(eql (position-if #'(lambda (x) (eq x 'b)) + #((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t) + 4) +(eql (position-if #'(lambda (x) (eq x 'c)) + #((a) (b) (c) (a a) (b b) (c c)) :key #'car) + 2) +(eql (position-if #'(lambda (x) (eq x 'c)) + #((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t) + 5) +(null (position-if #'(lambda (x) (eq x 'z)) + #((a) (b) (c) (a a) (b b) (c c)) :key #'car)) +(null (position-if #'(lambda (x) (eq x 'z)) + #((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t)) +(eql (position-if #'(lambda (x) (eq x 'a)) + #((a) (b) (c) (a a) (b b) (c c) (a a a)) + :key #'car + :from-end t) + 6) +(eql (position-if #'(lambda (x) (eq x 'a)) + #((a) (b) (c) (a a) (b b) (c c) (a a a)) + :key #'car + :from-end t + :end nil) + 6) +(eql (position-if #'(lambda (x) (eq x 'a)) + #((a) (b) (c) (a a) (b b) (c c) (a a a)) + :key #'car + :from-end t + :end 6) + 3) +(null (position-if #'(lambda (x) (eq x 'a)) + #((a) (b) (c) (a a) (b b) (c c) (a a a)) + :key #'car + :from-end t + :start 1 + :end 3)) +(null (position-if #'(lambda (x) (eql x #\c)) #("abc" "bcd" "cde"))) +(eql (position-if #'(lambda (x) (eql x #\c)) #("abc" "bcd" "cde") + :key #'(lambda (arg) (char arg 0))) + 2) +(eql (position-if #'(lambda (x) (char> #\c x)) #("abc" "bcd" "cde") + :key #'(lambda (arg) (char arg 0))) + 0) +(eql (position-if #'(lambda (x) (char> #\c x)) #("abc" "bcd" "cde") + :start 1 + :key #'(lambda (arg) (char arg 0))) + 1) + + +(eql (position-if-not #'(lambda (x) (not (eq x 'a))) '(a b c)) 0) +(eql (position-if-not #'(lambda (x) (not (eq x 'b))) '(a b c)) 1) +(eql (position-if-not #'(lambda (x) (not (eq x 'c))) '(a b c)) 2) +(null (position-if-not #'(lambda (arg) (not (eq arg 'x))) '(a b c))) +(null (position-if-not #'(lambda (x) (not (eq x 'a))) '(a b c) :start 1)) +(null (position-if-not #'(lambda (x) (not (eq x 'b))) '(a b c) :start 2)) +(null (position-if-not #'(lambda (x) (not (eq x 'c))) '(a b c) :start 3)) +(null (position-if-not #'(lambda (x) (not (eq x 'a))) '(a b c) :start 0 :end 0)) +(null (position-if-not #'(lambda (x) (not (eq x 'a))) '(a b c) + :start 0 :end 0 :from-end t)) +(null (position-if-not #'(lambda (x) (not (eq x 'a))) '(a b c) :start 1 :end 1)) +(null (position-if-not #'(lambda (x) (not (eq x 'a))) '(a b c) + :start 1 :end 1 :from-end t)) +(null (position-if-not #'(lambda (x) (not (eq x 'a))) '(a b c) :start 2 :end 2)) +(null (position-if-not #'(lambda (x) (not (eq x 'a))) '(a b c) + :start 2 :end 2 :from-end t)) +(null (position-if-not #'(lambda (x) (not (eq x 'a))) '(a b c) :start 3 :end 3)) +(null (position-if-not #'(lambda (x) (not (eq x 'a))) '(a b c) + :start 3 :end 3 :from-end t)) +(eql (position-if-not #'(lambda (x) (not (eq x 'a))) '(a b c) :end nil) 0) +(eql (position-if-not #'(lambda (x) (not (eq x 'b))) '(a b c) :end nil) 1) +(eql (position-if-not #'(lambda (x) (not (eq x 'c))) '(a b c) :end nil) 2) +(eql (position-if-not #'(lambda (x) (not (eq x 'a))) '(a b c) :end 1) 0) +(eql (position-if-not #'(lambda (x) (not (eq x 'b))) '(a b c) :end 2) 1) +(eql (position-if-not #'(lambda (x) (not (eq x 'c))) '(a b c) :end 3) 2) +(null (position-if-not #'(lambda (x) (not (eq x 'a))) '(a b c) :end 0)) +(null (position-if-not #'(lambda (x) (not (eq x 'b))) '(a b c) :end 1)) +(null (position-if-not #'(lambda (x) (not (eq x 'c))) '(a b c) :end 2)) +(null (position-if-not #'(lambda (x) (not (eq x 'a))) '((a) (b) (c)))) +(eql (position-if-not #'(lambda (x) (not (eq x 'a))) '((a) (b) (c)) :key #'car) + 0) +(eql (position-if-not #'(lambda (x) (not (eq x 'b))) '((a) (b) (c)) :key #'car) + 1) +(eql (position-if-not #'(lambda (x) (not (eq x 'c))) '((a) (b) (c)) :key #'car) + 2) +(null (position-if-not #'(lambda (x) (not (eq x 'z))) '((a) (b) (c)) + :key #'car)) +(eql (position-if-not #'(lambda (x) (not (eq x 'a))) + '((a) (b) (c) (a a) (b b) (c c)) :key #'car) + 0) +(eql (position-if-not #'(lambda (x) (not (eq x 'a))) + '((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t) + 3) +(eql (position-if-not #'(lambda (x) (not (eq x 'b))) + '((a) (b) (c) (a a) (b b) (c c)) :key #'car) + 1) +(eql (position-if-not #'(lambda (x) (not (eq x 'b))) + '((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t) + 4) +(eql (position-if-not #'(lambda (x) (not (eq x 'c))) + '((a) (b) (c) (a a) (b b) (c c)) :key #'car) + 2) +(eql (position-if-not #'(lambda (x) (not (eq x 'c))) + '((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t) + 5) +(null (position-if-not #'(lambda (x) (not (eq x 'z))) + '((a) (b) (c) (a a) (b b) (c c)) :key #'car)) +(null (position-if-not #'(lambda (x) (not (eq x 'z))) + '((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t)) +(eql (position-if-not #'(lambda (x) (not (eq x 'a))) + '((a) (b) (c) (a a) (b b) (c c) (a a a)) + :key #'car + :from-end t) + 6) +(eql (position-if-not #'(lambda (x) (not (eq x 'a))) + '((a) (b) (c) (a a) (b b) (c c) (a a a)) + :key #'car + :from-end t + :end nil) + 6) +(eql (position-if-not #'(lambda (x) (not (eq x 'a))) + '((a) (b) (c) (a a) (b b) (c c) (a a a)) + :key #'car + :from-end t + :end 6) + 3) +(null (position-if-not #'(lambda (x) (not (eq x 'a))) + '((a) (b) (c) (a a) (b b) (c c) (a a a)) + :key #'car + :from-end t + :start 1 + :end 3)) +(null (position-if-not #'(lambda (x) (not (eql x #\c))) '("abc" "bcd" "cde"))) +(eql (position-if-not #'(lambda (x) (not (eql x #\c))) '("abc" "bcd" "cde") + :key #'(lambda (arg) (char arg 0))) + 2) +(eql (position-if-not #'(lambda (x) (not (char> #\c x))) '("abc" "bcd" "cde") + :key #'(lambda (arg) (char arg 0))) + 0) +(eql (position-if-not #'(lambda (x) (not (char> #\c x))) '("abc" "bcd" "cde") + :start 1 + :key #'(lambda (arg) (char arg 0))) + 1) + +(eql (position-if-not #'(lambda (x) (not (eq x 'a))) #(a b c)) 0) +(eql (position-if-not #'(lambda (x) (not (eq x 'b))) #(a b c)) 1) +(eql (position-if-not #'(lambda (x) (not (eq x 'c))) #(a b c)) 2) +(null (position-if-not #'(lambda (arg) (not (eq arg 'x))) #(a b c))) +(null (position-if-not #'(lambda (x) (not (eq x 'a))) #(a b c) :start 1)) +(null (position-if-not #'(lambda (x) (not (eq x 'b))) #(a b c) :start 2)) +(null (position-if-not #'(lambda (x) (not (eq x 'c))) #(a b c) :start 3)) +(null (position-if-not #'(lambda (x) (not (eq x 'a))) #(a b c) :start 0 :end 0)) +(null (position-if-not #'(lambda (x) (not (eq x 'a))) #(a b c) :start 0 :end 0 + :from-end t)) +(null (position-if-not #'(lambda (x) (not (eq x 'a))) #(a b c) :start 1 :end 1)) +(null (position-if-not #'(lambda (x) (not (eq x 'a))) #(a b c) :start 1 :end 1 + :from-end t)) +(null (position-if-not #'(lambda (x) (not (eq x 'a))) #(a b c) :start 2 :end 2)) +(null (position-if-not #'(lambda (x) (not (eq x 'a))) #(a b c) :start 2 :end 2 + :from-end t)) +(null (position-if-not #'(lambda (x) (not (eq x 'a))) #(a b c) :start 3 :end 3)) +(null (position-if-not #'(lambda (x) (not (eq x 'a))) #(a b c) :start 3 :end 3 + :from-end t)) +(eql (position-if-not #'(lambda (x) (not (eq x 'a))) #(a b c) :end nil) 0) +(eql (position-if-not #'(lambda (x) (not (eq x 'b))) #(a b c) :end nil) 1) +(eql (position-if-not #'(lambda (x) (not (eq x 'c))) #(a b c) :end nil) 2) +(eql (position-if-not #'(lambda (x) (not (eq x 'a))) #(a b c) :end 1) 0) +(eql (position-if-not #'(lambda (x) (not (eq x 'b))) #(a b c) :end 2) 1) +(eql (position-if-not #'(lambda (x) (not (eq x 'c))) #(a b c) :end 3) 2) +(null (position-if-not #'(lambda (x) (not (eq x 'a))) #(a b c) :end 0)) +(null (position-if-not #'(lambda (x) (not (eq x 'b))) #(a b c) :end 1)) +(null (position-if-not #'(lambda (x) (not (eq x 'c))) #(a b c) :end 2)) +(null (position-if-not #'(lambda (x) (not (eq x 'a))) #((a) (b) (c)))) +(eql (position-if-not #'(lambda (x) (not (eq x 'a))) #((a) (b) (c)) :key #'car) + 0) +(eql (position-if-not #'(lambda (x) (not (eq x 'b))) #((a) (b) (c)) :key #'car) + 1) +(eql (position-if-not #'(lambda (x) (not (eq x 'c))) #((a) (b) (c)) :key #'car) + 2) +(null (position-if-not #'(lambda (x) (not (eq x 'z))) #((a) (b) (c)) + :key #'car)) +(eql (position-if-not #'(lambda (x) (not (eq x 'a))) + #((a) (b) (c) (a a) (b b) (c c)) :key #'car) + 0) +(eql (position-if-not #'(lambda (x) (not (eq x 'a))) + #((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t) + 3) +(eql (position-if-not #'(lambda (x) (not (eq x 'b))) + #((a) (b) (c) (a a) (b b) (c c)) :key #'car) + 1) +(eql (position-if-not #'(lambda (x) (not (eq x 'b))) + #((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t) + 4) +(eql (position-if-not #'(lambda (x) (not (eq x 'c))) + #((a) (b) (c) (a a) (b b) (c c)) :key #'car) + 2) +(eql (position-if-not #'(lambda (x) (not (eq x 'c))) + #((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t) + 5) +(null (position-if-not #'(lambda (x) (not (eq x 'z))) + #((a) (b) (c) (a a) (b b) (c c)) :key #'car)) +(null (position-if-not #'(lambda (x) (not (eq x 'z))) + #((a) (b) (c) (a a) (b b) (c c)) :key #'car :from-end t)) +(eql (position-if-not #'(lambda (x) (not (eq x 'a))) + #((a) (b) (c) (a a) (b b) (c c) (a a a)) + :key #'car + :from-end t) + 6) +(eql (position-if-not #'(lambda (x) (not (eq x 'a))) + #((a) (b) (c) (a a) (b b) (c c) (a a a)) + :key #'car + :from-end t + :end nil) + 6) +(eql (position-if-not #'(lambda (x) (not (eq x 'a))) + #((a) (b) (c) (a a) (b b) (c c) (a a a)) + :key #'car + :from-end t + :end 6) + 3) +(null (position-if-not #'(lambda (x) (not (eq x 'a))) + #((a) (b) (c) (a a) (b b) (c c) (a a a)) + :key #'car + :from-end t + :start 1 + :end 3)) +(eql (position-if-not #'(lambda (x) (not (eql x #\c))) #("abc" "bcd" "cde") + :key #'(lambda (arg) (char arg 0))) + 2) +(eql (position-if-not #'(lambda (x) (not (char> #\c x))) #("abc" "bcd" "cde") + :key #'(lambda (arg) (char arg 0))) + 0) +(eql (position-if-not #'(lambda (x) (not (char> #\c x))) #("abc" "bcd" "cde") + :start 1 + :key #'(lambda (arg) (char arg 0))) + 1) + + + +(eql (search "dog" "it's a dog's life") 7) +(eql (search '(0 1) '(2 4 6 1 3 5) :key #'oddp) 2) + + +(eql (search '() '()) 0) +(null (search '(a b c) '(x y z))) +(eql (search '() '(x y z)) 0) +(eql (search '(a) '(a)) 0) +(eql (search '(a b c) '(a b c x y z)) 0) +(eql (search '(a b c) '(x a b c y z)) 1) +(eql (search '(a b c) '(x y a b c z)) 2) +(eql (search '(a b c) '(x y z a b c)) 3) +(eql (search '(a b c) '(a b c a b c) :start2 1) 3) +(eql (search '(a b c) '(a b c a b c) :start2 1 :end2 nil) 3) +(eql (search '(a b c) '(a b c a b c) :start1 1 :start2 1 :end2 nil) 1) +(eql (search '(a b c) '(a b c a b c) :start1 1 :end1 nil :start2 1 :end2 nil) 1) +(null (search '(a b c) '(a b c a b c) :start2 0 :end2 0)) +(null (search '(a b c) '(a b c a b c) :start2 1 :end2 1)) +(null (search '(a b c) '(a b c a b c) :start2 2 :end2 2)) +(null (search '(a b c) '(a b c a b c) :start2 3 :end2 3)) +(null (search '(a b c) '(a b c a b c) :start2 4 :end2 4)) +(null (search '(a b c) '(a b c a b c) :start2 5 :end2 5)) +(null (search '(a b c) '(a b c a b c) :start2 6 :end2 6)) +(eql (search '(a b c) '(a b c a b c)) 0) +(eql (search '(a b c) '(a b c a b c) :from-end t) 3) +(eql (search '(a b c) '(a b c a b c) :start2 3 :end2 6) 3) +(eql (search '(a b c) '(a b c a b c) :start2 3 :end2 6 :from-end t) 3) +(eql (search '(a b c) '(a b c a b c) + :start1 0 :end1 2 :start2 0 :end2 6) + 0) +(eql (search '(a b c) '(a b c a b c) + :start1 0 :end1 2 :start2 0 :end2 6 :from-end t) + 3) +(eql (search '(a b c) '(a b c a b c) :start1 0 :end1 0 :start2 0 :end2 0) 0) +(eql (search '(a b c) '(a b c a b c) :start1 1 :end1 1 :start2 0 :end2 0) 0) +(eql (search '(a b c) '(a b c a b c) :start1 2 :end1 2 :start2 0 :end2 0) 0) +(eql (search '(a b c) '(a b c a b c) :start1 3 :end1 3 :start2 0 :end2 0) 0) +(eql (search '(a b c) '(a b c a b c) :start1 0 :end1 0 :start2 1 :end2 1) 1) +(eql (search '(a b c) '(a b c a b c) :start1 1 :end1 1 :start2 1 :end2 1) 1) +(eql (search '(a b c) '(a b c a b c) :start1 2 :end1 2 :start2 1 :end2 1) 1) +(eql (search '(a b c) '(a b c a b c) :start1 3 :end1 3 :start2 1 :end2 1) 1) +(eql (search '(a b c) '(a b c a b c) :start1 0 :end1 0 :start2 6 :end2 6) 6) +(eql (search '(a b c) '(a b c a b c) :start1 1 :end1 1 :start2 6 :end2 6) 6) +(eql (search '(a b c) '(a b c a b c) :start1 2 :end1 2 :start2 6 :end2 6) 6) +(eql (search '(a b c) '(a b c a b c) :start1 3 :end1 3 :start2 6 :end2 6) 6) + +(eql (search '(a b c) '(a b c a b c) :start1 0 :end1 0 :start2 0 :end2 0 + :from-end t) 0) +(eql (search '(a b c) '(a b c a b c) :start1 1 :end1 1 :start2 0 :end2 0 + :from-end t) 0) +(eql (search '(a b c) '(a b c a b c) :start1 2 :end1 2 :start2 0 :end2 0 + :from-end t) 0) +(eql (search '(a b c) '(a b c a b c) :start1 3 :end1 3 :start2 0 :end2 0 + :from-end t) 0) +(eql (search '(a b c) '(a b c a b c) :start1 0 :end1 0 :start2 1 :end2 1 + :from-end t) 1) +(eql (search '(a b c) '(a b c a b c) :start1 1 :end1 1 :start2 1 :end2 1 + :from-end t) 1) +(eql (search '(a b c) '(a b c a b c) :start1 2 :end1 2 :start2 1 :end2 1 + :from-end t) 1) +(eql (search '(a b c) '(a b c a b c) :start1 3 :end1 3 :start2 1 :end2 1 + :from-end t) 1) +(eql (search '(a b c) '(a b c a b c) :start1 0 :end1 0 :start2 6 :end2 6 + :from-end t) 6) +(eql (search '(a b c) '(a b c a b c) :start1 1 :end1 1 :start2 6 :end2 6 + :from-end t) 6) +(eql (search '(a b c) '(a b c a b c) :start1 2 :end1 2 :start2 6 :end2 6 + :from-end t) 6) +(eql (search '(a b c) '(a b c a b c) :start1 3 :end1 3 :start2 6 :end2 6 + :from-end t) 6) + +(null (search '(#\a #\b #\c) '(#\A #\B #\C))) +(eql (search '(#\a #\b #\c) '(#\A #\B #\C) :test #'char-equal) 0) +(eql (search '(#\a #\b #\c) '(#\A #\B #\C) :test-not (complement #'char-equal)) + 0) +(eql (search '(#\a #\b) '(#\a #\b #\x #\y #\z)) 0) +(eql (search '(#\a #\b) '(#\a #\b #\x #\y #\z) :test #'char<) 1) +(eql (search '(#\a #\b) '(#\a #\b #\x #\y #\z) :test-not (complement #'char<)) + 1) +(eql (search '(#\a #\b) '(#\a #\b #\x #\y #\z) + :test-not (complement #'char<) + :from-end t) + 3) + +(null (search '((a) (b)) '((x) (y) (z) (a) (b) (c)))) +(eql (search '((a) (b)) '((x) (y) (z) (a) (b) (c)) :key #'car) 3) +(eql (search '((a) (b)) '((a) (b) (c) (x) (y) (z) (a) (b) (c)) :key #'car) + 0) +(eql (search '((a) (b)) '((a) (b) (c) (x) (y) (z) (a) (b) (c)) + :key #'car + :from-end t) + 6) + +(eql (search '((a a) (b b)) '((a) (b) (c) (x) (y) (z) (a) (b) (c)) :key #'car) + 0) +(eql (search '((a a) (b b)) + '((a nil) (b t) (c nil) (x) (y) (z) (a 0) (b 1) (c 2)) + :key #'car + :from-end t) + 6) + +(eql (search '(("a" a) ("b" b)) + '(("a" nil) ("b" t) ("c" nil) ("x") ("y") ("z") + ("A" 0) ("B" 1) ("C" 2)) + :start1 1 + :end1 2 + :start2 3 + :end2 nil + :key #'car + :test #'string-equal + :from-end t) + 7) + + +(eql (search #() '()) 0) +(null (search #(a b c) '(x y z))) +(eql (search #() '(x y z)) 0) +(eql (search #(a) '(a)) 0) +(eql (search #(a b c) '(a b c x y z)) 0) +(eql (search #(a b c) '(x a b c y z)) 1) +(eql (search #(a b c) '(x y a b c z)) 2) +(eql (search #(a b c) '(x y z a b c)) 3) +(eql (search #(a b c) '(a b c a b c) :start2 1) 3) +(eql (search #(a b c) '(a b c a b c) :start2 1 :end2 nil) 3) +(eql (search #(a b c) '(a b c a b c) :start1 1 :start2 1 :end2 nil) 1) +(eql (search #(a b c) '(a b c a b c) :start1 1 :end1 nil :start2 1 :end2 nil) 1) +(null (search #(a b c) '(a b c a b c) :start2 0 :end2 0)) +(null (search #(a b c) '(a b c a b c) :start2 1 :end2 1)) +(null (search #(a b c) '(a b c a b c) :start2 2 :end2 2)) +(null (search #(a b c) '(a b c a b c) :start2 3 :end2 3)) +(null (search #(a b c) '(a b c a b c) :start2 4 :end2 4)) +(null (search #(a b c) '(a b c a b c) :start2 5 :end2 5)) +(null (search #(a b c) '(a b c a b c) :start2 6 :end2 6)) +(eql (search #(a b c) '(a b c a b c)) 0) +(eql (search #(a b c) '(a b c a b c) :from-end t) 3) +(eql (search #(a b c) '(a b c a b c) :start2 3 :end2 6) 3) +(eql (search #(a b c) '(a b c a b c) :start2 3 :end2 6 :from-end t) 3) +(eql (search #(a b c) '(a b c a b c) + :start1 0 :end1 2 :start2 0 :end2 6) + 0) +(eql (search #(a b c) '(a b c a b c) + :start1 0 :end1 2 :start2 0 :end2 6 :from-end t) + 3) +(eql (search #(a b c) '(a b c a b c) :start1 0 :end1 0 :start2 0 :end2 0) 0) +(eql (search #(a b c) '(a b c a b c) :start1 1 :end1 1 :start2 0 :end2 0) 0) +(eql (search #(a b c) '(a b c a b c) :start1 2 :end1 2 :start2 0 :end2 0) 0) +(eql (search #(a b c) '(a b c a b c) :start1 3 :end1 3 :start2 0 :end2 0) 0) +(eql (search #(a b c) '(a b c a b c) :start1 0 :end1 0 :start2 1 :end2 1) 1) +(eql (search #(a b c) '(a b c a b c) :start1 1 :end1 1 :start2 1 :end2 1) 1) +(eql (search #(a b c) '(a b c a b c) :start1 2 :end1 2 :start2 1 :end2 1) 1) +(eql (search #(a b c) '(a b c a b c) :start1 3 :end1 3 :start2 1 :end2 1) 1) +(eql (search #(a b c) '(a b c a b c) :start1 0 :end1 0 :start2 6 :end2 6) 6) +(eql (search #(a b c) '(a b c a b c) :start1 1 :end1 1 :start2 6 :end2 6) 6) +(eql (search #(a b c) '(a b c a b c) :start1 2 :end1 2 :start2 6 :end2 6) 6) +(eql (search #(a b c) '(a b c a b c) :start1 3 :end1 3 :start2 6 :end2 6) 6) + +(eql (search #(a b c) '(a b c a b c) :start1 0 :end1 0 :start2 0 :end2 0 + :from-end t) 0) +(eql (search #(a b c) '(a b c a b c) :start1 1 :end1 1 :start2 0 :end2 0 + :from-end t) 0) +(eql (search #(a b c) '(a b c a b c) :start1 2 :end1 2 :start2 0 :end2 0 + :from-end t) 0) +(eql (search #(a b c) '(a b c a b c) :start1 3 :end1 3 :start2 0 :end2 0 + :from-end t) 0) +(eql (search #(a b c) '(a b c a b c) :start1 0 :end1 0 :start2 1 :end2 1 + :from-end t) 1) +(eql (search #(a b c) '(a b c a b c) :start1 1 :end1 1 :start2 1 :end2 1 + :from-end t) 1) +(eql (search #(a b c) '(a b c a b c) :start1 2 :end1 2 :start2 1 :end2 1 + :from-end t) 1) +(eql (search #(a b c) '(a b c a b c) :start1 3 :end1 3 :start2 1 :end2 1 + :from-end t) 1) +(eql (search #(a b c) '(a b c a b c) :start1 0 :end1 0 :start2 6 :end2 6 + :from-end t) 6) +(eql (search #(a b c) '(a b c a b c) :start1 1 :end1 1 :start2 6 :end2 6 + :from-end t) 6) +(eql (search #(a b c) '(a b c a b c) :start1 2 :end1 2 :start2 6 :end2 6 + :from-end t) 6) +(eql (search #(a b c) '(a b c a b c) :start1 3 :end1 3 :start2 6 :end2 6 + :from-end t) 6) + +(null (search #(#\a #\b #\c) '(#\A #\B #\C))) +(eql (search #(#\a #\b #\c) '(#\A #\B #\C) :test #'char-equal) 0) +(eql (search #(#\a #\b #\c) '(#\A #\B #\C) :test-not (complement #'char-equal)) + 0) +(eql (search #(#\a #\b) '(#\a #\b #\x #\y #\z)) 0) +(eql (search #(#\a #\b) '(#\a #\b #\x #\y #\z) :test #'char<) 1) +(eql (search #(#\a #\b) '(#\a #\b #\x #\y #\z) :test-not (complement #'char<)) + 1) +(eql (search #(#\a #\b) '(#\a #\b #\x #\y #\z) + :test-not (complement #'char<) + :from-end t) + 3) + +(null (search #((a) (b)) '((x) (y) (z) (a) (b) (c)))) +(eql (search #((a) (b)) '((x) (y) (z) (a) (b) (c)) :key #'car) 3) +(eql (search #((a) (b)) '((a) (b) (c) (x) (y) (z) (a) (b) (c)) :key #'car) + 0) +(eql (search #((a) (b)) '((a) (b) (c) (x) (y) (z) (a) (b) (c)) + :key #'car + :from-end t) + 6) + +(eql (search #((a a) (b b)) '((a) (b) (c) (x) (y) (z) (a) (b) (c)) :key #'car) + 0) +(eql (search #((a a) (b b)) + '((a nil) (b t) (c nil) (x) (y) (z) (a 0) (b 1) (c 2)) + :key #'car + :from-end t) + 6) + +(eql (search #(("a" a) ("b" b)) + '(("a" nil) ("b" t) ("c" nil) ("x") ("y") ("z") + ("A" 0) ("B" 1) ("C" 2)) + :start1 1 + :end1 2 + :start2 3 + :end2 nil + :key #'car + :test #'string-equal + :from-end t) + 7) + + +(eql (search '() #()) 0) +(null (search '(a b c) #(x y z))) +(eql (search '() #(x y z)) 0) +(eql (search '(a) #(a)) 0) +(eql (search '(a b c) #(a b c x y z)) 0) +(eql (search '(a b c) #(x a b c y z)) 1) +(eql (search '(a b c) #(x y a b c z)) 2) +(eql (search '(a b c) #(x y z a b c)) 3) +(eql (search '(a b c) #(a b c a b c) :start2 1) 3) +(eql (search '(a b c) #(a b c a b c) :start2 1 :end2 nil) 3) +(eql (search '(a b c) #(a b c a b c) :start1 1 :start2 1 :end2 nil) 1) +(eql (search '(a b c) #(a b c a b c) :start1 1 :end1 nil :start2 1 :end2 nil) 1) +(null (search '(a b c) #(a b c a b c) :start2 0 :end2 0)) +(null (search '(a b c) #(a b c a b c) :start2 1 :end2 1)) +(null (search '(a b c) #(a b c a b c) :start2 2 :end2 2)) +(null (search '(a b c) #(a b c a b c) :start2 3 :end2 3)) +(null (search '(a b c) #(a b c a b c) :start2 4 :end2 4)) +(null (search '(a b c) #(a b c a b c) :start2 5 :end2 5)) +(null (search '(a b c) #(a b c a b c) :start2 6 :end2 6)) +(eql (search '(a b c) #(a b c a b c)) 0) +(eql (search '(a b c) #(a b c a b c) :from-end t) 3) +(eql (search '(a b c) #(a b c a b c) :start2 3 :end2 6) 3) +(eql (search '(a b c) #(a b c a b c) :start2 3 :end2 6 :from-end t) 3) +(eql (search '(a b c) #(a b c a b c) + :start1 0 :end1 2 :start2 0 :end2 6) + 0) +(eql (search '(a b c) #(a b c a b c) + :start1 0 :end1 2 :start2 0 :end2 6 :from-end t) + 3) +(eql (search '(a b c) #(a b c a b c) :start1 0 :end1 0 :start2 0 :end2 0) 0) +(eql (search '(a b c) #(a b c a b c) :start1 1 :end1 1 :start2 0 :end2 0) 0) +(eql (search '(a b c) #(a b c a b c) :start1 2 :end1 2 :start2 0 :end2 0) 0) +(eql (search '(a b c) #(a b c a b c) :start1 3 :end1 3 :start2 0 :end2 0) 0) +(eql (search '(a b c) #(a b c a b c) :start1 0 :end1 0 :start2 1 :end2 1) 1) +(eql (search '(a b c) #(a b c a b c) :start1 1 :end1 1 :start2 1 :end2 1) 1) +(eql (search '(a b c) #(a b c a b c) :start1 2 :end1 2 :start2 1 :end2 1) 1) +(eql (search '(a b c) #(a b c a b c) :start1 3 :end1 3 :start2 1 :end2 1) 1) +(eql (search '(a b c) #(a b c a b c) :start1 0 :end1 0 :start2 6 :end2 6) 6) +(eql (search '(a b c) #(a b c a b c) :start1 1 :end1 1 :start2 6 :end2 6) 6) +(eql (search '(a b c) #(a b c a b c) :start1 2 :end1 2 :start2 6 :end2 6) 6) +(eql (search '(a b c) #(a b c a b c) :start1 3 :end1 3 :start2 6 :end2 6) 6) + +(eql (search '(a b c) #(a b c a b c) :start1 0 :end1 0 :start2 0 :end2 0 + :from-end t) 0) +(eql (search '(a b c) #(a b c a b c) :start1 1 :end1 1 :start2 0 :end2 0 + :from-end t) 0) +(eql (search '(a b c) #(a b c a b c) :start1 2 :end1 2 :start2 0 :end2 0 + :from-end t) 0) +(eql (search '(a b c) #(a b c a b c) :start1 3 :end1 3 :start2 0 :end2 0 + :from-end t) 0) +(eql (search '(a b c) #(a b c a b c) :start1 0 :end1 0 :start2 1 :end2 1 + :from-end t) 1) +(eql (search '(a b c) #(a b c a b c) :start1 1 :end1 1 :start2 1 :end2 1 + :from-end t) 1) +(eql (search '(a b c) #(a b c a b c) :start1 2 :end1 2 :start2 1 :end2 1 + :from-end t) 1) +(eql (search '(a b c) #(a b c a b c) :start1 3 :end1 3 :start2 1 :end2 1 + :from-end t) 1) +(eql (search '(a b c) #(a b c a b c) :start1 0 :end1 0 :start2 6 :end2 6 + :from-end t) 6) +(eql (search '(a b c) #(a b c a b c) :start1 1 :end1 1 :start2 6 :end2 6 + :from-end t) 6) +(eql (search '(a b c) #(a b c a b c) :start1 2 :end1 2 :start2 6 :end2 6 + :from-end t) 6) +(eql (search '(a b c) #(a b c a b c) :start1 3 :end1 3 :start2 6 :end2 6 + :from-end t) 6) + +(null (search '(#\a #\b #\c) #(#\A #\B #\C))) +(eql (search '(#\a #\b #\c) #(#\A #\B #\C) :test #'char-equal) 0) +(eql (search '(#\a #\b #\c) #(#\A #\B #\C) :test-not (complement #'char-equal)) + 0) +(eql (search '(#\a #\b) #(#\a #\b #\x #\y #\z)) 0) +(eql (search '(#\a #\b) #(#\a #\b #\x #\y #\z) :test #'char<) 1) +(eql (search '(#\a #\b) #(#\a #\b #\x #\y #\z) :test-not (complement #'char<)) + 1) +(eql (search '(#\a #\b) #(#\a #\b #\x #\y #\z) + :test-not (complement #'char<) + :from-end t) + 3) + +(null (search '((a) (b)) #((x) (y) (z) (a) (b) (c)))) +(eql (search '((a) (b)) #((x) (y) (z) (a) (b) (c)) :key #'car) 3) +(eql (search '((a) (b)) #((a) (b) (c) (x) (y) (z) (a) (b) (c)) :key #'car) + 0) +(eql (search '((a) (b)) #((a) (b) (c) (x) (y) (z) (a) (b) (c)) + :key #'car + :from-end t) + 6) + +(eql (search '((a a) (b b)) #((a) (b) (c) (x) (y) (z) (a) (b) (c)) :key #'car) + 0) +(eql (search '((a a) (b b)) + #((a nil) (b t) (c nil) (x) (y) (z) (a 0) (b 1) (c 2)) + :key #'car + :from-end t) + 6) + +(eql (search '(("a" a) ("b" b)) + #(("a" nil) ("b" t) ("c" nil) ("x") ("y") ("z") + ("A" 0) ("B" 1) ("C" 2)) + :start1 1 + :end1 2 + :start2 3 + :end2 nil + :key #'car + :test #'string-equal + :from-end t) + 7) + + +(eql (search #() #()) 0) +(null (search #(a b c) #(x y z))) +(eql (search #() #(x y z)) 0) +(eql (search #(a) #(a)) 0) +(eql (search #(a b c) #(a b c x y z)) 0) +(eql (search #(a b c) #(x a b c y z)) 1) +(eql (search #(a b c) #(x y a b c z)) 2) +(eql (search #(a b c) #(x y z a b c)) 3) +(eql (search #(a b c) #(a b c a b c) :start2 1) 3) +(eql (search #(a b c) #(a b c a b c) :start2 1 :end2 nil) 3) +(eql (search #(a b c) #(a b c a b c) :start1 1 :start2 1 :end2 nil) 1) +(eql (search #(a b c) #(a b c a b c) :start1 1 :end1 nil :start2 1 :end2 nil) 1) +(null (search #(a b c) #(a b c a b c) :start2 0 :end2 0)) +(null (search #(a b c) #(a b c a b c) :start2 1 :end2 1)) +(null (search #(a b c) #(a b c a b c) :start2 2 :end2 2)) +(null (search #(a b c) #(a b c a b c) :start2 3 :end2 3)) +(null (search #(a b c) #(a b c a b c) :start2 4 :end2 4)) +(null (search #(a b c) #(a b c a b c) :start2 5 :end2 5)) +(null (search #(a b c) #(a b c a b c) :start2 6 :end2 6)) +(eql (search #(a b c) #(a b c a b c)) 0) +(eql (search #(a b c) #(a b c a b c) :from-end t) 3) +(eql (search #(a b c) #(a b c a b c) :start2 3 :end2 6) 3) +(eql (search #(a b c) #(a b c a b c) :start2 3 :end2 6 :from-end t) 3) +(eql (search #(a b c) #(a b c a b c) + :start1 0 :end1 2 :start2 0 :end2 6) + 0) +(eql (search #(a b c) #(a b c a b c) + :start1 0 :end1 2 :start2 0 :end2 6 :from-end t) + 3) +(eql (search #(a b c) #(a b c a b c) :start1 0 :end1 0 :start2 0 :end2 0) 0) +(eql (search #(a b c) #(a b c a b c) :start1 1 :end1 1 :start2 0 :end2 0) 0) +(eql (search #(a b c) #(a b c a b c) :start1 2 :end1 2 :start2 0 :end2 0) 0) +(eql (search #(a b c) #(a b c a b c) :start1 3 :end1 3 :start2 0 :end2 0) 0) +(eql (search #(a b c) #(a b c a b c) :start1 0 :end1 0 :start2 1 :end2 1) 1) +(eql (search #(a b c) #(a b c a b c) :start1 1 :end1 1 :start2 1 :end2 1) 1) +(eql (search #(a b c) #(a b c a b c) :start1 2 :end1 2 :start2 1 :end2 1) 1) +(eql (search #(a b c) #(a b c a b c) :start1 3 :end1 3 :start2 1 :end2 1) 1) +(eql (search #(a b c) #(a b c a b c) :start1 0 :end1 0 :start2 6 :end2 6) 6) +(eql (search #(a b c) #(a b c a b c) :start1 1 :end1 1 :start2 6 :end2 6) 6) +(eql (search #(a b c) #(a b c a b c) :start1 2 :end1 2 :start2 6 :end2 6) 6) +(eql (search #(a b c) #(a b c a b c) :start1 3 :end1 3 :start2 6 :end2 6) 6) + +(eql (search #(a b c) #(a b c a b c) :start1 0 :end1 0 :start2 0 :end2 0 + :from-end t) 0) +(eql (search #(a b c) #(a b c a b c) :start1 1 :end1 1 :start2 0 :end2 0 + :from-end t) 0) +(eql (search #(a b c) #(a b c a b c) :start1 2 :end1 2 :start2 0 :end2 0 + :from-end t) 0) +(eql (search #(a b c) #(a b c a b c) :start1 3 :end1 3 :start2 0 :end2 0 + :from-end t) 0) +(eql (search #(a b c) #(a b c a b c) :start1 0 :end1 0 :start2 1 :end2 1 + :from-end t) 1) +(eql (search #(a b c) #(a b c a b c) :start1 1 :end1 1 :start2 1 :end2 1 + :from-end t) 1) +(eql (search #(a b c) #(a b c a b c) :start1 2 :end1 2 :start2 1 :end2 1 + :from-end t) 1) +(eql (search #(a b c) #(a b c a b c) :start1 3 :end1 3 :start2 1 :end2 1 + :from-end t) 1) +(eql (search #(a b c) #(a b c a b c) :start1 0 :end1 0 :start2 6 :end2 6 + :from-end t) 6) +(eql (search #(a b c) #(a b c a b c) :start1 1 :end1 1 :start2 6 :end2 6 + :from-end t) 6) +(eql (search #(a b c) #(a b c a b c) :start1 2 :end1 2 :start2 6 :end2 6 + :from-end t) 6) +(eql (search #(a b c) #(a b c a b c) :start1 3 :end1 3 :start2 6 :end2 6 + :from-end t) 6) + +(null (search #(#\a #\b #\c) #(#\A #\B #\C))) +(eql (search #(#\a #\b #\c) #(#\A #\B #\C) :test #'char-equal) 0) +(eql (search #(#\a #\b #\c) #(#\A #\B #\C) :test-not (complement #'char-equal)) + 0) +(eql (search #(#\a #\b) #(#\a #\b #\x #\y #\z)) 0) +(eql (search #(#\a #\b) #(#\a #\b #\x #\y #\z) :test #'char<) 1) +(eql (search #(#\a #\b) #(#\a #\b #\x #\y #\z) :test-not (complement #'char<)) + 1) +(eql (search #(#\a #\b) #(#\a #\b #\x #\y #\z) + :test-not (complement #'char<) + :from-end t) + 3) + +(null (search #((a) (b)) #((x) (y) (z) (a) (b) (c)))) +(eql (search #((a) (b)) #((x) (y) (z) (a) (b) (c)) :key #'car) 3) +(eql (search #((a) (b)) #((a) (b) (c) (x) (y) (z) (a) (b) (c)) :key #'car) + 0) +(eql (search #((a) (b)) #((a) (b) (c) (x) (y) (z) (a) (b) (c)) + :key #'car + :from-end t) + 6) + +(eql (search #((a a) (b b)) #((a) (b) (c) (x) (y) (z) (a) (b) (c)) :key #'car) + 0) +(eql (search #((a a) (b b)) + #((a nil) (b t) (c nil) (x) (y) (z) (a 0) (b 1) (c 2)) + :key #'car + :from-end t) + 6) + +(eql (search #(("a" a) ("b" b)) + #(("a" nil) ("b" t) ("c" nil) ("x") ("y") ("z") + ("A" 0) ("B" 1) ("C" 2)) + :start1 1 + :end1 2 + :start2 3 + :end2 nil + :key #'car + :test #'string-equal + :from-end t) + 7) + + +(null (search "peace" "LOVE&PEACE")) +(eql (search "peace" "LOVE&PEACE" :test #'char-equal) 5) +(eql (search (concatenate 'simple-vector "peace") + (concatenate 'list "LOVE&PEACE") :test #'char-equal) + 5) +(eql (search (concatenate 'list "peace") + (concatenate 'vector "LOVE&PEACE") :test #'char-equal) + 5) +(eql (search (concatenate 'vector "peace") + (concatenate 'vector "LOVE&PEACE") :test #'char-equal) + 5) + +(eql (search #*10 #*010101) 1) +(eql (search #*10 #*010101 :from-end t) 3) + + +(null (search "PeAcE" "LoVe&pEaCe")) +(eql (search "PeAcE" "LoVe&pEaCe" :key #'char-upcase) 5) +(eql (search "abc" "abc xyz abc" :from-end t) 8) +(eql (search "abc" "abc xyz abc xyz abc xyz abc" + :start2 8 + :end2 19) + 8) +(eql (search "abc" "abc xyz abc xyz abc xyz abc" + :from-end t + :start2 8 + :end2 19) + 16) + + + +(eql (mismatch "abcd" "ABCDE" :test #'char-equal) 4) +(eql (mismatch '(3 2 1 1 2 3) '(1 2 3) :from-end t) 3) +(null (mismatch '(1 2 3) '(2 3 4) :test-not #'eq :key #'oddp)) +(null (mismatch '(1 2 3 4 5 6) '(3 4 5 6 7) :start1 2 :end2 4)) + + +(null (mismatch '() '())) +(eql (mismatch '(a b c) '(x y z)) 0) +(eql (mismatch '() '(x y z)) 0) +(eql (mismatch '(x y z) '()) 0) +(null (mismatch '(a) '(a))) +(eql (mismatch '(a b c x y z) '(a b c)) 3) +(null (mismatch '(a b c) '(a b c))) +(eql (mismatch '(a b c d e f) '(a b c)) 3) +(eql (mismatch '(a b c) '(a b c d e f)) 3) +(eql (mismatch '(a b c) '(a b x)) 2) +(eql (mismatch '(a b c) '(a x c)) 1) +(eql (mismatch '(a b c) '(x b c)) 0) +(eql (mismatch '(x y z a b c x y z) '(a b c) :start1 3) 6) +(eql (mismatch '(x y z a b c x y z) '(a b c) :start1 3 :end1 nil) 6) +(eql (mismatch '(x y z a b c x y z) '(a b c) :start1 3 :end1 4) 4) +(eql (mismatch '(x y z a b c x y z) '(a b c) :start1 3 :end1 3) 3) +(null (mismatch '(x y z) '() :start1 0 :end1 0)) +(null (mismatch '(x y z) '() :start1 1 :end1 1)) +(null (mismatch '(x y z) '() :start1 2 :end1 2)) +(null (mismatch '(x y z) '() :start1 3 :end1 3)) +(null (mismatch '(x y z) '() :start1 0 :end1 0 :start2 0 :end2 0)) +(null (mismatch '(x y z) '() :start1 1 :end1 1 :start2 1 :end2 1)) +(null (mismatch '(x y z) '() :start1 2 :end1 2 :start2 2 :end2 2)) +(null (mismatch '(x y z) '() :start1 3 :end1 3 :start2 3 :end2 3)) +(null (mismatch '(x y z) '() :start1 0 :end1 0 :start2 3 :end2 3)) +(null (mismatch '(x y z) '() :start1 1 :end1 1 :start2 2 :end2 2)) +(null (mismatch '(x y z) '() :start1 2 :end1 2 :start2 1 :end2 1)) +(null (mismatch '(x y z) '() :start1 3 :end1 3 :start2 0 :end2 0)) +(eql (mismatch '(x y z) '(a b c) :start1 0 :end1 0) 0) +(eql (mismatch '(x y z) '(a b c) :start1 1 :end1 1) 1) +(eql (mismatch '(x y z) '(a b c) :start1 2 :end1 2) 2) +(eql (mismatch '(x y z) '(a b c) :start1 3 :end1 3) 3) +(eql (mismatch '(x y z) '(x y z) :start1 0 :end1 1) 1) +(eql (mismatch '(x y z) '(x y z) :start1 0 :end1 2) 2) +(eql (mismatch '(x y z) '(x y z Z) :start1 0 :end1 3) 3) +(null (mismatch '(x y z) '(x y z) :start1 0 :end1 3)) +(eql (mismatch '(a b c x y z) '(x y z a b c)) 0) +(eql (mismatch '(a b c x y z) '(x y z a b c) :start1 3) 6) +(eql (mismatch '(a b c x y z a b c) '(x y z a b c x y z) :start1 3) 9) +(eql (mismatch '(a b c x y z a b c) '(x y z a b c x y z) :start1 6) 6) +(eql (mismatch '(a b c x y z a b c) '(x y z a b c x y z) :start1 6 :start2 3) + 9) +(eql (mismatch '(a b c x y z a b c) '(x y z a b c x y z) :start1 0 :start2 3) + 6) +(eql (mismatch '(a b c) '(a b c x y z)) 3) +(eql (mismatch '(a b c) '(x a b c y z)) 0) +(eql (mismatch '(a b c) '(x a b c y z) :start2 1) 3) +(eql (mismatch '(a b c) '(x a b c y z) :start2 1 :end2 nil) 3) +(null (mismatch '(a b c) '(x a b c y z) :start2 1 :end2 4)) + +(eql (mismatch '(a b c d e) '(c d)) 0) +(eql (mismatch '(a b c d e) '(c d) :start1 2) 4) +(eql (mismatch '(a b c d e) '(c d) :start1 2 :end1 3) 3) +(eql (mismatch '(a b c d e) '(c d) :start1 2 :start2 1) 2) +(eql (mismatch '(a b c d e) '(c d) :start1 3 :start2 1) 4) +(eql (mismatch '(a b c d e) '(c d) :start1 2 :end2 1) 3) +(null (mismatch '(a b c d) '(a b c d) :start1 1 :end1 2 :start2 1 :end2 2)) +(null (mismatch '(a b c d) '(a b c d) :start1 1 :end1 3 :start2 1 :end2 3)) +(null (mismatch '(a b c d) '(a b c d) :start1 1 :end1 4 :start2 1 :end2 4)) +(eql (mismatch '(a b c d) '(a b c d) :start1 1 :end1 nil :start2 1 :end2 1) 1) +(eql (mismatch '(a b c d) '(a b c d) :start1 1 :end1 nil :start2 1 :end2 2) 2) +(eql (mismatch '(a b c d) '(a b c d) :start1 1 :end1 nil :start2 1 :end2 3) 3) +(null (mismatch '(a b c d) '(a b c d) :start1 1 :end1 nil :start2 1 :end2 4)) +(eql (mismatch '(a b c d) '(a b c d) :start1 1 :end1 1 :start2 1) 1) +(eql (mismatch '(a b c d) '(a b c d) :start1 1 :end1 2 :start2 1) 2) +(eql (mismatch '(a b c d) '(a b c d) :start1 1 :end1 3 :start2 1) 3) +(null (mismatch '(a b c d) '(a b c d) :start1 1 :end1 4 :start2 1)) + +(null (mismatch '(a b c) '(a b c) :from-end t)) +(eql (mismatch '(a b c d) '(a b c) :from-end t) 4) +(eql (mismatch '(a b c) '(c) :from-end t) 2) +(eql (mismatch '(a b c) '(z a b c) :from-end t) 0) +(eql (mismatch '(a b c) '(x y z a b c) :from-end t) 0) +(eql (mismatch '(x y z a b c) '(a b c) :from-end t) 3) +(eql (mismatch '(x y z a b c) '(a b c) :end1 3 :from-end t) 3) +(eql (mismatch '(x y z a b c) '(a b c) :end1 5 :from-end t) 5) +(eql (mismatch '(x y z a b c x y z) '(a b c) :end1 6 :from-end t) 3) +(eql (mismatch '(x y z a b c x y z) '(a b c) :start1 2 :end1 6 :from-end t) 3) +(eql (mismatch '(x y z a b c x y z) '(a b c) + :from-end t + :start1 2 :end1 5 + :start2 1 :end2 2 + ) 4) +(eql (mismatch '(x y z a b c x y z) '(a b c) + :start1 2 :end1 5 + :start2 1 :end2 2 + ) 2) +(eql (mismatch '((a) (b) (c)) '((a) (b) (c))) 0) +(null (mismatch '((a) (b) (c)) '((a) (b) (c)) :key #'car)) +(null (mismatch '((a) (b) (c)) '((a) (b) (c)) :test #'equal)) +(eql (mismatch '(#(a) #(b) #(c)) '(#(a) #(b) #(c))) 0) +(null (mismatch '(#(a) #(b) #(c)) '(#(a) #(b) #(c)) :test #'equalp)) +(eql (mismatch '((a) (b) (c) (d)) '((a) (b) (c)) :key #'car) 3) +(eql (mismatch '((a) (b) (c)) '((a) (b) (c) (d)) :key #'car) 3) +(eql (mismatch '(#\a #\b #\c) '(#\A #\B #\C)) 0) +(null (mismatch '(#\a #\b #\c) '(#\A #\B #\C) :key #'char-upcase)) +(null (mismatch '(#\a #\b #\c) '(#\A #\B #\C) :key #'char-downcase)) +(null (mismatch '(#\a #\b #\c) '(#\A #\B #\C) + :key #'char-upcase + :start1 1 :end1 2 + :start2 1 :end2 2)) +(null (mismatch '(#\a #\b #\c) '(#\A #\B #\C) + :key #'char-upcase + :start1 2 + :start2 2)) +(eql (mismatch '((a b c) (b c d) (d e f)) + '((b b c) (c c d) (e e f))) + 0) +(eql (mismatch '((a b c) (b c d) (d e f)) + '((b b c) (c c d) (e e f)) + :key #'cdr) + 0) +(null (mismatch '((a b c) (b c d) (d e f)) + '((b b c) (c c d) (e e f)) + :key #'cdr + :test #'equal)) +(eql (mismatch '((a b c) (b c d) (d e f) (e f g)) + '((b b c) (c c d) (e e f)) + :key #'cdr + :test #'equal) + 3) +(eql (mismatch '((a b c) (b c d) (d e f) (e f g)) + '((b b c) (c c d) (e e f)) + :key #'cdr + :test #'equal + :from-end t) + 4) +(eql (mismatch '((a a a) (a b c) (b c d) (d e f)) + '((b b c) (c c d) (e e f)) + :key #'cdr + :test #'equal + :from-end t) + 1) +(null (mismatch '((a a a) (a b c) (b c d) (d e f) (e f g)) + '((b b c) (c c d) (e e f)) + :key #'cdr + :test #'equal + :from-end t + :start1 1 + :end1 4)) +(eql (mismatch '((a a a) (a b c) (b c d) (d e f) (e f g)) + '((b b c) (c c d) (e e f)) + :key #'cdr + :test #'equal + :from-end t + :start1 1) + 5) +(eql (mismatch '((a a a) (a b c) (b c d) (d e f) (e f g)) + '((b b c) (c c d) (e e f)) + :key #'cdr + :test #'equal + :from-end t + :end1 3 + :start2 1 + :end2 2) + + 2) + + +(null (mismatch #() '())) +(eql (mismatch #(a b c) '(x y z)) 0) +(eql (mismatch #() '(x y z)) 0) +(eql (mismatch #(x y z) '()) 0) +(null (mismatch #(a) '(a))) +(eql (mismatch #(a b c x y z) '(a b c)) 3) +(null (mismatch #(a b c) '(a b c))) +(eql (mismatch #(a b c d e f) '(a b c)) 3) +(eql (mismatch #(a b c) '(a b c d e f)) 3) +(eql (mismatch #(a b c) '(a b x)) 2) +(eql (mismatch #(a b c) '(a x c)) 1) +(eql (mismatch #(a b c) '(x b c)) 0) +(eql (mismatch #(x y z a b c x y z) '(a b c) :start1 3) 6) +(eql (mismatch #(x y z a b c x y z) '(a b c) :start1 3 :end1 nil) 6) +(eql (mismatch #(x y z a b c x y z) '(a b c) :start1 3 :end1 4) 4) +(eql (mismatch #(x y z a b c x y z) '(a b c) :start1 3 :end1 3) 3) +(null (mismatch #(x y z) '() :start1 0 :end1 0)) +(null (mismatch #(x y z) '() :start1 1 :end1 1)) +(null (mismatch #(x y z) '() :start1 2 :end1 2)) +(null (mismatch #(x y z) '() :start1 3 :end1 3)) +(null (mismatch #(x y z) '() :start1 0 :end1 0 :start2 0 :end2 0)) +(null (mismatch #(x y z) '() :start1 1 :end1 1 :start2 1 :end2 1)) +(null (mismatch #(x y z) '() :start1 2 :end1 2 :start2 2 :end2 2)) +(null (mismatch #(x y z) '() :start1 3 :end1 3 :start2 3 :end2 3)) +(null (mismatch #(x y z) '() :start1 0 :end1 0 :start2 3 :end2 3)) +(null (mismatch #(x y z) '() :start1 1 :end1 1 :start2 2 :end2 2)) +(null (mismatch #(x y z) '() :start1 2 :end1 2 :start2 1 :end2 1)) +(null (mismatch #(x y z) '() :start1 3 :end1 3 :start2 0 :end2 0)) +(eql (mismatch #(x y z) '(a b c) :start1 0 :end1 0) 0) +(eql (mismatch #(x y z) '(a b c) :start1 1 :end1 1) 1) +(eql (mismatch #(x y z) '(a b c) :start1 2 :end1 2) 2) +(eql (mismatch #(x y z) '(a b c) :start1 3 :end1 3) 3) +(eql (mismatch #(x y z) '(x y z) :start1 0 :end1 1) 1) +(eql (mismatch #(x y z) '(x y z) :start1 0 :end1 2) 2) +(eql (mismatch #(x y z) '(x y z Z) :start1 0 :end1 3) 3) +(null (mismatch #(x y z) '(x y z) :start1 0 :end1 3)) +(eql (mismatch #(a b c x y z) '(x y z a b c)) 0) +(eql (mismatch #(a b c x y z) '(x y z a b c) :start1 3) 6) +(eql (mismatch #(a b c x y z a b c) '(x y z a b c x y z) :start1 3) 9) +(eql (mismatch #(a b c x y z a b c) '(x y z a b c x y z) :start1 6) 6) +(eql (mismatch #(a b c x y z a b c) '(x y z a b c x y z) :start1 6 :start2 3) + 9) +(eql (mismatch #(a b c x y z a b c) '(x y z a b c x y z) :start1 0 :start2 3) + 6) +(eql (mismatch #(a b c) '(a b c x y z)) 3) +(eql (mismatch #(a b c) '(x a b c y z)) 0) +(eql (mismatch #(a b c) '(x a b c y z) :start2 1) 3) +(eql (mismatch #(a b c) '(x a b c y z) :start2 1 :end2 nil) 3) +(null (mismatch #(a b c) '(x a b c y z) :start2 1 :end2 4)) +(eql (mismatch #(a b c d e) '(c d)) 0) +(eql (mismatch #(a b c d e) '(c d) :start1 2) 4) +(eql (mismatch #(a b c d e) '(c d) :start1 2 :end1 3) 3) +(eql (mismatch #(a b c d e) '(c d) :start1 2 :start2 1) 2) +(eql (mismatch #(a b c d e) '(c d) :start1 3 :start2 1) 4) +(eql (mismatch #(a b c d e) '(c d) :start1 2 :end2 1) 3) +(null (mismatch #(a b c d) '(a b c d) :start1 1 :end1 2 :start2 1 :end2 2)) +(null (mismatch #(a b c d) '(a b c d) :start1 1 :end1 3 :start2 1 :end2 3)) +(null (mismatch #(a b c d) '(a b c d) :start1 1 :end1 4 :start2 1 :end2 4)) +(eql (mismatch #(a b c d) '(a b c d) :start1 1 :end1 nil :start2 1 :end2 1) 1) +(eql (mismatch #(a b c d) '(a b c d) :start1 1 :end1 nil :start2 1 :end2 2) 2) +(eql (mismatch #(a b c d) '(a b c d) :start1 1 :end1 nil :start2 1 :end2 3) 3) +(null (mismatch #(a b c d) '(a b c d) :start1 1 :end1 nil :start2 1 :end2 4)) +(eql (mismatch #(a b c d) '(a b c d) :start1 1 :end1 1 :start2 1) 1) +(eql (mismatch #(a b c d) '(a b c d) :start1 1 :end1 2 :start2 1) 2) +(eql (mismatch #(a b c d) '(a b c d) :start1 1 :end1 3 :start2 1) 3) +(null (mismatch #(a b c d) '(a b c d) :start1 1 :end1 4 :start2 1)) +(null (mismatch #(a b c) '(a b c) :from-end t)) +(eql (mismatch #(a b c d) '(a b c) :from-end t) 4) +(eql (mismatch #(a b c) '(c) :from-end t) 2) +(eql (mismatch #(a b c) '(z a b c) :from-end t) 0) +(eql (mismatch #(a b c) '(x y z a b c) :from-end t) 0) +(eql (mismatch #(x y z a b c) '(a b c) :from-end t) 3) +(eql (mismatch #(x y z a b c) '(a b c) :end1 3 :from-end t) 3) +(eql (mismatch #(x y z a b c) '(a b c) :end1 5 :from-end t) 5) +(eql (mismatch #(x y z a b c x y z) '(a b c) :end1 6 :from-end t) 3) +(eql (mismatch #(x y z a b c x y z) '(a b c) :start1 2 :end1 6 :from-end t) 3) +(eql (mismatch #(x y z a b c x y z) '(a b c) + :from-end t + :start1 2 :end1 5 + :start2 1 :end2 2 + ) 4) +(eql (mismatch #(x y z a b c x y z) '(a b c) + :start1 2 :end1 5 + :start2 1 :end2 2 + ) 2) +(eql (mismatch #((a) (b) (c)) '((a) (b) (c))) 0) +(null (mismatch #((a) (b) (c)) '((a) (b) (c)) :key #'car)) +(null (mismatch #((a) (b) (c)) '((a) (b) (c)) :test #'equal)) +(eql (mismatch #(#(a) #(b) #(c)) '(#(a) #(b) #(c))) 0) +(null (mismatch #(#(a) #(b) #(c)) '(#(a) #(b) #(c)) :test #'equalp)) +(eql (mismatch #((a) (b) (c) (d)) '((a) (b) (c)) :key #'car) 3) +(eql (mismatch #((a) (b) (c)) '((a) (b) (c) (d)) :key #'car) 3) +(eql (mismatch #(#\a #\b #\c) '(#\A #\B #\C)) 0) +(null (mismatch #(#\a #\b #\c) '(#\A #\B #\C) :key #'char-upcase)) +(null (mismatch #(#\a #\b #\c) '(#\A #\B #\C) :key #'char-downcase)) +(null (mismatch #(#\a #\b #\c) '(#\A #\B #\C) + :key #'char-upcase + :start1 1 :end1 2 + :start2 1 :end2 2)) +(null (mismatch #(#\a #\b #\c) '(#\A #\B #\C) + :key #'char-upcase + :start1 2 + :start2 2)) +(eql (mismatch #((a b c) (b c d) (d e f)) + '((b b c) (c c d) (e e f))) + 0) +(eql (mismatch #((a b c) (b c d) (d e f)) + '((b b c) (c c d) (e e f)) + :key #'cdr) + 0) +(null (mismatch #((a b c) (b c d) (d e f)) + '((b b c) (c c d) (e e f)) + :key #'cdr + :test #'equal)) +(eql (mismatch #((a b c) (b c d) (d e f) (e f g)) + '((b b c) (c c d) (e e f)) + :key #'cdr + :test #'equal) + 3) +(eql (mismatch #((a b c) (b c d) (d e f) (e f g)) + '((b b c) (c c d) (e e f)) + :key #'cdr + :test #'equal + :from-end t) + 4) +(eql (mismatch #((a a a) (a b c) (b c d) (d e f)) + '((b b c) (c c d) (e e f)) + :key #'cdr + :test #'equal + :from-end t) + 1) +(null (mismatch #((a a a) (a b c) (b c d) (d e f) (e f g)) + '((b b c) (c c d) (e e f)) + :key #'cdr + :test #'equal + :from-end t + :start1 1 + :end1 4)) +(eql (mismatch #((a a a) (a b c) (b c d) (d e f) (e f g)) + '((b b c) (c c d) (e e f)) + :key #'cdr + :test #'equal + :from-end t + :start1 1) + 5) +(eql (mismatch #((a a a) (a b c) (b c d) (d e f) (e f g)) + '((b b c) (c c d) (e e f)) + :key #'cdr + :test #'equal + :from-end t + :end1 3 + :start2 1 + :end2 2) + + 2) + + +(null (mismatch '() #())) +(eql (mismatch '(a b c) #(x y z)) 0) +(eql (mismatch '() #(x y z)) 0) +(eql (mismatch '(x y z) #()) 0) +(null (mismatch '(a) #(a))) +(eql (mismatch '(a b c x y z) #(a b c)) 3) +(null (mismatch '(a b c) #(a b c))) +(eql (mismatch '(a b c d e f) #(a b c)) 3) +(eql (mismatch '(a b c) #(a b c d e f)) 3) +(eql (mismatch '(a b c) #(a b x)) 2) +(eql (mismatch '(a b c) #(a x c)) 1) +(eql (mismatch '(a b c) #(x b c)) 0) +(eql (mismatch '(x y z a b c x y z) #(a b c) :start1 3) 6) +(eql (mismatch '(x y z a b c x y z) #(a b c) :start1 3 :end1 nil) 6) +(eql (mismatch '(x y z a b c x y z) #(a b c) :start1 3 :end1 4) 4) +(eql (mismatch '(x y z a b c x y z) #(a b c) :start1 3 :end1 3) 3) +(null (mismatch '(x y z) #() :start1 0 :end1 0)) +(null (mismatch '(x y z) #() :start1 1 :end1 1)) +(null (mismatch '(x y z) #() :start1 2 :end1 2)) +(null (mismatch '(x y z) #() :start1 3 :end1 3)) +(null (mismatch '(x y z) #() :start1 0 :end1 0 :start2 0 :end2 0)) +(null (mismatch '(x y z) #() :start1 1 :end1 1 :start2 1 :end2 1)) +(null (mismatch '(x y z) #() :start1 2 :end1 2 :start2 2 :end2 2)) +(null (mismatch '(x y z) #() :start1 3 :end1 3 :start2 3 :end2 3)) +(null (mismatch '(x y z) #() :start1 0 :end1 0 :start2 3 :end2 3)) +(null (mismatch '(x y z) #() :start1 1 :end1 1 :start2 2 :end2 2)) +(null (mismatch '(x y z) #() :start1 2 :end1 2 :start2 1 :end2 1)) +(null (mismatch '(x y z) #() :start1 3 :end1 3 :start2 0 :end2 0)) +(eql (mismatch '(x y z) #(a b c) :start1 0 :end1 0) 0) +(eql (mismatch '(x y z) #(a b c) :start1 1 :end1 1) 1) +(eql (mismatch '(x y z) #(a b c) :start1 2 :end1 2) 2) +(eql (mismatch '(x y z) #(a b c) :start1 3 :end1 3) 3) +(eql (mismatch '(x y z) #(x y z) :start1 0 :end1 1) 1) +(eql (mismatch '(x y z) #(x y z) :start1 0 :end1 2) 2) +(eql (mismatch '(x y z) #(x y z Z) :start1 0 :end1 3) 3) +(null (mismatch '(x y z) #(x y z) :start1 0 :end1 3)) +(eql (mismatch '(a b c x y z) #(x y z a b c)) 0) +(eql (mismatch '(a b c x y z) #(x y z a b c) :start1 3) 6) +(eql (mismatch '(a b c x y z a b c) #(x y z a b c x y z) :start1 3) 9) +(eql (mismatch '(a b c x y z a b c) #(x y z a b c x y z) :start1 6) 6) +(eql (mismatch '(a b c x y z a b c) #(x y z a b c x y z) :start1 6 :start2 3) + 9) +(eql (mismatch '(a b c x y z a b c) #(x y z a b c x y z) :start1 0 :start2 3) + 6) +(eql (mismatch '(a b c) #(a b c x y z)) 3) +(eql (mismatch '(a b c) #(x a b c y z)) 0) +(eql (mismatch '(a b c) #(x a b c y z) :start2 1) 3) +(eql (mismatch '(a b c) #(x a b c y z) :start2 1 :end2 nil) 3) +(null (mismatch '(a b c) #(x a b c y z) :start2 1 :end2 4)) +(eql (mismatch '(a b c d e) #(c d)) 0) +(eql (mismatch '(a b c d e) #(c d) :start1 2) 4) +(eql (mismatch '(a b c d e) #(c d) :start1 2 :end1 3) 3) +(eql (mismatch '(a b c d e) #(c d) :start1 2 :start2 1) 2) +(eql (mismatch '(a b c d e) #(c d) :start1 3 :start2 1) 4) +(eql (mismatch '(a b c d e) #(c d) :start1 2 :end2 1) 3) +(null (mismatch '(a b c d) #(a b c d) :start1 1 :end1 2 :start2 1 :end2 2)) +(null (mismatch '(a b c d) #(a b c d) :start1 1 :end1 3 :start2 1 :end2 3)) +(null (mismatch '(a b c d) #(a b c d) :start1 1 :end1 4 :start2 1 :end2 4)) +(eql (mismatch '(a b c d) #(a b c d) :start1 1 :end1 nil :start2 1 :end2 1) 1) +(eql (mismatch '(a b c d) #(a b c d) :start1 1 :end1 nil :start2 1 :end2 2) 2) +(eql (mismatch '(a b c d) #(a b c d) :start1 1 :end1 nil :start2 1 :end2 3) 3) +(null (mismatch '(a b c d) #(a b c d) :start1 1 :end1 nil :start2 1 :end2 4)) +(eql (mismatch '(a b c d) #(a b c d) :start1 1 :end1 1 :start2 1) 1) +(eql (mismatch '(a b c d) #(a b c d) :start1 1 :end1 2 :start2 1) 2) +(eql (mismatch '(a b c d) #(a b c d) :start1 1 :end1 3 :start2 1) 3) +(null (mismatch '(a b c d) #(a b c d) :start1 1 :end1 4 :start2 1)) +(null (mismatch '(a b c) #(a b c) :from-end t)) +(eql (mismatch '(a b c d) #(a b c) :from-end t) 4) +(eql (mismatch '(a b c) #(c) :from-end t) 2) +(eql (mismatch '(a b c) #(z a b c) :from-end t) 0) +(eql (mismatch '(a b c) #(x y z a b c) :from-end t) 0) +(eql (mismatch '(x y z a b c) #(a b c) :from-end t) 3) +(eql (mismatch '(x y z a b c) #(a b c) :end1 3 :from-end t) 3) +(eql (mismatch '(x y z a b c) #(a b c) :end1 5 :from-end t) 5) +(eql (mismatch '(x y z a b c x y z) #(a b c) :end1 6 :from-end t) 3) +(eql (mismatch '(x y z a b c x y z) #(a b c) :start1 2 :end1 6 :from-end t) 3) +(eql (mismatch '(x y z a b c x y z) #(a b c) + :from-end t + :start1 2 :end1 5 + :start2 1 :end2 2 + ) 4) +(eql (mismatch '(x y z a b c x y z) #(a b c) + :start1 2 :end1 5 + :start2 1 :end2 2 + ) 2) +(eql (mismatch '((a) (b) (c)) #((a) (b) (c))) 0) +(null (mismatch '((a) (b) (c)) #((a) (b) (c)) :key #'car)) +(null (mismatch '((a) (b) (c)) #((a) (b) (c)) :test #'equal)) +(eql (mismatch '(#(a) #(b) #(c)) #(#(a) #(b) #(c))) 0) +(null (mismatch '(#(a) #(b) #(c)) #(#(a) #(b) #(c)) :test #'equalp)) +(eql (mismatch '((a) (b) (c) (d)) #((a) (b) (c)) :key #'car) 3) +(eql (mismatch '((a) (b) (c)) #((a) (b) (c) (d)) :key #'car) 3) +(eql (mismatch '(#\a #\b #\c) #(#\A #\B #\C)) 0) +(null (mismatch '(#\a #\b #\c) #(#\A #\B #\C) :key #'char-upcase)) +(null (mismatch '(#\a #\b #\c) #(#\A #\B #\C) :key #'char-downcase)) +(null (mismatch '(#\a #\b #\c) #(#\A #\B #\C) + :key #'char-upcase + :start1 1 :end1 2 + :start2 1 :end2 2)) +(null (mismatch '(#\a #\b #\c) #(#\A #\B #\C) + :key #'char-upcase + :start1 2 + :start2 2)) +(eql (mismatch '((a b c) (b c d) (d e f)) + #((b b c) (c c d) (e e f))) + 0) +(eql (mismatch '((a b c) (b c d) (d e f)) + #((b b c) (c c d) (e e f)) + :key #'cdr) + 0) +(null (mismatch '((a b c) (b c d) (d e f)) + #((b b c) (c c d) (e e f)) + :key #'cdr + :test #'equal)) +(eql (mismatch '((a b c) (b c d) (d e f) (e f g)) + #((b b c) (c c d) (e e f)) + :key #'cdr + :test #'equal) + 3) +(eql (mismatch '((a b c) (b c d) (d e f) (e f g)) + #((b b c) (c c d) (e e f)) + :key #'cdr + :test #'equal + :from-end t) + 4) +(eql (mismatch '((a a a) (a b c) (b c d) (d e f)) + #((b b c) (c c d) (e e f)) + :key #'cdr + :test #'equal + :from-end t) + 1) +(null (mismatch '((a a a) (a b c) (b c d) (d e f) (e f g)) + #((b b c) (c c d) (e e f)) + :key #'cdr + :test #'equal + :from-end t + :start1 1 + :end1 4)) +(eql (mismatch '((a a a) (a b c) (b c d) (d e f) (e f g)) + #((b b c) (c c d) (e e f)) + :key #'cdr + :test #'equal + :from-end t + :start1 1) + 5) +(eql (mismatch '((a a a) (a b c) (b c d) (d e f) (e f g)) + #((b b c) (c c d) (e e f)) + :key #'cdr + :test #'equal + :from-end t + :end1 3 + :start2 1 + :end2 2) + + 2) + + +(null (mismatch #() #())) +(eql (mismatch #(a b c) #(x y z)) 0) +(eql (mismatch #() #(x y z)) 0) +(eql (mismatch #(x y z) #()) 0) +(null (mismatch #(a) #(a))) +(eql (mismatch #(a b c x y z) #(a b c)) 3) +(null (mismatch #(a b c) #(a b c))) +(eql (mismatch #(a b c d e f) #(a b c)) 3) +(eql (mismatch #(a b c) #(a b c d e f)) 3) +(eql (mismatch #(a b c) #(a b x)) 2) +(eql (mismatch #(a b c) #(a x c)) 1) +(eql (mismatch #(a b c) #(x b c)) 0) +(eql (mismatch #(x y z a b c x y z) #(a b c) :start1 3) 6) +(eql (mismatch #(x y z a b c x y z) #(a b c) :start1 3 :end1 nil) 6) +(eql (mismatch #(x y z a b c x y z) #(a b c) :start1 3 :end1 4) 4) +(eql (mismatch #(x y z a b c x y z) #(a b c) :start1 3 :end1 3) 3) +(null (mismatch #(x y z) #() :start1 0 :end1 0)) +(null (mismatch #(x y z) #() :start1 1 :end1 1)) +(null (mismatch #(x y z) #() :start1 2 :end1 2)) +(null (mismatch #(x y z) #() :start1 3 :end1 3)) +(null (mismatch #(x y z) #() :start1 0 :end1 0 :start2 0 :end2 0)) +(null (mismatch #(x y z) #() :start1 1 :end1 1 :start2 1 :end2 1)) +(null (mismatch #(x y z) #() :start1 2 :end1 2 :start2 2 :end2 2)) +(null (mismatch #(x y z) #() :start1 3 :end1 3 :start2 3 :end2 3)) +(null (mismatch #(x y z) #() :start1 0 :end1 0 :start2 3 :end2 3)) +(null (mismatch #(x y z) #() :start1 1 :end1 1 :start2 2 :end2 2)) +(null (mismatch #(x y z) #() :start1 2 :end1 2 :start2 1 :end2 1)) +(null (mismatch #(x y z) #() :start1 3 :end1 3 :start2 0 :end2 0)) +(eql (mismatch #(x y z) #(a b c) :start1 0 :end1 0) 0) +(eql (mismatch #(x y z) #(a b c) :start1 1 :end1 1) 1) +(eql (mismatch #(x y z) #(a b c) :start1 2 :end1 2) 2) +(eql (mismatch #(x y z) #(a b c) :start1 3 :end1 3) 3) +(eql (mismatch #(x y z) #(x y z) :start1 0 :end1 1) 1) +(eql (mismatch #(x y z) #(x y z) :start1 0 :end1 2) 2) +(eql (mismatch #(x y z) #(x y z Z) :start1 0 :end1 3) 3) +(null (mismatch #(x y z) #(x y z) :start1 0 :end1 3)) +(eql (mismatch #(a b c x y z) #(x y z a b c)) 0) +(eql (mismatch #(a b c x y z) #(x y z a b c) :start1 3) 6) +(eql (mismatch #(a b c x y z a b c) #(x y z a b c x y z) :start1 3) 9) +(eql (mismatch #(a b c x y z a b c) #(x y z a b c x y z) :start1 6) 6) +(eql (mismatch #(a b c x y z a b c) #(x y z a b c x y z) :start1 6 :start2 3) + 9) +(eql (mismatch #(a b c x y z a b c) #(x y z a b c x y z) :start1 0 :start2 3) + 6) +(eql (mismatch #(a b c) #(a b c x y z)) 3) +(eql (mismatch #(a b c) #(x a b c y z)) 0) +(eql (mismatch #(a b c) #(x a b c y z) :start2 1) 3) +(eql (mismatch #(a b c) #(x a b c y z) :start2 1 :end2 nil) 3) +(null (mismatch #(a b c) #(x a b c y z) :start2 1 :end2 4)) +(eql (mismatch #(a b c d e) #(c d)) 0) +(eql (mismatch #(a b c d e) #(c d) :start1 2) 4) +(eql (mismatch #(a b c d e) #(c d) :start1 2 :end1 3) 3) +(eql (mismatch #(a b c d e) #(c d) :start1 2 :start2 1) 2) +(eql (mismatch #(a b c d e) #(c d) :start1 3 :start2 1) 4) +(eql (mismatch #(a b c d e) #(c d) :start1 2 :end2 1) 3) +(null (mismatch #(a b c d) #(a b c d) :start1 1 :end1 2 :start2 1 :end2 2)) +(null (mismatch #(a b c d) #(a b c d) :start1 1 :end1 3 :start2 1 :end2 3)) +(null (mismatch #(a b c d) #(a b c d) :start1 1 :end1 4 :start2 1 :end2 4)) +(eql (mismatch #(a b c d) #(a b c d) :start1 1 :end1 nil :start2 1 :end2 1) 1) +(eql (mismatch #(a b c d) #(a b c d) :start1 1 :end1 nil :start2 1 :end2 2) 2) +(eql (mismatch #(a b c d) #(a b c d) :start1 1 :end1 nil :start2 1 :end2 3) 3) +(null (mismatch #(a b c d) #(a b c d) :start1 1 :end1 nil :start2 1 :end2 4)) +(eql (mismatch #(a b c d) #(a b c d) :start1 1 :end1 1 :start2 1) 1) +(eql (mismatch #(a b c d) #(a b c d) :start1 1 :end1 2 :start2 1) 2) +(eql (mismatch #(a b c d) #(a b c d) :start1 1 :end1 3 :start2 1) 3) +(null (mismatch #(a b c d) #(a b c d) :start1 1 :end1 4 :start2 1)) +(null (mismatch #(a b c) #(a b c) :from-end t)) +(eql (mismatch #(a b c d) #(a b c) :from-end t) 4) +(eql (mismatch #(a b c) #(c) :from-end t) 2) +(eql (mismatch #(a b c) #(z a b c) :from-end t) 0) +(eql (mismatch #(a b c) #(x y z a b c) :from-end t) 0) +(eql (mismatch #(x y z a b c) #(a b c) :from-end t) 3) +(eql (mismatch #(x y z a b c) #(a b c) :end1 3 :from-end t) 3) +(eql (mismatch #(x y z a b c) #(a b c) :end1 5 :from-end t) 5) +(eql (mismatch #(x y z a b c x y z) #(a b c) :end1 6 :from-end t) 3) +(eql (mismatch #(x y z a b c x y z) #(a b c) :start1 2 :end1 6 :from-end t) 3) +(eql (mismatch #(x y z a b c x y z) #(a b c) + :from-end t + :start1 2 :end1 5 + :start2 1 :end2 2 + ) 4) +(eql (mismatch #(x y z a b c x y z) #(a b c) + :start1 2 :end1 5 + :start2 1 :end2 2 + ) 2) +(eql (mismatch #((a) (b) (c)) #((a) (b) (c))) 0) +(null (mismatch #((a) (b) (c)) #((a) (b) (c)) :key #'car)) +(null (mismatch #((a) (b) (c)) #((a) (b) (c)) :test #'equal)) +(eql (mismatch #(#(a) #(b) #(c)) #(#(a) #(b) #(c))) 0) +(null (mismatch #(#(a) #(b) #(c)) #(#(a) #(b) #(c)) :test #'equalp)) +(eql (mismatch #((a) (b) (c) (d)) #((a) (b) (c)) :key #'car) 3) +(eql (mismatch #((a) (b) (c)) #((a) (b) (c) (d)) :key #'car) 3) +(eql (mismatch #(#\a #\b #\c) #(#\A #\B #\C)) 0) +(null (mismatch #(#\a #\b #\c) #(#\A #\B #\C) :key #'char-upcase)) +(null (mismatch #(#\a #\b #\c) #(#\A #\B #\C) :key #'char-downcase)) +(null (mismatch #(#\a #\b #\c) #(#\A #\B #\C) + :key #'char-upcase + :start1 1 :end1 2 + :start2 1 :end2 2)) +(null (mismatch #(#\a #\b #\c) #(#\A #\B #\C) + :key #'char-upcase + :start1 2 + :start2 2)) +(eql (mismatch #((a b c) (b c d) (d e f)) + #((b b c) (c c d) (e e f))) + 0) +(eql (mismatch #((a b c) (b c d) (d e f)) + #((b b c) (c c d) (e e f)) + :key #'cdr) + 0) +(null (mismatch #((a b c) (b c d) (d e f)) + #((b b c) (c c d) (e e f)) + :key #'cdr + :test #'equal)) +(eql (mismatch #((a b c) (b c d) (d e f) (e f g)) + #((b b c) (c c d) (e e f)) + :key #'cdr + :test #'equal) + 3) +(eql (mismatch #((a b c) (b c d) (d e f) (e f g)) + #((b b c) (c c d) (e e f)) + :key #'cdr + :test #'equal + :from-end t) + 4) +(eql (mismatch #((a a a) (a b c) (b c d) (d e f)) + #((b b c) (c c d) (e e f)) + :key #'cdr + :test #'equal + :from-end t) + 1) +(null (mismatch #((a a a) (a b c) (b c d) (d e f) (e f g)) + #((b b c) (c c d) (e e f)) + :key #'cdr + :test #'equal + :from-end t + :start1 1 + :end1 4)) +(eql (mismatch #((a a a) (a b c) (b c d) (d e f) (e f g)) + #((b b c) (c c d) (e e f)) + :key #'cdr + :test #'equal + :from-end t + :start1 1) + 5) +(eql (mismatch #((a a a) (a b c) (b c d) (d e f) (e f g)) + #((b b c) (c c d) (e e f)) + :key #'cdr + :test #'equal + :from-end t + :end1 3 + :start2 1 + :end2 2) + + 2) + + +(eql (mismatch "abc" "xyz") 0) +(null (mismatch "" "")) +(null (mismatch "a" "a")) +(null (mismatch "abc" "abc")) +(null (mismatch "abc" "ABC" :key #'char-downcase)) +(null (mismatch "abc" "ABC" :test #'char-equal)) +(eql (mismatch "abcde" "abc") 3) +(eql (mismatch "abc" "abcde") 3) +(eql (mismatch "abc" "abxyz") 2) +(eql (mismatch "abcde" "abx") 2) +(null (mismatch "abc" "abc" :from-end t)) +(eql (mismatch "abcxyz" "xyzxyz" :from-end t) 3) +(eql (mismatch "abcxyz" "xyz" :from-end t) 3) +(eql (mismatch "xyz" "abcxyz" :from-end t) 0) +(eql (mismatch "ayz" "abcxyz" :from-end t) 1) +(null (mismatch "abc" "xyz" :test #'char<)) +(eql (mismatch "abc" "xyz" :test #'char>) 0) +(eql (mismatch "abcxyz" "abcdefg") 3) +(eql (mismatch "1xyz" "22xyz" :from-end t) 1) + +(null (mismatch #*010101 #*010101)) +(eql (mismatch #*010 #*101) 0) +(eql (mismatch #*010 #*101 :from-end t) 3) +(eql (mismatch #*0101 #*010101) 4) +(eql (mismatch #*010101 #*0101) 4) +(eql (mismatch #*010100 #*010111) 4) +(null (mismatch #*0101 #*0101 :from-end t)) +(eql (mismatch #*00101 #*0101 :from-end t) 1) +(eql (mismatch #*0101 #*00101 :from-end t) 0) +(eql (mismatch #*00101 #*10101 :from-end t) 1) + + + +(equal (replace "abcdefghij" "0123456789" :start1 4 :end1 7 :start2 4) + "abcd456hij") +(let ((lst (copy-seq "012345678"))) + (and (equal (replace lst lst :start1 2 :start2 0) "010123456") + (equal lst "010123456"))) + + +(let* ((list0 (list 'a 'b 'c 'd 'e)) + (list (replace list0 '(x y z)))) + (and (eq list0 list) + (equal list0 '(x y z d e)))) + +(let* ((list0 (list 'a 'b 'c 'd 'e)) + (list (replace list0 '(x y z) :start1 1))) + (and (eq list0 list) + (equal list0 '(a x y z e)))) + +(let* ((list0 (list 'a 'b 'c 'd 'e)) + (list (replace list0 '(x y z) :start1 1 :end1 nil))) + (and (eq list0 list) + (equal list0 '(a x y z e)))) + +(let* ((list0 (list 'a 'b 'c 'd 'e)) + (list (replace list0 '(x y z) :start1 1 :start2 1))) + (and (eq list0 list) + (equal list0 '(a y z d e)))) + +(let* ((list0 (list 'a 'b 'c 'd 'e)) + (list (replace list0 '(x y z) :start1 1 :start2 1 :end2 nil))) + (and (eq list0 list) + (equal list0 '(a y z d e)))) + +(let* ((list0 (list 'a 'b 'c 'd 'e)) + (list (replace list0 '(x y z) :start1 1 :end1 nil :start2 1 :end2 nil))) + (and (eq list0 list) + (equal list0 '(a y z d e)))) + +(let* ((list0 (list 'a 'b 'c 'd 'e)) + (list (replace list0 '(x y z) :start1 1 :end1 2 :start2 1))) + (and (eq list0 list) + (equal list0 '(a y c d e)))) + +(let* ((list0 (list 'a 'b 'c 'd 'e)) + (list (replace list0 '(x y z) :start1 1 :end1 1))) + (and (eq list0 list) + (equal list0 '(a b c d e)))) + +(let* ((list0 (list 'a 'b 'c 'd 'e)) + (list (replace list0 '(x y z) :start1 2 :end1 2))) + (and (eq list0 list) + (equal list0 '(a b c d e)))) + +(let* ((list0 (list 'a 'b 'c 'd 'e)) + (list (replace list0 '(x y z) :start1 3 :end1 3))) + (and (eq list0 list) + (equal list0 '(a b c d e)))) + +(let* ((list0 (list 'a 'b 'c 'd 'e)) + (list (replace list0 '(x y z) :start1 4 :end1 4))) + (and (eq list0 list) + (equal list0 '(a b c d e)))) + +(let* ((list0 (list 'a 'b 'c 'd 'e)) + (list (replace list0 '(x y z) :start1 5 :end1 5))) + (and (eq list0 list) + (equal list0 '(a b c d e)))) + +(null (replace nil nil)) +(null (replace nil '(a b c))) + +(let* ((list0 (list 'a 'b 'c)) + (list (replace list0 '()))) + (and (eq list0 list) + (equal list0 '(a b c)))) + +(let* ((list0 (list 'a 'b 'c 'd 'e)) + (list (replace list0 list0))) + (and (eq list0 list) + (equal list0 '(a b c d e)))) + +(let* ((list0 (list 'a 'b 'c 'd 'e)) + (list (replace list0 list0 :start1 3))) + (and (eq list0 list) + (equal list0 '(a b c a b)))) + +(let* ((list0 (list 'a 'b 'c 'd 'e)) + (list (replace list0 list0 :start1 1))) + (and (eq list0 list) + (equal list0 '(a a b c d)))) + +(let* ((list0 (list 'a 'b 'c 'd 'e)) + (list (replace list0 list0 :start1 1 :end1 3))) + (and (eq list0 list) + (equal list0 '(a a b d e)))) + +(let* ((list0 (list 'a 'b 'c)) + (list (replace list0 '(x y z)))) + (and (eq list0 list) + (equal list0 '(x y z)))) + + +(let* ((vector0 (vector 'a 'b 'c 'd 'e)) + (vector (replace vector0 '(x y z)))) + (and (eq vector0 vector) + (equalp vector0 #(x y z d e)))) + +(let* ((vector0 (vector 'a 'b 'c 'd 'e)) + (vector (replace vector0 '(x y z) :start1 1))) + (and (eq vector0 vector) + (equalp vector0 #(a x y z e)))) + +(let* ((vector0 (vector 'a 'b 'c 'd 'e)) + (vector (replace vector0 '(x y z) :start1 1 :end1 nil))) + (and (eq vector0 vector) + (equalp vector0 #(a x y z e)))) + +(let* ((vector0 (vector 'a 'b 'c 'd 'e)) + (vector (replace vector0 '(x y z) :start1 1 :start2 1))) + (and (eq vector0 vector) + (equalp vector0 #(a y z d e)))) + +(let* ((vector0 (vector 'a 'b 'c 'd 'e)) + (vector (replace vector0 '(x y z) :start1 1 :start2 1 :end2 nil))) + (and (eq vector0 vector) + (equalp vector0 #(a y z d e)))) + +(let* ((vector0 (vector 'a 'b 'c 'd 'e)) + (vector (replace vector0 '(x y z) :start1 1 :end1 nil :start2 1 :end2 nil))) + (and (eq vector0 vector) + (equalp vector0 #(a y z d e)))) + +(let* ((vector0 (vector 'a 'b 'c 'd 'e)) + (vector (replace vector0 '(x y z) :start1 1 :end1 2 :start2 1))) + (and (eq vector0 vector) + (equalp vector0 #(a y c d e)))) + +(let* ((vector0 (vector 'a 'b 'c 'd 'e)) + (vector (replace vector0 '(x y z) :start1 1 :end1 1))) + (and (eq vector0 vector) + (equalp vector0 #(a b c d e)))) + +(let* ((vector0 (vector 'a 'b 'c 'd 'e)) + (vector (replace vector0 '(x y z) :start1 2 :end1 2))) + (and (eq vector0 vector) + (equalp vector0 #(a b c d e)))) + +(let* ((vector0 (vector 'a 'b 'c 'd 'e)) + (vector (replace vector0 '(x y z) :start1 3 :end1 3))) + (and (eq vector0 vector) + (equalp vector0 #(a b c d e)))) + +(let* ((vector0 (vector 'a 'b 'c 'd 'e)) + (vector (replace vector0 '(x y z) :start1 4 :end1 4))) + (and (eq vector0 vector) + (equalp vector0 #(a b c d e)))) + +(let* ((vector0 (vector 'a 'b 'c 'd 'e)) + (vector (replace vector0 '(x y z) :start1 5 :end1 5))) + (and (eq vector0 vector) + (equalp vector0 #(a b c d e)))) + +(null (replace nil #())) +(null (replace nil #(a b c))) + +(let* ((vector0 (vector 'a 'b 'c)) + (vector (replace vector0 '()))) + (and (eq vector0 vector) + (equalp vector0 #(a b c)))) + +(let* ((vector0 (vector 'a 'b 'c 'd 'e)) + (vector (replace vector0 vector0))) + (and (eq vector0 vector) + (equalp vector0 #(a b c d e)))) + +(let* ((vector0 (vector 'a 'b 'c 'd 'e)) + (vector (replace vector0 vector0 :start1 3))) + (and (eq vector0 vector) + (equalp vector0 #(a b c a b)))) + +(let* ((vector0 (vector 'a 'b 'c 'd 'e)) + (vector (replace vector0 vector0 :start1 1))) + (and (eq vector0 vector) + (equalp vector0 #(a a b c d)))) + +(let* ((vector0 (vector 'a 'b 'c 'd 'e)) + (vector (replace vector0 vector0 :start1 1 :end1 3))) + (and (eq vector0 vector) + (equalp vector0 #(a a b d e)))) + +(let* ((vector0 (vector 'a 'b 'c)) + (vector (replace vector0 '(x y z)))) + (and (eq vector0 vector) + (equalp vector0 #(x y z)))) + + +(let* ((vector0 (vector 'a 'b 'c 'd 'e)) + (vector (replace vector0 #(x y z)))) + (and (eq vector0 vector) + (equalp vector0 #(x y z d e)))) + +(let* ((vector0 (vector 'a 'b 'c 'd 'e)) + (vector (replace vector0 #(x y z) :start1 1))) + (and (eq vector0 vector) + (equalp vector0 #(a x y z e)))) + +(let* ((vector0 (vector 'a 'b 'c 'd 'e)) + (vector (replace vector0 #(x y z) :start1 1 :end1 nil))) + (and (eq vector0 vector) + (equalp vector0 #(a x y z e)))) + +(let* ((vector0 (vector 'a 'b 'c 'd 'e)) + (vector (replace vector0 #(x y z) :start1 1 :start2 1))) + (and (eq vector0 vector) + (equalp vector0 #(a y z d e)))) + +(let* ((vector0 (vector 'a 'b 'c 'd 'e)) + (vector (replace vector0 #(x y z) :start1 1 :start2 1 :end2 nil))) + (and (eq vector0 vector) + (equalp vector0 #(a y z d e)))) + +(let* ((vector0 (vector 'a 'b 'c 'd 'e)) + (vector (replace vector0 #(x y z) :start1 1 :end1 nil :start2 1 :end2 nil))) + (and (eq vector0 vector) + (equalp vector0 #(a y z d e)))) + +(let* ((vector0 (vector 'a 'b 'c 'd 'e)) + (vector (replace vector0 #(x y z) :start1 1 :end1 2 :start2 1))) + (and (eq vector0 vector) + (equalp vector0 #(a y c d e)))) + +(let* ((vector0 (vector 'a 'b 'c 'd 'e)) + (vector (replace vector0 #(x y z) :start1 1 :end1 1))) + (and (eq vector0 vector) + (equalp vector0 #(a b c d e)))) + +(let* ((vector0 (vector 'a 'b 'c 'd 'e)) + (vector (replace vector0 #(x y z) :start1 2 :end1 2))) + (and (eq vector0 vector) + (equalp vector0 #(a b c d e)))) + +(let* ((vector0 (vector 'a 'b 'c 'd 'e)) + (vector (replace vector0 #(x y z) :start1 3 :end1 3))) + (and (eq vector0 vector) + (equalp vector0 #(a b c d e)))) + +(let* ((vector0 (vector 'a 'b 'c 'd 'e)) + (vector (replace vector0 #(x y z) :start1 4 :end1 4))) + (and (eq vector0 vector) + (equalp vector0 #(a b c d e)))) + +(let* ((vector0 (vector 'a 'b 'c 'd 'e)) + (vector (replace vector0 #(x y z) :start1 5 :end1 5))) + (and (eq vector0 vector) + (equalp vector0 #(a b c d e)))) + +(null (replace nil #())) +(null (replace nil #(a b c))) + +(let* ((vector0 (vector 'a 'b 'c)) + (vector (replace vector0 #()))) + (and (eq vector0 vector) + (equalp vector0 #(a b c)))) + +(let* ((vector0 (vector 'a 'b 'c 'd 'e)) + (vector (replace vector0 vector0))) + (and (eq vector0 vector) + (equalp vector0 #(a b c d e)))) + +(let* ((vector0 (vector 'a 'b 'c 'd 'e)) + (vector (replace vector0 vector0 :start1 3))) + (and (eq vector0 vector) + (equalp vector0 #(a b c a b)))) + +(let* ((vector0 (vector 'a 'b 'c 'd 'e)) + (vector (replace vector0 vector0 :start1 1))) + (and (eq vector0 vector) + (equalp vector0 #(a a b c d)))) + +(let* ((vector0 (vector 'a 'b 'c 'd 'e)) + (vector (replace vector0 vector0 :start1 1 :end1 3))) + (and (eq vector0 vector) + (equalp vector0 #(a a b d e)))) + +(let* ((vector0 (vector 'a 'b 'c)) + (vector (replace vector0 #(x y z)))) + (and (eq vector0 vector) + (equalp vector0 #(x y z)))) + +(let* ((str0 (copy-seq "abc")) + (str (replace str0 "xyz"))) + (and (eq str0 str) + (equalp str0 "xyz"))) + +(let* ((str0 (copy-seq "")) + (str (replace str0 ""))) + (and (eq str0 str) + (equalp str0 ""))) + +(let* ((str0 (copy-seq "")) + (str (replace str0 "xyz"))) + (and (eq str0 str) + (equalp str0 ""))) + +(let* ((str0 (copy-seq "abc")) + (str (replace str0 ""))) + (and (eq str0 str) + (equalp str0 "abc"))) + +(let* ((str0 (copy-seq "abcdef")) + (str (replace str0 "xyz" :start1 3))) + (and (eq str0 str) + (equalp str0 "abcxyz"))) + +(let* ((str0 (copy-seq "abcdef")) + (str (replace str0 "xyz" :start1 4 :start2 1))) + (and (eq str0 str) + (equalp str0 "abcdyz"))) + +(let* ((str0 (copy-seq "abcdef")) + (str (replace str0 "xyz" :start1 1 :end1 2 :start2 1))) + (and (eq str0 str) + (equalp str0 "aycdef"))) + +(let* ((str0 (copy-seq "abcdef")) + (str (replace str0 "xyz" :start1 1 :start2 1 :end2 2))) + (and (eq str0 str) + (equalp str0 "aycdef"))) + +(let* ((str0 (copy-seq "abcdef")) + (str (replace str0 str0 :start1 1))) + (and (eq str0 str) + (equalp str0 "aabcde"))) + + +(let* ((bv0 (copy-seq #*0000)) + (bv (replace bv0 #*1010))) + (and (eq bv0 bv) + (equalp bv0 #*1010))) + +(let* ((bv0 (copy-seq #*)) + (bv (replace bv0 #*1010))) + (and (eq bv0 bv) + (equalp bv0 #*))) + +(let* ((bv0 (copy-seq #*0000)) + (bv (replace bv0 #*))) + (and (eq bv0 bv) + (equalp bv0 #*0000))) + +(let* ((bv0 (copy-seq #*0000)) + (bv (replace bv0 #*1111 :start1 2))) + (and (eq bv0 bv) + (equalp bv0 #*0011))) + +(let* ((bv0 (copy-seq #*1001)) + (bv (replace bv0 #*0110 :start1 1 :end1 3 :start2 1 :end2 3))) + (and (eq bv0 bv) + (equalp bv0 #*1111))) + +(let* ((bv0 (copy-seq #*1010)) + (bv (replace bv0 bv0 :start1 1))) + (and (eq bv0 bv) + (equalp bv0 #*1101))) + + + +(equal (substitute #\. #\SPACE "0 2 4 6") "0.2.4.6") +(equal (substitute 9 4 '(1 2 4 1 3 4 5)) '(1 2 9 1 3 9 5)) +(equal (substitute 9 4 '(1 2 4 1 3 4 5) :count 1) '(1 2 9 1 3 4 5)) +(equal (substitute 9 4 '(1 2 4 1 3 4 5) :count 1 :from-end t) '(1 2 4 1 3 9 5)) +(equal (substitute 9 3 '(1 2 4 1 3 4 5) :test #'>) '(9 9 4 9 3 4 5)) +(equal (substitute-if 0 #'evenp '((1) (2) (3) (4)) :start 2 :key #'car) + '((1) (2) (3) 0)) +(equal (substitute-if 9 #'oddp '(1 2 4 1 3 4 5)) '(9 2 4 9 9 4 9)) +(equal (substitute-if 9 #'evenp '(1 2 4 1 3 4 5) :count 1 :from-end t) + '(1 2 4 1 3 9 5)) +(let ((some-things (list 'a 'car 'b 'cdr 'c))) + (and (equal (nsubstitute-if "function was here" #'fboundp some-things + :count 1 :from-end t) + '(A CAR B "function was here" C)) + (equal some-things '(A CAR B "function was here" C)))) +(let ((alpha-tester (copy-seq "ab "))) + (and (equal (nsubstitute-if-not #\z #'alpha-char-p alpha-tester) "abz") + (equal alpha-tester "abz"))) + + +(equal (substitute 'a 'x '(x y z)) '(a y z)) +(equal (substitute 'b 'y '(x y z)) '(x b z)) +(equal (substitute 'c 'z '(x y z)) '(x y c)) +(equal (substitute 'a 'p '(x y z)) '(x y z)) +(equal (substitute 'a 'x '()) '()) +(equal (substitute #\x #\b '(#\a #\b #\c #\d #\e) :test #'char<) + '(#\a #\b #\x #\x #\x)) +(equal (substitute #\x #\b '(#\a #\b #\c #\d #\e) + :test-not (complement #'char<)) + '(#\a #\b #\x #\x #\x)) +(equal (substitute '(a) 'x '((x) (y) (z)) :key #'car) + '((a) (y) (z))) +(equal (substitute 'c 'b '(a b a b a b a b)) '(a c a c a c a c)) +(equal (substitute 'a 'b '(b b b)) '(a a a)) +(equal (substitute 'z 'x '(a x b x c x d x e x f)) + '(a z b z c z d z e z f)) +(equal (substitute 'z 'x '(a x b x c x d x e x f) :count nil) + '(a z b z c z d z e z f)) +(equal (substitute 'z 'x '(a x b x c x d x e x f) :count 0) + '(a x b x c x d x e x f)) +(equal (substitute 'z 'x '(a x b x c x d x e x f) :count -100) + '(a x b x c x d x e x f)) +(equal (substitute 'z 'x '(a x b x c x d x e x f) :count 1) + '(a z b x c x d x e x f)) +(equal (substitute 'z 'x '(a x b x c x d x e x f) :count 2) + '(a z b z c x d x e x f)) +(equal (substitute 'z 'x '(a x b x c x d x e x f) :count 3) + '(a z b z c z d x e x f)) +(equal (substitute 'z 'x '(a x b x c x d x e x f) :count 4) + '(a z b z c z d z e x f)) +(equal (substitute 'z 'x '(a x b x c x d x e x f) :count 5) + '(a z b z c z d z e z f)) +(equal (substitute 'z 'x '(a x b x c x d x e x f) :count 6) + '(a z b z c z d z e z f)) +(equal (substitute 'z 'x '(a x b x c x d x e x f) :count 7) + '(a z b z c z d z e z f)) +(equal (substitute 'z 'x '(a x b x c x d x e x f) :count nil :from-end t) + '(a z b z c z d z e z f)) +(equal (substitute 'z 'x '(a x b x c x d x e x f) :count 0 :from-end t) + '(a x b x c x d x e x f)) +(equal (substitute 'z 'x '(a x b x c x d x e x f) :count -100 :from-end t) + '(a x b x c x d x e x f)) +(equal (substitute 'z 'x '(a x b x c x d x e x f) :count 1 :from-end t) + '(a x b x c x d x e z f)) +(equal (substitute 'z 'x '(a x b x c x d x e x f) :count 2 :from-end t) + '(a x b x c x d z e z f)) +(equal (substitute 'z 'x '(a x b x c x d x e x f) :count 3 :from-end t) + '(a x b x c z d z e z f)) +(equal (substitute 'z 'x '(a x b x c x d x e x f) :count 4 :from-end t) + '(a x b z c z d z e z f)) +(equal (substitute 'z 'x '(a x b x c x d x e x f) :count 5 :from-end t) + '(a z b z c z d z e z f)) +(equal (substitute 'z 'x '(a x b x c x d x e x f) :count 6 :from-end t) + '(a z b z c z d z e z f)) +(equal (substitute 'z 'x '(a x b x c x d x e x f) :count 7 :from-end t) + '(a z b z c z d z e z f)) +(equal (substitute 'z 'x '(a x b x c x d x e x f) :start 2 :count 1) + '(a x b z c x d x e x f)) +(equal (substitute 'z 'x '(a x b x c x d x e x f) :start 2 :end nil :count 1) + '(a x b z c x d x e x f)) +(equal (substitute 'z 'x '(a x b x c x d x e x f) :start 2 :end 6 :count 100) + '(a x b z c z d x e x f)) +(equal (substitute 'z 'x '(a x b x c x d x e x f) :start 2 :end 11 :count 100) + '(a x b z c z d z e z f)) +(equal (substitute 'z 'x '(a x b x c x d x e x f) :start 2 :end 8 :count 10) + '(a x b z c z d z e x f)) +(equal (substitute 'z 'x '(a x b x c x d x e x f) + :start 2 :end 8 :count 2 :from-end t) + '(a x b x c z d z e x f)) +(equal (substitute #\z #\c '(#\a #\b #\c #\d #\e #\f) :test #'char<) + '(#\a #\b #\c #\z #\z #\z)) +(equal (substitute #\z #\c '(#\a #\b #\c #\d #\e #\f) + :test-not (complement #'char<)) + '(#\a #\b #\c #\z #\z #\z)) +(equal (substitute "peace" "war" '("love" "hate" "war" "peace") :test #'equal) + '("love" "hate" "peace" "peace")) +(equal (substitute "peace" "war" '("love" "hate" "war" "peace") + :test-not (complement #'equal)) + '("love" "hate" "peace" "peace")) +(equal (substitute "peace" "war" '("war" "War" "WAr" "WAR") + :test #'string-equal) + '("peace" "peace" "peace" "peace")) +(equal (substitute "peace" "war" '("war" "War" "WAr" "WAR") + :test-not (complement #'string-equal)) + '("peace" "peace" "peace" "peace")) +(equal (substitute "peace" "WAR" '("war" "War" "WAr" "WAR") + :test #'string=) + '("war" "War" "WAr" "peace")) +(equal (substitute "peace" "WAR" '("war" "War" "WAr" "WAR") + :test-not (complement #'string=)) + '("war" "War" "WAr" "peace")) +(equal (substitute "peace" "WAR" '("war" "War" "WAr" "WAR") + :test #'string= + :key #'string-upcase) + '("peace" "peace" "peace" "peace")) +(equal (substitute "peace" "WAR" '("war" "War" "WAr" "WAR") + :test-not (complement #'string=) + :key #'string-upcase) + '("peace" "peace" "peace" "peace")) +(equal (substitute "peace" "WAR" '("war" "War" "WAr" "WAR") + :start 1 + :end 2 + :test #'string= + :key #'string-upcase) + '("war" "peace" "WAr" "WAR")) +(equal (substitute "peace" "WAR" '("war" "War" "WAr" "WAR") + :start 1 + :end 2 + :test-not (complement #'string=) + :key #'string-upcase) + '("war" "peace" "WAr" "WAR")) +(equal (substitute "peace" "WAR" '("war" "War" "WAr" "WAR") + :start 1 + :end nil + :test #'string= + :key #'string-upcase) + '("war" "peace" "peace" "peace")) +(equal (substitute "peace" "WAR" '("war" "War" "WAr" "WAR") + :start 1 + :end nil + :test-not (complement #'string=) + :key #'string-upcase) + '("war" "peace" "peace" "peace")) +(equal (substitute "peace" "war" '("war" "War" "WAr" "WAR") + :test #'string= + :key #'string-upcase) + '("war" "War" "WAr" "WAR")) +(equal (substitute "peace" "war" '("war" "War" "WAr" "WAR") + :test-not (complement #'string=) + :key #'string-upcase) + '("war" "War" "WAr" "WAR")) +(equal (substitute "peace" "WAR" + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR") + :start 1 + :end 7 + :count 1 + :test-not (complement #'string=) + :key #'string-upcase) + '("war" "peace" "WAr" "WAR" "war" "War" "WAr" "WAR")) +(equal (substitute "peace" "WAR" + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR") + :start 1 + :end 7 + :count 2 + :test-not (complement #'string=) + :key #'string-upcase) + '("war" "peace" "peace" "WAR" "war" "War" "WAr" "WAR")) +(equal (substitute "peace" "WAR" + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR") + :start 1 + :end 7 + :count 2 + :from-end t + :test-not (complement #'string=) + :key #'string-upcase) + '("war" "War" "WAr" "WAR" "war" "peace" "peace" "WAR")) +(equal (substitute "peace" "WAR" + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR") + :start 1 + :end 7 + :count 0 + :from-end t + :test-not (complement #'string=) + :key #'string-upcase) + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) +(equal (substitute "peace" "WAR" + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR") + :start 1 + :end 7 + :count -2 + :from-end t + :test-not (complement #'string=) + :key #'string-upcase) + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) +(equal (substitute "peace" "WAR" + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR") + :start 1 + :end 7 + :count nil + :from-end t + :test-not (complement #'string=) + :key #'string-upcase) + '("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR")) +(equal (substitute "peace" "WAR" + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR") + :start 1 + :end 7 + :count 6 + :from-end t + :test-not (complement #'string=) + :key #'string-upcase) + '("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR")) +(equal (substitute "peace" "WAR" + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR") + :start 1 + :end 7 + :count 7 + :from-end t + :test-not (complement #'string=) + :key #'string-upcase) + '("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR")) +(equal (substitute "peace" "WAR" + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR") + :start 1 + :end 7 + :count 100 + :from-end t + :test-not (complement #'string=) + :key #'string-upcase) + '("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR")) + + +(equalp (substitute 'a 'x #(x y z)) #(a y z)) +(equalp (substitute 'b 'y #(x y z)) #(x b z)) +(equalp (substitute 'c 'z #(x y z)) #(x y c)) +(equalp (substitute 'a 'p #(x y z)) #(x y z)) +(equalp (substitute 'a 'x #()) #()) +(equalp (substitute #\x #\b #(#\a #\b #\c #\d #\e) :test #'char<) + #(#\a #\b #\x #\x #\x)) +(equalp (substitute #\x #\b #(#\a #\b #\c #\d #\e) + :test-not (complement #'char<)) + #(#\a #\b #\x #\x #\x)) +(equalp (substitute '(a) 'x #((x) (y) (z)) :key #'car) + #((a) (y) (z))) +(equalp (substitute 'c 'b #(a b a b a b a b)) #(a c a c a c a c)) +(equalp (substitute 'a 'b #(b b b)) #(a a a)) +(equalp (substitute 'z 'x #(a x b x c x d x e x f)) + #(a z b z c z d z e z f)) +(equalp (substitute 'z 'x #(a x b x c x d x e x f) :count nil) + #(a z b z c z d z e z f)) +(equalp (substitute 'z 'x #(a x b x c x d x e x f) :count 0) + #(a x b x c x d x e x f)) +(equalp (substitute 'z 'x #(a x b x c x d x e x f) :count -100) + #(a x b x c x d x e x f)) +(equalp (substitute 'z 'x #(a x b x c x d x e x f) :count 1) + #(a z b x c x d x e x f)) +(equalp (substitute 'z 'x #(a x b x c x d x e x f) :count 2) + #(a z b z c x d x e x f)) +(equalp (substitute 'z 'x #(a x b x c x d x e x f) :count 3) + #(a z b z c z d x e x f)) +(equalp (substitute 'z 'x #(a x b x c x d x e x f) :count 4) + #(a z b z c z d z e x f)) +(equalp (substitute 'z 'x #(a x b x c x d x e x f) :count 5) + #(a z b z c z d z e z f)) +(equalp (substitute 'z 'x #(a x b x c x d x e x f) :count 6) + #(a z b z c z d z e z f)) +(equalp (substitute 'z 'x #(a x b x c x d x e x f) :count 7) + #(a z b z c z d z e z f)) +(equalp (substitute 'z 'x #(a x b x c x d x e x f) :count nil :from-end t) + #(a z b z c z d z e z f)) +(equalp (substitute 'z 'x #(a x b x c x d x e x f) :count 0 :from-end t) + #(a x b x c x d x e x f)) +(equalp (substitute 'z 'x #(a x b x c x d x e x f) :count -100 :from-end t) + #(a x b x c x d x e x f)) +(equalp (substitute 'z 'x #(a x b x c x d x e x f) :count 1 :from-end t) + #(a x b x c x d x e z f)) +(equalp (substitute 'z 'x #(a x b x c x d x e x f) :count 2 :from-end t) + #(a x b x c x d z e z f)) +(equalp (substitute 'z 'x #(a x b x c x d x e x f) :count 3 :from-end t) + #(a x b x c z d z e z f)) +(equalp (substitute 'z 'x #(a x b x c x d x e x f) :count 4 :from-end t) + #(a x b z c z d z e z f)) +(equalp (substitute 'z 'x #(a x b x c x d x e x f) :count 5 :from-end t) + #(a z b z c z d z e z f)) +(equalp (substitute 'z 'x #(a x b x c x d x e x f) :count 6 :from-end t) + #(a z b z c z d z e z f)) +(equalp (substitute 'z 'x #(a x b x c x d x e x f) :count 7 :from-end t) + #(a z b z c z d z e z f)) +(equalp (substitute 'z 'x #(a x b x c x d x e x f) :start 2 :count 1) + #(a x b z c x d x e x f)) +(equalp (substitute 'z 'x #(a x b x c x d x e x f) :start 2 :end nil :count 1) + #(a x b z c x d x e x f)) +(equalp (substitute 'z 'x #(a x b x c x d x e x f) :start 2 :end 6 :count 100) + #(a x b z c z d x e x f)) +(equalp (substitute 'z 'x #(a x b x c x d x e x f) :start 2 :end 11 :count 100) + #(a x b z c z d z e z f)) +(equalp (substitute 'z 'x #(a x b x c x d x e x f) :start 2 :end 8 :count 10) + #(a x b z c z d z e x f)) +(equalp (substitute 'z 'x #(a x b x c x d x e x f) + :start 2 :end 8 :count 2 :from-end t) + #(a x b x c z d z e x f)) +(equalp (substitute #\z #\c #(#\a #\b #\c #\d #\e #\f) :test #'char<) + #(#\a #\b #\c #\z #\z #\z)) +(equalp (substitute #\z #\c #(#\a #\b #\c #\d #\e #\f) + :test-not (complement #'char<)) + #(#\a #\b #\c #\z #\z #\z)) +(equalp (substitute "peace" "war" #("love" "hate" "war" "peace") :test #'equal) + #("love" "hate" "peace" "peace")) +(equalp (substitute "peace" "war" #("love" "hate" "war" "peace") + :test-not (complement #'equal)) + #("love" "hate" "peace" "peace")) +(equalp (substitute "peace" "war" #("war" "War" "WAr" "WAR") + :test #'string-equal) + #("peace" "peace" "peace" "peace")) +(equalp (substitute "peace" "war" #("war" "War" "WAr" "WAR") + :test-not (complement #'string-equal)) + #("peace" "peace" "peace" "peace")) +(equalp (substitute "peace" "WAR" #("war" "War" "WAr" "WAR") + :test #'string=) + #("war" "War" "WAr" "peace")) +(equalp (substitute "peace" "WAR" #("war" "War" "WAr" "WAR") + :test-not (complement #'string=)) + #("war" "War" "WAr" "peace")) +(equalp (substitute "peace" "WAR" #("war" "War" "WAr" "WAR") + :test #'string= + :key #'string-upcase) + #("peace" "peace" "peace" "peace")) +(equalp (substitute "peace" "WAR" #("war" "War" "WAr" "WAR") + :test-not (complement #'string=) + :key #'string-upcase) + #("peace" "peace" "peace" "peace")) +(equalp (substitute "peace" "WAR" #("war" "War" "WAr" "WAR") + :start 1 + :end 2 + :test #'string= + :key #'string-upcase) + #("war" "peace" "WAr" "WAR")) +(equalp (substitute "peace" "WAR" #("war" "War" "WAr" "WAR") + :start 1 + :end 2 + :test-not (complement #'string=) + :key #'string-upcase) + #("war" "peace" "WAr" "WAR")) +(equalp (substitute "peace" "WAR" #("war" "War" "WAr" "WAR") + :start 1 + :end nil + :test #'string= + :key #'string-upcase) + #("war" "peace" "peace" "peace")) +(equalp (substitute "peace" "WAR" #("war" "War" "WAr" "WAR") + :start 1 + :end nil + :test-not (complement #'string=) + :key #'string-upcase) + #("war" "peace" "peace" "peace")) +(equalp (substitute "peace" "war" #("war" "War" "WAr" "WAR") + :test #'string= + :key #'string-upcase) + #("war" "War" "WAr" "WAR")) +(equalp (substitute "peace" "war" #("war" "War" "WAr" "WAR") + :test-not (complement #'string=) + :key #'string-upcase) + #("war" "War" "WAr" "WAR")) +(equalp (substitute "peace" "WAR" + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR") + :start 1 + :end 7 + :count 1 + :test-not (complement #'string=) + :key #'string-upcase) + #("war" "peace" "WAr" "WAR" "war" "War" "WAr" "WAR")) +(equalp (substitute "peace" "WAR" + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR") + :start 1 + :end 7 + :count 2 + :test-not (complement #'string=) + :key #'string-upcase) + #("war" "peace" "peace" "WAR" "war" "War" "WAr" "WAR")) +(equalp (substitute "peace" "WAR" + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR") + :start 1 + :end 7 + :count 2 + :from-end t + :test-not (complement #'string=) + :key #'string-upcase) + #("war" "War" "WAr" "WAR" "war" "peace" "peace" "WAR")) +(equalp (substitute "peace" "WAR" + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR") + :start 1 + :end 7 + :count 0 + :from-end t + :test-not (complement #'string=) + :key #'string-upcase) + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) +(equalp (substitute "peace" "WAR" + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR") + :start 1 + :end 7 + :count -2 + :from-end t + :test-not (complement #'string=) + :key #'string-upcase) + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) +(equalp (substitute "peace" "WAR" + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR") + :start 1 + :end 7 + :count nil + :from-end t + :test-not (complement #'string=) + :key #'string-upcase) + #("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR")) +(equalp (substitute "peace" "WAR" + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR") + :start 1 + :end 7 + :count 6 + :from-end t + :test-not (complement #'string=) + :key #'string-upcase) + #("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR")) +(equalp (substitute "peace" "WAR" + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR") + :start 1 + :end 7 + :count 7 + :from-end t + :test-not (complement #'string=) + :key #'string-upcase) + #("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR")) +(equalp (substitute "peace" "WAR" + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR") + :start 1 + :end 7 + :count 100 + :from-end t + :test-not (complement #'string=) + :key #'string-upcase) + #("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR")) +(string= (substitute #\A #\a "abcabc") "AbcAbc") +(string= (substitute #\A #\a "") "") +(string= (substitute #\A #\a "xyz") "xyz") +(string= (substitute #\A #\a "aaaaaaaaaa" :start 5 :end nil) "aaaaaAAAAA") +(string= (substitute #\x #\5 "0123456789" :test #'char<) "012345xxxx") +(string= (substitute #\x #\5 "0123456789" :test #'char>) "xxxxx56789") +(string= (substitute #\x #\D "abcdefg" + :key #'char-upcase + :test #'char>) + "xxxdefg") +(string= (substitute #\x #\D "abcdefg" + :start 1 + :end 2 + :key #'char-upcase + :test #'char>) + "axcdefg") +(string= (substitute #\A #\a "aaaaaaaaaa" :count 2) "AAaaaaaaaa") +(string= (substitute #\A #\a "aaaaaaaaaa" :count -1) "aaaaaaaaaa") +(string= (substitute #\A #\a "aaaaaaaaaa" :count 0) "aaaaaaaaaa") +(string= (substitute #\A #\a "aaaaaaaaaa" :count nil) "AAAAAAAAAA") +(string= (substitute #\A #\a "aaaaaaaaaa" :count 100) "AAAAAAAAAA") +(string= (substitute #\A #\a "aaaaaaaaaa" :count 9) "AAAAAAAAAa") +(string= (substitute #\A #\a "aaaaaaaaaa" :count 9 :from-end t) "aAAAAAAAAA") +(string= (substitute #\A #\a "aaaaaaaaaa" + :start 2 + :end 8 + :count 3) + "aaAAAaaaaa") +(string= (substitute #\A #\a "aaaaaaaaaa" + :start 2 + :end 8 + :from-end t + :count 3) + "aaaaaAAAaa") +(string= (substitute #\x #\A "aaaaaaaaaa" + :start 2 + :end 8 + :from-end t + :count 3) + "aaaaaaaaaa") +(string= (substitute #\X #\A "aaaaaaaaaa" + :start 2 + :end 8 + :from-end t + :key #'char-upcase + :count 3) + "aaaaaXXXaa") +(string= (substitute #\X #\D "abcdefghij" + :start 2 + :end 8 + :from-end t + :key #'char-upcase + :test #'char< + :count 3) + "abcdeXXXij") +(equalp (substitute 0 1 #*1111) #*0000) +(equalp (substitute 0 1 #*1111 :start 1 :end nil) #*1000) +(equalp (substitute 0 1 #*1111 :start 1 :end 3) #*1001) +(equalp (substitute 0 1 #*11111111 :start 1 :end 7) #*10000001) +(equalp (substitute 0 1 #*11111111 :start 1 :end 7 :count 3) #*10001111) +(equalp (substitute 0 1 #*11111111 :start 1 :end 7 :count 3 :from-end t) + #*11110001) +(equalp (substitute 1 1 #*10101010 + :start 1 :end 7 :count 3 :from-end t + :key #'(lambda (x) (if (zerop x) 1 0))) + #*11111110) +(equalp (substitute 1 1 #*10101010 + :start 1 :end 7 :count 3 :from-end t + :key #'(lambda (x) (if (zerop x) 1 0)) + :test #'>=) + #*10101110) + + + +(equal (substitute-if 'a #'(lambda (arg) (eq arg 'x)) '(x y z)) '(a y z)) +(equal (substitute-if 'b #'(lambda (arg) (eq arg 'y)) '(x y z)) '(x b z)) +(equal (substitute-if 'c #'(lambda (arg) (eq arg 'z)) '(x y z)) '(x y c)) +(equal (substitute-if 'a #'(lambda (arg) (eq arg 'p)) '(x y z)) '(x y z)) +(equal (substitute-if 'a #'(lambda (arg) (eq arg 'x)) '()) '()) +(equal (substitute-if #\x #'(lambda (arg) (char< #\b arg)) + '(#\a #\b #\c #\d #\e)) + '(#\a #\b #\x #\x #\x)) +(equal (substitute-if '(a) #'(lambda (arg) (eq arg 'x)) + '((x) (y) (z)) :key #'car) + '((a) (y) (z))) +(equal (substitute-if 'c #'(lambda (arg) (eq arg 'b)) + '(a b a b a b a b)) '(a c a c a c a c)) +(equal (substitute-if 'a #'(lambda (arg) (eq arg 'b)) + '(b b b)) '(a a a)) +(equal (substitute-if 'z #'(lambda (arg) (eq arg 'x)) + '(a x b x c x d x e x f)) + '(a z b z c z d z e z f)) +(equal (substitute-if 'z #'(lambda (arg) (eq arg 'x)) + '(a x b x c x d x e x f) :count nil) + '(a z b z c z d z e z f)) +(equal (substitute-if 'z #'(lambda (arg) (eq arg 'x)) + '(a x b x c x d x e x f) :count 0) + '(a x b x c x d x e x f)) +(equal (substitute-if 'z #'(lambda (arg) (eq arg 'x)) + '(a x b x c x d x e x f) :count -100) + '(a x b x c x d x e x f)) +(equal (substitute-if 'z #'(lambda (arg) (eq arg 'x)) + '(a x b x c x d x e x f) :count 1) + '(a z b x c x d x e x f)) +(equal (substitute-if 'z #'(lambda (arg) (eq arg 'x)) + '(a x b x c x d x e x f) :count 2) + '(a z b z c x d x e x f)) +(equal (substitute-if 'z #'(lambda (arg) (eq arg 'x)) + '(a x b x c x d x e x f) :count 3) + '(a z b z c z d x e x f)) +(equal (substitute-if 'z #'(lambda (arg) (eq arg 'x)) + '(a x b x c x d x e x f) :count 4) + '(a z b z c z d z e x f)) +(equal (substitute-if 'z #'(lambda (arg) (eq arg 'x)) + '(a x b x c x d x e x f) :count 5) + '(a z b z c z d z e z f)) +(equal (substitute-if 'z #'(lambda (arg) (eq arg 'x)) + '(a x b x c x d x e x f) :count 6) + '(a z b z c z d z e z f)) +(equal (substitute-if 'z #'(lambda (arg) (eq arg 'x)) + '(a x b x c x d x e x f) :count 7) + '(a z b z c z d z e z f)) +(equal (substitute-if 'z #'(lambda (arg) (eq arg 'x)) + '(a x b x c x d x e x f) :count nil :from-end t) + '(a z b z c z d z e z f)) +(equal (substitute-if 'z #'(lambda (arg) (eq arg 'x)) + '(a x b x c x d x e x f) :count 0 :from-end t) + '(a x b x c x d x e x f)) +(equal (substitute-if 'z #'(lambda (arg) (eq arg 'x)) + '(a x b x c x d x e x f) :count -100 :from-end t) + '(a x b x c x d x e x f)) +(equal (substitute-if 'z #'(lambda (arg) (eq arg 'x)) + '(a x b x c x d x e x f) :count 1 :from-end t) + '(a x b x c x d x e z f)) +(equal (substitute-if 'z #'(lambda (arg) (eq arg 'x)) + '(a x b x c x d x e x f) :count 2 :from-end t) + '(a x b x c x d z e z f)) +(equal (substitute-if 'z #'(lambda (arg) (eq arg 'x)) + '(a x b x c x d x e x f) :count 3 :from-end t) + '(a x b x c z d z e z f)) +(equal (substitute-if 'z #'(lambda (arg) (eq arg 'x)) + '(a x b x c x d x e x f) :count 4 :from-end t) + '(a x b z c z d z e z f)) +(equal (substitute-if 'z #'(lambda (arg) (eq arg 'x)) + '(a x b x c x d x e x f) :count 5 :from-end t) + '(a z b z c z d z e z f)) +(equal (substitute-if 'z #'(lambda (arg) (eq arg 'x)) + '(a x b x c x d x e x f) :count 6 :from-end t) + '(a z b z c z d z e z f)) +(equal (substitute-if 'z #'(lambda (arg) (eq arg 'x)) + '(a x b x c x d x e x f) :count 7 :from-end t) + '(a z b z c z d z e z f)) +(equal (substitute-if 'z #'(lambda (arg) (eq arg 'x)) + '(a x b x c x d x e x f) :start 2 :count 1) + '(a x b z c x d x e x f)) +(equal (substitute-if 'z #'(lambda (arg) (eq arg 'x)) + '(a x b x c x d x e x f) :start 2 :end nil :count 1) + '(a x b z c x d x e x f)) +(equal (substitute-if 'z #'(lambda (arg) (eq arg 'x)) + '(a x b x c x d x e x f) :start 2 :end 6 :count 100) + '(a x b z c z d x e x f)) +(equal (substitute-if 'z #'(lambda (arg) (eq arg 'x)) + '(a x b x c x d x e x f) :start 2 :end 11 :count 100) + '(a x b z c z d z e z f)) +(equal (substitute-if 'z #'(lambda (arg) (eq arg 'x)) + '(a x b x c x d x e x f) :start 2 :end 8 :count 10) + '(a x b z c z d z e x f)) +(equal (substitute-if 'z #'(lambda (arg) (eq arg 'x)) + '(a x b x c x d x e x f) + :start 2 :end 8 :count 2 :from-end t) + '(a x b x c z d z e x f)) +(equal (substitute-if #\z #'(lambda (arg) (char< #\c arg)) + '(#\a #\b #\c #\d #\e #\f)) + '(#\a #\b #\c #\z #\z #\z)) +(equal (substitute-if "peace" #'(lambda (arg) (equal "war" arg)) + '("love" "hate" "war" "peace")) + '("love" "hate" "peace" "peace")) +(equal (substitute-if "peace" #'(lambda (arg) (string-equal "war" arg)) + '("war" "War" "WAr" "WAR")) + '("peace" "peace" "peace" "peace")) +(equal (substitute-if "peace" #'(lambda (arg) (string= "WAR" arg)) + '("war" "War" "WAr" "WAR") + :key #'string-upcase) + '("peace" "peace" "peace" "peace")) +(equal (substitute-if "peace" #'(lambda (arg) (string= "WAR" arg)) + '("war" "War" "WAr" "WAR") + :start 1 + :end 2 + :key #'string-upcase) + '("war" "peace" "WAr" "WAR")) +(equal (substitute-if "peace" #'(lambda (arg) (string= "WAR" arg)) + '("war" "War" "WAr" "WAR") + :start 1 + :end nil + :key #'string-upcase) + '("war" "peace" "peace" "peace")) +(equal (substitute-if "peace" #'(lambda (arg) (string= "war" arg)) + '("war" "War" "WAr" "WAR") + :key #'string-upcase) + '("war" "War" "WAr" "WAR")) +(equal (substitute-if "peace" #'(lambda (arg) (string= "WAR" arg)) + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR") + :start 1 + :end 7 + :count 1 + :key #'string-upcase) + '("war" "peace" "WAr" "WAR" "war" "War" "WAr" "WAR")) +(equal (substitute-if "peace" #'(lambda (arg) (string= "WAR" arg)) + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR") + :start 1 + :end 7 + :count 2 + :key #'string-upcase) + '("war" "peace" "peace" "WAR" "war" "War" "WAr" "WAR")) +(equal (substitute-if "peace" #'(lambda (arg) (string= "WAR" arg)) + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR") + :start 1 + :end 7 + :count 2 + :from-end t + :key #'string-upcase) + '("war" "War" "WAr" "WAR" "war" "peace" "peace" "WAR")) +(equal (substitute-if "peace" #'(lambda (arg) (string= "WAR" arg)) + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR") + :start 1 + :end 7 + :count 0 + :from-end t + :key #'string-upcase) + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) +(equal (substitute-if "peace" #'(lambda (arg) (string= "WAR" arg)) + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR") + :start 1 + :end 7 + :count -2 + :from-end t + :key #'string-upcase) + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) +(equal (substitute-if "peace" #'(lambda (arg) (string= "WAR" arg)) + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR") + :start 1 + :end 7 + :count nil + :from-end t + :key #'string-upcase) + '("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR")) +(equal (substitute-if "peace" #'(lambda (arg) (string= "WAR" arg)) + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR") + :start 1 + :end 7 + :count 6 + :from-end t + :key #'string-upcase) + '("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR")) +(equal (substitute-if "peace" #'(lambda (arg) (string= "WAR" arg)) + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR") + :start 1 + :end 7 + :count 7 + :from-end t + :key #'string-upcase) + '("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR")) +(equal (substitute-if "peace" #'(lambda (arg) (string= "WAR" arg)) + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR") + :start 1 + :end 7 + :count 100 + :from-end t + :key #'string-upcase) + '("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR")) + + +(equalp (substitute-if 'a #'(lambda (arg) (eq arg 'x)) #(x y z)) #(a y z)) +(equalp (substitute-if 'b #'(lambda (arg) (eq arg 'y)) #(x y z)) #(x b z)) +(equalp (substitute-if 'c #'(lambda (arg) (eq arg 'z)) #(x y z)) #(x y c)) +(equalp (substitute-if 'a #'(lambda (arg) (eq arg 'p)) #(x y z)) #(x y z)) +(equalp (substitute-if 'a #'(lambda (arg) (eq arg 'x)) #()) #()) +(equalp (substitute-if #\x #'(lambda (arg) (char< #\b arg)) + #(#\a #\b #\c #\d #\e)) + #(#\a #\b #\x #\x #\x)) +(equalp (substitute-if '(a) #'(lambda (arg) (eq arg 'x)) + #((x) (y) (z)) :key #'car) + #((a) (y) (z))) +(equalp (substitute-if 'c #'(lambda (arg) (eq arg 'b)) + #(a b a b a b a b)) #(a c a c a c a c)) +(equalp (substitute-if 'a #'(lambda (arg) (eq arg 'b)) + #(b b b)) #(a a a)) +(equalp (substitute-if 'z #'(lambda (arg) (eq arg 'x)) + #(a x b x c x d x e x f)) + #(a z b z c z d z e z f)) +(equalp (substitute-if 'z #'(lambda (arg) (eq arg 'x)) + #(a x b x c x d x e x f) :count nil) + #(a z b z c z d z e z f)) +(equalp (substitute-if 'z #'(lambda (arg) (eq arg 'x)) + #(a x b x c x d x e x f) :count 0) + #(a x b x c x d x e x f)) +(equalp (substitute-if 'z #'(lambda (arg) (eq arg 'x)) + #(a x b x c x d x e x f) :count -100) + #(a x b x c x d x e x f)) +(equalp (substitute-if 'z #'(lambda (arg) (eq arg 'x)) + #(a x b x c x d x e x f) :count 1) + #(a z b x c x d x e x f)) +(equalp (substitute-if 'z #'(lambda (arg) (eq arg 'x)) + #(a x b x c x d x e x f) :count 2) + #(a z b z c x d x e x f)) +(equalp (substitute-if 'z #'(lambda (arg) (eq arg 'x)) + #(a x b x c x d x e x f) :count 3) + #(a z b z c z d x e x f)) +(equalp (substitute-if 'z #'(lambda (arg) (eq arg 'x)) + #(a x b x c x d x e x f) :count 4) + #(a z b z c z d z e x f)) +(equalp (substitute-if 'z #'(lambda (arg) (eq arg 'x)) + #(a x b x c x d x e x f) :count 5) + #(a z b z c z d z e z f)) +(equalp (substitute-if 'z #'(lambda (arg) (eq arg 'x)) + #(a x b x c x d x e x f) :count 6) + #(a z b z c z d z e z f)) +(equalp (substitute-if 'z #'(lambda (arg) (eq arg 'x)) + #(a x b x c x d x e x f) :count 7) + #(a z b z c z d z e z f)) +(equalp (substitute-if 'z #'(lambda (arg) (eq arg 'x)) + #(a x b x c x d x e x f) :count nil :from-end t) + #(a z b z c z d z e z f)) +(equalp (substitute-if 'z #'(lambda (arg) (eq arg 'x)) + #(a x b x c x d x e x f) :count 0 :from-end t) + #(a x b x c x d x e x f)) +(equalp (substitute-if 'z #'(lambda (arg) (eq arg 'x)) + #(a x b x c x d x e x f) :count -100 :from-end t) + #(a x b x c x d x e x f)) +(equalp (substitute-if 'z #'(lambda (arg) (eq arg 'x)) + #(a x b x c x d x e x f) :count 1 :from-end t) + #(a x b x c x d x e z f)) +(equalp (substitute-if 'z #'(lambda (arg) (eq arg 'x)) + #(a x b x c x d x e x f) :count 2 :from-end t) + #(a x b x c x d z e z f)) +(equalp (substitute-if 'z #'(lambda (arg) (eq arg 'x)) + #(a x b x c x d x e x f) :count 3 :from-end t) + #(a x b x c z d z e z f)) +(equalp (substitute-if 'z #'(lambda (arg) (eq arg 'x)) + #(a x b x c x d x e x f) :count 4 :from-end t) + #(a x b z c z d z e z f)) +(equalp (substitute-if 'z #'(lambda (arg) (eq arg 'x)) + #(a x b x c x d x e x f) :count 5 :from-end t) + #(a z b z c z d z e z f)) +(equalp (substitute-if 'z #'(lambda (arg) (eq arg 'x)) + #(a x b x c x d x e x f) :count 6 :from-end t) + #(a z b z c z d z e z f)) +(equalp (substitute-if 'z #'(lambda (arg) (eq arg 'x)) + #(a x b x c x d x e x f) :count 7 :from-end t) + #(a z b z c z d z e z f)) +(equalp (substitute-if 'z #'(lambda (arg) (eq arg 'x)) + #(a x b x c x d x e x f) :start 2 :count 1) + #(a x b z c x d x e x f)) +(equalp (substitute-if 'z #'(lambda (arg) (eq arg 'x)) + #(a x b x c x d x e x f) :start 2 :end nil :count 1) + #(a x b z c x d x e x f)) +(equalp (substitute-if 'z #'(lambda (arg) (eq arg 'x)) + #(a x b x c x d x e x f) :start 2 :end 6 :count 100) + #(a x b z c z d x e x f)) +(equalp (substitute-if 'z #'(lambda (arg) (eq arg 'x)) + #(a x b x c x d x e x f) :start 2 :end 11 :count 100) + #(a x b z c z d z e z f)) +(equalp (substitute-if 'z #'(lambda (arg) (eq arg 'x)) + #(a x b x c x d x e x f) :start 2 :end 8 :count 10) + #(a x b z c z d z e x f)) +(equalp (substitute-if 'z #'(lambda (arg) (eq arg 'x)) + #(a x b x c x d x e x f) + :start 2 :end 8 :count 2 :from-end t) + #(a x b x c z d z e x f)) +(equalp (substitute-if #\z #'(lambda (arg) (char< #\c arg)) + #(#\a #\b #\c #\d #\e #\f)) + #(#\a #\b #\c #\z #\z #\z)) +(equalp (substitute-if "peace" #'(lambda (arg) (equal "war" arg)) + #("love" "hate" "war" "peace")) + #("love" "hate" "peace" "peace")) +(equalp (substitute-if "peace" #'(lambda (arg) (string-equal "war" arg)) + #("war" "War" "WAr" "WAR")) + #("peace" "peace" "peace" "peace")) +(equalp (substitute-if "peace" #'(lambda (arg) (string= "WAR" arg)) + #("war" "War" "WAr" "WAR") + :key #'string-upcase) + #("peace" "peace" "peace" "peace")) +(equalp (substitute-if "peace" #'(lambda (arg) (string= "WAR" arg)) + #("war" "War" "WAr" "WAR") + :start 1 + :end 2 + :key #'string-upcase) + #("war" "peace" "WAr" "WAR")) +(equalp (substitute-if "peace" #'(lambda (arg) (string= "WAR" arg)) + #("war" "War" "WAr" "WAR") + :start 1 + :end nil + :key #'string-upcase) + #("war" "peace" "peace" "peace")) +(equalp (substitute-if "peace" #'(lambda (arg) (string= "war" arg)) + #("war" "War" "WAr" "WAR") + :key #'string-upcase) + #("war" "War" "WAr" "WAR")) +(equalp (substitute-if "peace" #'(lambda (arg) (string= "WAR" arg)) + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR") + :start 1 + :end 7 + :count 1 + :key #'string-upcase) + #("war" "peace" "WAr" "WAR" "war" "War" "WAr" "WAR")) +(equalp (substitute-if "peace" #'(lambda (arg) (string= "WAR" arg)) + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR") + :start 1 + :end 7 + :count 2 + :key #'string-upcase) + #("war" "peace" "peace" "WAR" "war" "War" "WAr" "WAR")) +(equalp (substitute-if "peace" #'(lambda (arg) (string= "WAR" arg)) + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR") + :start 1 + :end 7 + :count 2 + :from-end t + :key #'string-upcase) + #("war" "War" "WAr" "WAR" "war" "peace" "peace" "WAR")) +(equalp (substitute-if "peace" #'(lambda (arg) (string= "WAR" arg)) + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR") + :start 1 + :end 7 + :count 0 + :from-end t + :key #'string-upcase) + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) +(equalp (substitute-if "peace" #'(lambda (arg) (string= "WAR" arg)) + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR") + :start 1 + :end 7 + :count -2 + :from-end t + :key #'string-upcase) + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) +(equalp (substitute-if "peace" #'(lambda (arg) (string= "WAR" arg)) + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR") + :start 1 + :end 7 + :count nil + :from-end t + :key #'string-upcase) + #("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR")) +(equalp (substitute-if "peace" #'(lambda (arg) (string= "WAR" arg)) + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR") + :start 1 + :end 7 + :count 6 + :from-end t + :key #'string-upcase) + #("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR")) +(equalp (substitute-if "peace" #'(lambda (arg) (string= "WAR" arg)) + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR") + :start 1 + :end 7 + :count 7 + :from-end t + :key #'string-upcase) + #("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR")) +(equalp (substitute-if "peace" #'(lambda (arg) (string= "WAR" arg)) + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR") + :start 1 + :end 7 + :count 100 + :from-end t + :key #'string-upcase) + #("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR")) + +(string= (substitute-if #\A #'(lambda (arg) (eql #\a arg)) "abcabc") "AbcAbc") +(string= (substitute-if #\A #'(lambda (arg) (eql #\a arg)) "") "") +(string= (substitute-if #\A #'(lambda (arg) (eql #\a arg)) "xyz") "xyz") +(string= (substitute-if #\A #'(lambda (arg) (eql #\a arg)) + "aaaaaaaaaa" :start 5 :end nil) "aaaaaAAAAA") +(string= (substitute-if #\x #'(lambda (arg) (char< #\5 arg)) + "0123456789") "012345xxxx") +(string= (substitute-if #\x #'(lambda (arg) (char> #\5 arg)) + "0123456789") "xxxxx56789") +(string= (substitute-if #\x #'(lambda (arg) (char> #\D arg)) "abcdefg" + :key #'char-upcase) + "xxxdefg") +(string= (substitute-if #\x #'(lambda (arg) (char> #\D arg)) "abcdefg" + :start 1 + :end 2 + :key #'char-upcase) + "axcdefg") +(string= (substitute-if #\A #'(lambda (arg) (eql #\a arg)) + "aaaaaaaaaa" :count 2) "AAaaaaaaaa") +(string= (substitute-if #\A #'(lambda (arg) (eql #\a arg)) + "aaaaaaaaaa" :count -1) "aaaaaaaaaa") +(string= (substitute-if #\A #'(lambda (arg) (eql #\a arg)) + "aaaaaaaaaa" :count 0) "aaaaaaaaaa") +(string= (substitute-if #\A #'(lambda (arg) (eql #\a arg)) + "aaaaaaaaaa" :count nil) "AAAAAAAAAA") +(string= (substitute-if #\A #'(lambda (arg) (eql #\a arg)) + "aaaaaaaaaa" :count 100) "AAAAAAAAAA") +(string= (substitute-if #\A #'(lambda (arg) (eql #\a arg)) + "aaaaaaaaaa" :count 9) "AAAAAAAAAa") +(string= (substitute-if #\A #'(lambda (arg) (eql #\a arg)) + "aaaaaaaaaa" :count 9 :from-end t) "aAAAAAAAAA") +(string= (substitute-if #\A #'(lambda (arg) (eql #\a arg)) + "aaaaaaaaaa" + :start 2 + :end 8 + :count 3) + "aaAAAaaaaa") +(string= (substitute-if #\A #'(lambda (arg) (eql #\a arg)) + "aaaaaaaaaa" + :start 2 + :end 8 + :from-end t + :count 3) + "aaaaaAAAaa") +(string= (substitute-if #\x #'(lambda (arg) (eql #\A arg)) + "aaaaaaaaaa" + :start 2 + :end 8 + :from-end t + :count 3) + "aaaaaaaaaa") +(string= (substitute-if #\X #'(lambda (arg) (eql #\A arg)) + "aaaaaaaaaa" + :start 2 + :end 8 + :from-end t + :key #'char-upcase + :count 3) + "aaaaaXXXaa") +(string= (substitute-if #\X #'(lambda (arg) (char< #\D arg)) + "abcdefghij" + :start 2 + :end 8 + :from-end t + :key #'char-upcase + :count 3) + "abcdeXXXij") +(equalp (substitute-if 0 #'(lambda (arg) (= 1 arg)) #*1111) #*0000) +(equalp (substitute-if 0 #'(lambda (arg) (= 1 arg)) + #*1111 :start 1 :end nil) #*1000) +(equalp (substitute-if 0 #'(lambda (arg) (= 1 arg)) + #*1111 :start 1 :end 3) #*1001) +(equalp (substitute-if 0 #'(lambda (arg) (= 1 arg)) + #*11111111 :start 1 :end 7) #*10000001) +(equalp (substitute-if 0 #'(lambda (arg) (= 1 arg)) + #*11111111 :start 1 :end 7 :count 3) #*10001111) +(equalp (substitute-if 0 #'(lambda (arg) (= 1 arg)) + #*11111111 :start 1 :end 7 :count 3 :from-end t) + #*11110001) +(equalp (substitute-if 1 #'(lambda (arg) (= 1 arg)) + #*10101010 + :start 1 :end 7 :count 3 :from-end t + :key #'(lambda (x) (if (zerop x) 1 0))) + #*11111110) +(equalp (substitute-if 1 #'(lambda (arg) (>= 1 arg)) + #*10101010 + :start 1 :end 7 :count 3 :from-end t + :key #'(lambda (x) (if (zerop x) 1 0))) + #*10101110) + + + +(equal (substitute-if-not 'a #'(lambda (arg) (not (eq arg 'x))) '(x y z)) + '(a y z)) +(equal (substitute-if-not 'b #'(lambda (arg) (not (eq arg 'y))) '(x y z)) + '(x b z)) +(equal (substitute-if-not 'c #'(lambda (arg) (not (eq arg 'z))) '(x y z)) + '(x y c)) +(equal (substitute-if-not 'a #'(lambda (arg) (not (eq arg 'p))) '(x y z)) + '(x y z)) +(equal (substitute-if-not 'a #'(lambda (arg) (not (eq arg 'x))) '()) '()) +(equal (substitute-if-not #\x #'(lambda (arg) (not (char< #\b arg))) + '(#\a #\b #\c #\d #\e)) + '(#\a #\b #\x #\x #\x)) +(equal (substitute-if-not '(a) #'(lambda (arg) (not (eq arg 'x))) + '((x) (y) (z)) :key #'car) + '((a) (y) (z))) +(equal (substitute-if-not 'c #'(lambda (arg) (not (eq arg 'b))) + '(a b a b a b a b)) '(a c a c a c a c)) +(equal (substitute-if-not 'a #'(lambda (arg) (not (eq arg 'b))) + '(b b b)) '(a a a)) +(equal (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + '(a x b x c x d x e x f)) + '(a z b z c z d z e z f)) +(equal (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + '(a x b x c x d x e x f) :count nil) + '(a z b z c z d z e z f)) +(equal (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + '(a x b x c x d x e x f) :count 0) + '(a x b x c x d x e x f)) +(equal (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + '(a x b x c x d x e x f) :count -100) + '(a x b x c x d x e x f)) +(equal (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + '(a x b x c x d x e x f) :count 1) + '(a z b x c x d x e x f)) +(equal (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + '(a x b x c x d x e x f) :count 2) + '(a z b z c x d x e x f)) +(equal (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + '(a x b x c x d x e x f) :count 3) + '(a z b z c z d x e x f)) +(equal (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + '(a x b x c x d x e x f) :count 4) + '(a z b z c z d z e x f)) +(equal (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + '(a x b x c x d x e x f) :count 5) + '(a z b z c z d z e z f)) +(equal (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + '(a x b x c x d x e x f) :count 6) + '(a z b z c z d z e z f)) +(equal (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + '(a x b x c x d x e x f) :count 7) + '(a z b z c z d z e z f)) +(equal (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + '(a x b x c x d x e x f) :count nil :from-end t) + '(a z b z c z d z e z f)) +(equal (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + '(a x b x c x d x e x f) :count 0 :from-end t) + '(a x b x c x d x e x f)) +(equal (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + '(a x b x c x d x e x f) :count -100 :from-end t) + '(a x b x c x d x e x f)) +(equal (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + '(a x b x c x d x e x f) :count 1 :from-end t) + '(a x b x c x d x e z f)) +(equal (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + '(a x b x c x d x e x f) :count 2 :from-end t) + '(a x b x c x d z e z f)) +(equal (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + '(a x b x c x d x e x f) :count 3 :from-end t) + '(a x b x c z d z e z f)) +(equal (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + '(a x b x c x d x e x f) :count 4 :from-end t) + '(a x b z c z d z e z f)) +(equal (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + '(a x b x c x d x e x f) :count 5 :from-end t) + '(a z b z c z d z e z f)) +(equal (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + '(a x b x c x d x e x f) :count 6 :from-end t) + '(a z b z c z d z e z f)) +(equal (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + '(a x b x c x d x e x f) :count 7 :from-end t) + '(a z b z c z d z e z f)) +(equal (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + '(a x b x c x d x e x f) :start 2 :count 1) + '(a x b z c x d x e x f)) +(equal (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + '(a x b x c x d x e x f) :start 2 :end nil :count 1) + '(a x b z c x d x e x f)) +(equal (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + '(a x b x c x d x e x f) :start 2 :end 6 :count 100) + '(a x b z c z d x e x f)) +(equal (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + '(a x b x c x d x e x f) :start 2 :end 11 :count 100) + '(a x b z c z d z e z f)) +(equal (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + '(a x b x c x d x e x f) :start 2 :end 8 :count 10) + '(a x b z c z d z e x f)) +(equal (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + '(a x b x c x d x e x f) + :start 2 :end 8 :count 2 :from-end t) + '(a x b x c z d z e x f)) +(equal (substitute-if-not #\z #'(lambda (arg) (not (char< #\c arg))) + '(#\a #\b #\c #\d #\e #\f)) + '(#\a #\b #\c #\z #\z #\z)) +(equal (substitute-if-not "peace" #'(lambda (arg) (not (equal "war" arg))) + '("love" "hate" "war" "peace")) + '("love" "hate" "peace" "peace")) +(equal (substitute-if-not "peace" + #'(lambda (arg) (not (string-equal "war" arg))) + '("war" "War" "WAr" "WAR")) + '("peace" "peace" "peace" "peace")) +(equal (substitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg))) + '("war" "War" "WAr" "WAR") + :key #'string-upcase) + '("peace" "peace" "peace" "peace")) +(equal (substitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg))) + '("war" "War" "WAr" "WAR") + :start 1 + :end 2 + :key #'string-upcase) + '("war" "peace" "WAr" "WAR")) +(equal (substitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg))) + '("war" "War" "WAr" "WAR") + :start 1 + :end nil + :key #'string-upcase) + '("war" "peace" "peace" "peace")) +(equal (substitute-if-not "peace" #'(lambda (arg) (not (string= "war" arg))) + '("war" "War" "WAr" "WAR") + :key #'string-upcase) + '("war" "War" "WAr" "WAR")) +(equal (substitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg))) + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR") + :start 1 + :end 7 + :count 1 + :key #'string-upcase) + '("war" "peace" "WAr" "WAR" "war" "War" "WAr" "WAR")) +(equal (substitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg))) + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR") + :start 1 + :end 7 + :count 2 + :key #'string-upcase) + '("war" "peace" "peace" "WAR" "war" "War" "WAr" "WAR")) +(equal (substitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg))) + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR") + :start 1 + :end 7 + :count 2 + :from-end t + :key #'string-upcase) + '("war" "War" "WAr" "WAR" "war" "peace" "peace" "WAR")) +(equal (substitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg))) + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR") + :start 1 + :end 7 + :count 0 + :from-end t + :key #'string-upcase) + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) +(equal (substitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg))) + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR") + :start 1 + :end 7 + :count -2 + :from-end t + :key #'string-upcase) + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) +(equal (substitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg))) + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR") + :start 1 + :end 7 + :count nil + :from-end t + :key #'string-upcase) + '("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR")) +(equal (substitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg))) + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR") + :start 1 + :end 7 + :count 6 + :from-end t + :key #'string-upcase) + '("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR")) +(equal (substitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg))) + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR") + :start 1 + :end 7 + :count 7 + :from-end t + :key #'string-upcase) + '("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR")) +(equal (substitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg))) + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR") + :start 1 + :end 7 + :count 100 + :from-end t + :key #'string-upcase) + '("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR")) + + +(equalp (substitute-if-not 'a #'(lambda (arg) (not (eq arg 'x))) + #(x y z)) #(a y z)) +(equalp (substitute-if-not 'b #'(lambda (arg) (not (eq arg 'y))) + #(x y z)) #(x b z)) +(equalp (substitute-if-not 'c #'(lambda (arg) (not (eq arg 'z))) + #(x y z)) #(x y c)) +(equalp (substitute-if-not 'a #'(lambda (arg) (not (eq arg 'p))) + #(x y z)) #(x y z)) +(equalp (substitute-if-not 'a #'(lambda (arg) (not (eq arg 'x))) + #()) #()) +(equalp (substitute-if-not #\x #'(lambda (arg) (not (char< #\b arg))) + #(#\a #\b #\c #\d #\e)) + #(#\a #\b #\x #\x #\x)) +(equalp (substitute-if-not '(a) #'(lambda (arg) (not (eq arg 'x))) + #((x) (y) (z)) :key #'car) + #((a) (y) (z))) +(equalp (substitute-if-not 'c #'(lambda (arg) (not (eq arg 'b))) + #(a b a b a b a b)) #(a c a c a c a c)) +(equalp (substitute-if-not 'a #'(lambda (arg) (not (eq arg 'b))) + #(b b b)) #(a a a)) +(equalp (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + #(a x b x c x d x e x f)) + #(a z b z c z d z e z f)) +(equalp (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + #(a x b x c x d x e x f) :count nil) + #(a z b z c z d z e z f)) +(equalp (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + #(a x b x c x d x e x f) :count 0) + #(a x b x c x d x e x f)) +(equalp (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + #(a x b x c x d x e x f) :count -100) + #(a x b x c x d x e x f)) +(equalp (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + #(a x b x c x d x e x f) :count 1) + #(a z b x c x d x e x f)) +(equalp (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + #(a x b x c x d x e x f) :count 2) + #(a z b z c x d x e x f)) +(equalp (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + #(a x b x c x d x e x f) :count 3) + #(a z b z c z d x e x f)) +(equalp (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + #(a x b x c x d x e x f) :count 4) + #(a z b z c z d z e x f)) +(equalp (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + #(a x b x c x d x e x f) :count 5) + #(a z b z c z d z e z f)) +(equalp (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + #(a x b x c x d x e x f) :count 6) + #(a z b z c z d z e z f)) +(equalp (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + #(a x b x c x d x e x f) :count 7) + #(a z b z c z d z e z f)) +(equalp (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + #(a x b x c x d x e x f) :count nil :from-end t) + #(a z b z c z d z e z f)) +(equalp (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + #(a x b x c x d x e x f) :count 0 :from-end t) + #(a x b x c x d x e x f)) +(equalp (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + #(a x b x c x d x e x f) :count -100 :from-end t) + #(a x b x c x d x e x f)) +(equalp (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + #(a x b x c x d x e x f) :count 1 :from-end t) + #(a x b x c x d x e z f)) +(equalp (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + #(a x b x c x d x e x f) :count 2 :from-end t) + #(a x b x c x d z e z f)) +(equalp (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + #(a x b x c x d x e x f) :count 3 :from-end t) + #(a x b x c z d z e z f)) +(equalp (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + #(a x b x c x d x e x f) :count 4 :from-end t) + #(a x b z c z d z e z f)) +(equalp (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + #(a x b x c x d x e x f) :count 5 :from-end t) + #(a z b z c z d z e z f)) +(equalp (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + #(a x b x c x d x e x f) :count 6 :from-end t) + #(a z b z c z d z e z f)) +(equalp (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + #(a x b x c x d x e x f) :count 7 :from-end t) + #(a z b z c z d z e z f)) +(equalp (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + #(a x b x c x d x e x f) :start 2 :count 1) + #(a x b z c x d x e x f)) +(equalp (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + #(a x b x c x d x e x f) :start 2 :end nil :count 1) + #(a x b z c x d x e x f)) +(equalp (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + #(a x b x c x d x e x f) :start 2 :end 6 :count 100) + #(a x b z c z d x e x f)) +(equalp (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + #(a x b x c x d x e x f) :start 2 :end 11 :count 100) + #(a x b z c z d z e z f)) +(equalp (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + #(a x b x c x d x e x f) :start 2 :end 8 :count 10) + #(a x b z c z d z e x f)) +(equalp (substitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + #(a x b x c x d x e x f) + :start 2 :end 8 :count 2 :from-end t) + #(a x b x c z d z e x f)) +(equalp (substitute-if-not #\z #'(lambda (arg) (not (char< #\c arg))) + #(#\a #\b #\c #\d #\e #\f)) + #(#\a #\b #\c #\z #\z #\z)) +(equalp (substitute-if-not "peace" #'(lambda (arg) (not (equal "war" arg))) + #("love" "hate" "war" "peace")) + #("love" "hate" "peace" "peace")) +(equalp (substitute-if-not "peace" + #'(lambda (arg) (not (string-equal "war" arg))) + #("war" "War" "WAr" "WAR")) + #("peace" "peace" "peace" "peace")) +(equalp (substitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg))) + #("war" "War" "WAr" "WAR") + :key #'string-upcase) + #("peace" "peace" "peace" "peace")) +(equalp (substitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg))) + #("war" "War" "WAr" "WAR") + :start 1 + :end 2 + :key #'string-upcase) + #("war" "peace" "WAr" "WAR")) +(equalp (substitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg))) + #("war" "War" "WAr" "WAR") + :start 1 + :end nil + :key #'string-upcase) + #("war" "peace" "peace" "peace")) +(equalp (substitute-if-not "peace" #'(lambda (arg) (not (string= "war" arg))) + #("war" "War" "WAr" "WAR") + :key #'string-upcase) + #("war" "War" "WAr" "WAR")) +(equalp (substitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg))) + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR") + :start 1 + :end 7 + :count 1 + :key #'string-upcase) + #("war" "peace" "WAr" "WAR" "war" "War" "WAr" "WAR")) +(equalp (substitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg))) + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR") + :start 1 + :end 7 + :count 2 + :key #'string-upcase) + #("war" "peace" "peace" "WAR" "war" "War" "WAr" "WAR")) +(equalp (substitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg))) + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR") + :start 1 + :end 7 + :count 2 + :from-end t + :key #'string-upcase) + #("war" "War" "WAr" "WAR" "war" "peace" "peace" "WAR")) +(equalp (substitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg))) + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR") + :start 1 + :end 7 + :count 0 + :from-end t + :key #'string-upcase) + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) +(equalp (substitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg))) + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR") + :start 1 + :end 7 + :count -2 + :from-end t + :key #'string-upcase) + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) +(equalp (substitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg))) + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR") + :start 1 + :end 7 + :count nil + :from-end t + :key #'string-upcase) + #("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR")) +(equalp (substitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg))) + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR") + :start 1 + :end 7 + :count 6 + :from-end t + :key #'string-upcase) + #("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR")) +(equalp (substitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg))) + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR") + :start 1 + :end 7 + :count 7 + :from-end t + :key #'string-upcase) + #("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR")) +(equalp (substitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg))) + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR") + :start 1 + :end 7 + :count 100 + :from-end t + :key #'string-upcase) + #("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR")) + +(string= (substitute-if-not #\A #'(lambda (arg) (not (eql #\a arg))) "abcabc") + "AbcAbc") +(string= (substitute-if-not #\A #'(lambda (arg) (not (eql #\a arg))) "") "") +(string= (substitute-if-not #\A #'(lambda (arg) (not (eql #\a arg))) "xyz") + "xyz") +(string= (substitute-if-not #\A #'(lambda (arg) (not (eql #\a arg))) + "aaaaaaaaaa" :start 5 :end nil) "aaaaaAAAAA") +(string= (substitute-if-not #\x #'(lambda (arg) (not (char< #\5 arg))) + "0123456789") "012345xxxx") +(string= (substitute-if-not #\x #'(lambda (arg) (not (char> #\5 arg))) + "0123456789") "xxxxx56789") +(string= (substitute-if-not #\x #'(lambda (arg) (not (char> #\D arg))) + "abcdefg" + :key #'char-upcase) + "xxxdefg") +(string= (substitute-if-not #\x #'(lambda (arg) (not (char> #\D arg))) + "abcdefg" + :start 1 + :end 2 + :key #'char-upcase) + "axcdefg") +(string= (substitute-if-not #\A #'(lambda (arg) (not (eql #\a arg))) + "aaaaaaaaaa" :count 2) "AAaaaaaaaa") +(string= (substitute-if-not #\A #'(lambda (arg) (not (eql #\a arg))) + "aaaaaaaaaa" :count -1) "aaaaaaaaaa") +(string= (substitute-if-not #\A #'(lambda (arg) (not (eql #\a arg))) + "aaaaaaaaaa" :count 0) "aaaaaaaaaa") +(string= (substitute-if-not #\A #'(lambda (arg) (not (eql #\a arg))) + "aaaaaaaaaa" :count nil) "AAAAAAAAAA") +(string= (substitute-if-not #\A #'(lambda (arg) (not (eql #\a arg))) + "aaaaaaaaaa" :count 100) "AAAAAAAAAA") +(string= (substitute-if-not #\A #'(lambda (arg) (not (eql #\a arg))) + "aaaaaaaaaa" :count 9) "AAAAAAAAAa") +(string= (substitute-if-not #\A #'(lambda (arg) (not (eql #\a arg))) + "aaaaaaaaaa" :count 9 :from-end t) "aAAAAAAAAA") +(string= (substitute-if-not #\A #'(lambda (arg) (not (eql #\a arg))) + "aaaaaaaaaa" + :start 2 + :end 8 + :count 3) + "aaAAAaaaaa") +(string= (substitute-if-not #\A #'(lambda (arg) (not (eql #\a arg))) + "aaaaaaaaaa" + :start 2 + :end 8 + :from-end t + :count 3) + "aaaaaAAAaa") +(string= (substitute-if-not #\x #'(lambda (arg) (not (eql #\A arg))) + "aaaaaaaaaa" + :start 2 + :end 8 + :from-end t + :count 3) + "aaaaaaaaaa") +(string= (substitute-if-not #\X #'(lambda (arg) (not (eql #\A arg))) + "aaaaaaaaaa" + :start 2 + :end 8 + :from-end t + :key #'char-upcase + :count 3) + "aaaaaXXXaa") +(string= (substitute-if-not #\X #'(lambda (arg) (not (char< #\D arg))) + "abcdefghij" + :start 2 + :end 8 + :from-end t + :key #'char-upcase + :count 3) + "abcdeXXXij") +(equalp (substitute-if-not 0 #'(lambda (arg) (not (= 1 arg))) #*1111) #*0000) +(equalp (substitute-if-not 0 #'(lambda (arg) (not (= 1 arg))) + #*1111 :start 1 :end nil) #*1000) +(equalp (substitute-if-not 0 #'(lambda (arg) (not (= 1 arg))) + #*1111 :start 1 :end 3) #*1001) +(equalp (substitute-if-not 0 #'(lambda (arg) (not (= 1 arg))) + #*11111111 :start 1 :end 7) #*10000001) +(equalp (substitute-if-not 0 #'(lambda (arg) (not (= 1 arg))) + #*11111111 :start 1 :end 7 :count 3) #*10001111) +(equalp (substitute-if-not 0 #'(lambda (arg) (not (= 1 arg))) + #*11111111 :start 1 :end 7 :count 3 :from-end t) + #*11110001) +(equalp (substitute-if-not 1 #'(lambda (arg) (not (= 1 arg))) + #*10101010 + :start 1 :end 7 :count 3 :from-end t + :key #'(lambda (x) (if (zerop x) 1 0))) + #*11111110) +(equalp (substitute-if-not 1 #'(lambda (arg) (not (>= 1 arg))) + #*10101010 + :start 1 :end 7 :count 3 :from-end t + :key #'(lambda (x) (if (zerop x) 1 0))) + #*10101110) + + +(equal (nsubstitute 'a 'x (copy-seq '(x y z))) '(a y z)) +(equal (nsubstitute 'b 'y (copy-seq '(x y z))) '(x b z)) +(equal (nsubstitute 'c 'z (copy-seq '(x y z))) '(x y c)) +(equal (nsubstitute 'a 'p (copy-seq '(x y z))) '(x y z)) +(equal (nsubstitute 'a 'x (copy-seq '())) '()) +(equal (nsubstitute #\x #\b (copy-seq '(#\a #\b #\c #\d #\e)) :test #'char<) + '(#\a #\b #\x #\x #\x)) +(equal (nsubstitute #\x #\b (copy-seq '(#\a #\b #\c #\d #\e)) + :test-not (complement #'char<)) + '(#\a #\b #\x #\x #\x)) +(equal (nsubstitute '(a) 'x (copy-seq '((x) (y) (z))) :key #'car) + '((a) (y) (z))) +(equal (nsubstitute 'c 'b (copy-seq '(a b a b a b a b))) '(a c a c a c a c)) +(equal (nsubstitute 'a 'b (copy-seq '(b b b))) '(a a a)) +(equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f))) + '(a z b z c z d z e z f)) +(equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)) :count nil) + '(a z b z c z d z e z f)) +(equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)) :count 0) + '(a x b x c x d x e x f)) +(equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)) :count -100) + '(a x b x c x d x e x f)) +(equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)) :count 1) + '(a z b x c x d x e x f)) +(equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)) :count 2) + '(a z b z c x d x e x f)) +(equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)) :count 3) + '(a z b z c z d x e x f)) +(equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)) :count 4) + '(a z b z c z d z e x f)) +(equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)) :count 5) + '(a z b z c z d z e z f)) +(equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)) :count 6) + '(a z b z c z d z e z f)) +(equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)) :count 7) + '(a z b z c z d z e z f)) +(equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)) + :count nil :from-end t) + '(a z b z c z d z e z f)) +(equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)) + :count 0 :from-end t) + '(a x b x c x d x e x f)) +(equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)) + :count -100 :from-end t) + '(a x b x c x d x e x f)) +(equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)) + :count 1 :from-end t) + '(a x b x c x d x e z f)) +(equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)) + :count 2 :from-end t) + '(a x b x c x d z e z f)) +(equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)) + :count 3 :from-end t) + '(a x b x c z d z e z f)) +(equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)) + :count 4 :from-end t) + '(a x b z c z d z e z f)) +(equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)) + :count 5 :from-end t) + '(a z b z c z d z e z f)) +(equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)) + :count 6 :from-end t) + '(a z b z c z d z e z f)) +(equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)) + :count 7 :from-end t) + '(a z b z c z d z e z f)) +(equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)) + :start 2 :count 1) + '(a x b z c x d x e x f)) +(equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)) + :start 2 :end nil :count 1) + '(a x b z c x d x e x f)) +(equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)) + :start 2 :end 6 :count 100) + '(a x b z c z d x e x f)) +(equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)) + :start 2 :end 11 :count 100) + '(a x b z c z d z e z f)) +(equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)) + :start 2 :end 8 :count 10) + '(a x b z c z d z e x f)) +(equal (nsubstitute 'z 'x (copy-seq '(a x b x c x d x e x f)) + :start 2 :end 8 :count 2 :from-end t) + '(a x b x c z d z e x f)) +(equal (nsubstitute #\z #\c (copy-seq '(#\a #\b #\c #\d #\e #\f)) + :test #'char<) + '(#\a #\b #\c #\z #\z #\z)) +(equal (nsubstitute #\z #\c (copy-seq '(#\a #\b #\c #\d #\e #\f)) + :test-not (complement #'char<)) + '(#\a #\b #\c #\z #\z #\z)) +(equal (nsubstitute "peace" "war" (copy-seq '("love" "hate" "war" "peace")) + :test #'equal) + '("love" "hate" "peace" "peace")) +(equal (nsubstitute "peace" "war" (copy-seq '("love" "hate" "war" "peace")) + :test-not (complement #'equal)) + '("love" "hate" "peace" "peace")) +(equal (nsubstitute "peace" "war" (copy-seq '("war" "War" "WAr" "WAR")) + :test #'string-equal) + '("peace" "peace" "peace" "peace")) +(equal (nsubstitute "peace" "war" (copy-seq '("war" "War" "WAr" "WAR")) + :test-not (complement #'string-equal)) + '("peace" "peace" "peace" "peace")) +(equal (nsubstitute "peace" "WAR" (copy-seq '("war" "War" "WAr" "WAR")) + :test #'string=) + '("war" "War" "WAr" "peace")) +(equal (nsubstitute "peace" "WAR" (copy-seq '("war" "War" "WAr" "WAR")) + :test-not (complement #'string=)) + '("war" "War" "WAr" "peace")) +(equal (nsubstitute "peace" "WAR" (copy-seq '("war" "War" "WAr" "WAR")) + :test #'string= + :key #'string-upcase) + '("peace" "peace" "peace" "peace")) +(equal (nsubstitute "peace" "WAR" (copy-seq '("war" "War" "WAr" "WAR")) + :test-not (complement #'string=) + :key #'string-upcase) + '("peace" "peace" "peace" "peace")) +(equal (nsubstitute "peace" "WAR" (copy-seq '("war" "War" "WAr" "WAR")) + :start 1 + :end 2 + :test #'string= + :key #'string-upcase) + '("war" "peace" "WAr" "WAR")) +(equal (nsubstitute "peace" "WAR" (copy-seq '("war" "War" "WAr" "WAR")) + :start 1 + :end 2 + :test-not (complement #'string=) + :key #'string-upcase) + '("war" "peace" "WAr" "WAR")) +(equal (nsubstitute "peace" "WAR" (copy-seq '("war" "War" "WAr" "WAR")) + :start 1 + :end nil + :test #'string= + :key #'string-upcase) + '("war" "peace" "peace" "peace")) +(equal (nsubstitute "peace" "WAR" (copy-seq '("war" "War" "WAr" "WAR")) + :start 1 + :end nil + :test-not (complement #'string=) + :key #'string-upcase) + '("war" "peace" "peace" "peace")) +(equal (nsubstitute "peace" "war" (copy-seq '("war" "War" "WAr" "WAR")) + :test #'string= + :key #'string-upcase) + '("war" "War" "WAr" "WAR")) +(equal (nsubstitute "peace" "war" (copy-seq '("war" "War" "WAr" "WAR")) + :test-not (complement #'string=) + :key #'string-upcase) + '("war" "War" "WAr" "WAR")) +(equal (nsubstitute "peace" "WAR" + (copy-seq + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) + :start 1 + :end 7 + :count 1 + :test-not (complement #'string=) + :key #'string-upcase) + '("war" "peace" "WAr" "WAR" "war" "War" "WAr" "WAR")) +(equal (nsubstitute "peace" "WAR" + (copy-seq '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) + :start 1 + :end 7 + :count 2 + :test-not (complement #'string=) + :key #'string-upcase) + '("war" "peace" "peace" "WAR" "war" "War" "WAr" "WAR")) +(equal (nsubstitute "peace" "WAR" + (copy-seq + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) + :start 1 + :end 7 + :count 2 + :from-end t + :test-not (complement #'string=) + :key #'string-upcase) + '("war" "War" "WAr" "WAR" "war" "peace" "peace" "WAR")) +(equal (nsubstitute "peace" "WAR" + (copy-seq + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) + :start 1 + :end 7 + :count 0 + :from-end t + :test-not (complement #'string=) + :key #'string-upcase) + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) +(equal (nsubstitute "peace" "WAR" + (copy-seq + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) + :start 1 + :end 7 + :count -2 + :from-end t + :test-not (complement #'string=) + :key #'string-upcase) + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) +(equal (nsubstitute "peace" "WAR" + (copy-seq + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) + :start 1 + :end 7 + :count nil + :from-end t + :test-not (complement #'string=) + :key #'string-upcase) + '("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR")) +(equal (nsubstitute "peace" "WAR" + (copy-seq + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) + :start 1 + :end 7 + :count 6 + :from-end t + :test-not (complement #'string=) + :key #'string-upcase) + '("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR")) +(equal (nsubstitute "peace" "WAR" + (copy-seq + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) + :start 1 + :end 7 + :count 7 + :from-end t + :test-not (complement #'string=) + :key #'string-upcase) + '("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR")) +(equal (nsubstitute "peace" "WAR" + (copy-seq + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) + :start 1 + :end 7 + :count 100 + :from-end t + :test-not (complement #'string=) + :key #'string-upcase) + '("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR")) + + +(equalp (nsubstitute 'a 'x (copy-seq #(x y z))) #(a y z)) +(equalp (nsubstitute 'b 'y (copy-seq #(x y z))) #(x b z)) +(equalp (nsubstitute 'c 'z (copy-seq #(x y z))) #(x y c)) +(equalp (nsubstitute 'a 'p (copy-seq #(x y z))) #(x y z)) +(equalp (nsubstitute 'a 'x (copy-seq #())) #()) +(equalp (nsubstitute #\x #\b (copy-seq #(#\a #\b #\c #\d #\e)) :test #'char<) + #(#\a #\b #\x #\x #\x)) +(equalp (nsubstitute #\x #\b (copy-seq #(#\a #\b #\c #\d #\e)) + :test-not (complement #'char<)) + #(#\a #\b #\x #\x #\x)) +(equalp (nsubstitute '(a) 'x (copy-seq #((x) (y) (z))) :key #'car) + #((a) (y) (z))) +(equalp (nsubstitute 'c 'b (copy-seq #(a b a b a b a b))) #(a c a c a c a c)) +(equalp (nsubstitute 'a 'b (copy-seq #(b b b))) #(a a a)) +(equalp (nsubstitute 'z 'x (copy-seq #(a x b x c x d x e x f))) + #(a z b z c z d z e z f)) +(equalp (nsubstitute 'z 'x (copy-seq #(a x b x c x d x e x f)) :count nil) + #(a z b z c z d z e z f)) +(equalp (nsubstitute 'z 'x (copy-seq #(a x b x c x d x e x f)) :count 0) + #(a x b x c x d x e x f)) +(equalp (nsubstitute 'z 'x (copy-seq #(a x b x c x d x e x f)) :count -100) + #(a x b x c x d x e x f)) +(equalp (nsubstitute 'z 'x (copy-seq #(a x b x c x d x e x f)) :count 1) + #(a z b x c x d x e x f)) +(equalp (nsubstitute 'z 'x (copy-seq #(a x b x c x d x e x f)) :count 2) + #(a z b z c x d x e x f)) +(equalp (nsubstitute 'z 'x (copy-seq #(a x b x c x d x e x f)) :count 3) + #(a z b z c z d x e x f)) +(equalp (nsubstitute 'z 'x (copy-seq #(a x b x c x d x e x f)) :count 4) + #(a z b z c z d z e x f)) +(equalp (nsubstitute 'z 'x (copy-seq #(a x b x c x d x e x f)) :count 5) + #(a z b z c z d z e z f)) +(equalp (nsubstitute 'z 'x (copy-seq #(a x b x c x d x e x f)) :count 6) + #(a z b z c z d z e z f)) +(equalp (nsubstitute 'z 'x (copy-seq #(a x b x c x d x e x f)) :count 7) + #(a z b z c z d z e z f)) +(equalp (nsubstitute 'z 'x (copy-seq #(a x b x c x d x e x f)) + :count nil :from-end t) + #(a z b z c z d z e z f)) +(equalp (nsubstitute 'z 'x (copy-seq #(a x b x c x d x e x f)) + :count 0 :from-end t) + #(a x b x c x d x e x f)) +(equalp (nsubstitute 'z 'x (copy-seq #(a x b x c x d x e x f)) + :count -100 :from-end t) + #(a x b x c x d x e x f)) +(equalp (nsubstitute 'z 'x (copy-seq #(a x b x c x d x e x f)) + :count 1 :from-end t) + #(a x b x c x d x e z f)) +(equalp (nsubstitute 'z 'x (copy-seq #(a x b x c x d x e x f)) + :count 2 :from-end t) + #(a x b x c x d z e z f)) +(equalp (nsubstitute 'z 'x (copy-seq #(a x b x c x d x e x f)) + :count 3 :from-end t) + #(a x b x c z d z e z f)) +(equalp (nsubstitute 'z 'x (copy-seq #(a x b x c x d x e x f)) + :count 4 :from-end t) + #(a x b z c z d z e z f)) +(equalp (nsubstitute 'z 'x (copy-seq #(a x b x c x d x e x f)) + :count 5 :from-end t) + #(a z b z c z d z e z f)) +(equalp (nsubstitute 'z 'x (copy-seq #(a x b x c x d x e x f)) + :count 6 :from-end t) + #(a z b z c z d z e z f)) +(equalp (nsubstitute 'z 'x (copy-seq #(a x b x c x d x e x f)) + :count 7 :from-end t) + #(a z b z c z d z e z f)) +(equalp (nsubstitute 'z 'x (copy-seq #(a x b x c x d x e x f)) + :start 2 :count 1) + #(a x b z c x d x e x f)) +(equalp (nsubstitute 'z 'x (copy-seq #(a x b x c x d x e x f)) + :start 2 :end nil :count 1) + #(a x b z c x d x e x f)) +(equalp (nsubstitute 'z 'x (copy-seq #(a x b x c x d x e x f)) + :start 2 :end 6 :count 100) + #(a x b z c z d x e x f)) +(equalp (nsubstitute 'z 'x (copy-seq #(a x b x c x d x e x f)) + :start 2 :end 11 :count 100) + #(a x b z c z d z e z f)) +(equalp (nsubstitute 'z 'x (copy-seq #(a x b x c x d x e x f)) + :start 2 :end 8 :count 10) + #(a x b z c z d z e x f)) +(equalp (nsubstitute 'z 'x (copy-seq #(a x b x c x d x e x f)) + :start 2 :end 8 :count 2 :from-end t) + #(a x b x c z d z e x f)) +(equalp (nsubstitute #\z #\c (copy-seq #(#\a #\b #\c #\d #\e #\f)) + :test #'char<) + #(#\a #\b #\c #\z #\z #\z)) +(equalp (nsubstitute #\z #\c (copy-seq #(#\a #\b #\c #\d #\e #\f)) + :test-not (complement #'char<)) + #(#\a #\b #\c #\z #\z #\z)) +(equalp (nsubstitute "peace" "war" (copy-seq #("love" "hate" "war" "peace")) + :test #'equal) + #("love" "hate" "peace" "peace")) +(equalp (nsubstitute "peace" "war" (copy-seq #("love" "hate" "war" "peace")) + :test-not (complement #'equal)) + #("love" "hate" "peace" "peace")) +(equalp (nsubstitute "peace" "war" (copy-seq #("war" "War" "WAr" "WAR")) + :test #'string-equal) + #("peace" "peace" "peace" "peace")) +(equalp (nsubstitute "peace" "war" (copy-seq #("war" "War" "WAr" "WAR")) + :test-not (complement #'string-equal)) + #("peace" "peace" "peace" "peace")) +(equalp (nsubstitute "peace" "WAR" (copy-seq #("war" "War" "WAr" "WAR")) + :test #'string=) + #("war" "War" "WAr" "peace")) +(equalp (nsubstitute "peace" "WAR" (copy-seq #("war" "War" "WAr" "WAR")) + :test-not (complement #'string=)) + #("war" "War" "WAr" "peace")) +(equalp (nsubstitute "peace" "WAR" (copy-seq #("war" "War" "WAr" "WAR")) + :test #'string= + :key #'string-upcase) + #("peace" "peace" "peace" "peace")) +(equalp (nsubstitute "peace" "WAR" (copy-seq #("war" "War" "WAr" "WAR")) + :test-not (complement #'string=) + :key #'string-upcase) + #("peace" "peace" "peace" "peace")) +(equalp (nsubstitute "peace" "WAR" (copy-seq #("war" "War" "WAr" "WAR")) + :start 1 + :end 2 + :test #'string= + :key #'string-upcase) + #("war" "peace" "WAr" "WAR")) +(equalp (nsubstitute "peace" "WAR" (copy-seq #("war" "War" "WAr" "WAR")) + :start 1 + :end 2 + :test-not (complement #'string=) + :key #'string-upcase) + #("war" "peace" "WAr" "WAR")) +(equalp (nsubstitute "peace" "WAR" (copy-seq #("war" "War" "WAr" "WAR")) + :start 1 + :end nil + :test #'string= + :key #'string-upcase) + #("war" "peace" "peace" "peace")) +(equalp (nsubstitute "peace" "WAR" (copy-seq #("war" "War" "WAr" "WAR")) + :start 1 + :end nil + :test-not (complement #'string=) + :key #'string-upcase) + #("war" "peace" "peace" "peace")) +(equalp (nsubstitute "peace" "war" (copy-seq #("war" "War" "WAr" "WAR")) + :test #'string= + :key #'string-upcase) + #("war" "War" "WAr" "WAR")) +(equalp (nsubstitute "peace" "war" (copy-seq #("war" "War" "WAr" "WAR")) + :test-not (complement #'string=) + :key #'string-upcase) + #("war" "War" "WAr" "WAR")) +(equalp (nsubstitute "peace" "WAR" + (copy-seq + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) + :start 1 + :end 7 + :count 1 + :test-not (complement #'string=) + :key #'string-upcase) + #("war" "peace" "WAr" "WAR" "war" "War" "WAr" "WAR")) +(equalp (nsubstitute "peace" "WAR" + (copy-seq + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) + :start 1 + :end 7 + :count 2 + :test-not (complement #'string=) + :key #'string-upcase) + #("war" "peace" "peace" "WAR" "war" "War" "WAr" "WAR")) +(equalp (nsubstitute "peace" "WAR" + (copy-seq + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) + :start 1 + :end 7 + :count 2 + :from-end t + :test-not (complement #'string=) + :key #'string-upcase) + #("war" "War" "WAr" "WAR" "war" "peace" "peace" "WAR")) +(equalp (nsubstitute "peace" "WAR" + (copy-seq + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) + :start 1 + :end 7 + :count 0 + :from-end t + :test-not (complement #'string=) + :key #'string-upcase) + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) +(equalp (nsubstitute "peace" "WAR" + (copy-seq + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) + :start 1 + :end 7 + :count -2 + :from-end t + :test-not (complement #'string=) + :key #'string-upcase) + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) +(equalp (nsubstitute "peace" "WAR" + (copy-seq + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) + :start 1 + :end 7 + :count nil + :from-end t + :test-not (complement #'string=) + :key #'string-upcase) + #("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR")) +(equalp (nsubstitute "peace" "WAR" + (copy-seq + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) + :start 1 + :end 7 + :count 6 + :from-end t + :test-not (complement #'string=) + :key #'string-upcase) + #("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR")) +(equalp (nsubstitute "peace" "WAR" + (copy-seq + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) + :start 1 + :end 7 + :count 7 + :from-end t + :test-not (complement #'string=) + :key #'string-upcase) + #("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR")) +(equalp (nsubstitute "peace" "WAR" + (copy-seq + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) + :start 1 + :end 7 + :count 100 + :from-end t + :test-not (complement #'string=) + :key #'string-upcase) + #("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR")) +(string= (nsubstitute #\A #\a (copy-seq "abcabc")) "AbcAbc") +(string= (nsubstitute #\A #\a (copy-seq "")) "") +(string= (nsubstitute #\A #\a (copy-seq "xyz")) "xyz") +(string= (nsubstitute #\A #\a (copy-seq "aaaaaaaaaa") :start 5 :end nil) + "aaaaaAAAAA") +(string= (nsubstitute #\x #\5 (copy-seq "0123456789") :test #'char<) + "012345xxxx") +(string= (nsubstitute #\x #\5 (copy-seq "0123456789") :test #'char>) + "xxxxx56789") +(string= (nsubstitute #\x #\D (copy-seq "abcdefg") + :key #'char-upcase + :test #'char>) + "xxxdefg") +(string= (nsubstitute #\x #\D (copy-seq "abcdefg") + :start 1 + :end 2 + :key #'char-upcase + :test #'char>) + "axcdefg") +(string= (nsubstitute #\A #\a (copy-seq "aaaaaaaaaa") :count 2) "AAaaaaaaaa") +(string= (nsubstitute #\A #\a (copy-seq "aaaaaaaaaa") :count -1) "aaaaaaaaaa") +(string= (nsubstitute #\A #\a (copy-seq "aaaaaaaaaa") :count 0) "aaaaaaaaaa") +(string= (nsubstitute #\A #\a (copy-seq "aaaaaaaaaa") :count nil) "AAAAAAAAAA") +(string= (nsubstitute #\A #\a (copy-seq "aaaaaaaaaa") :count 100) "AAAAAAAAAA") +(string= (nsubstitute #\A #\a (copy-seq "aaaaaaaaaa") :count 9) "AAAAAAAAAa") +(string= (nsubstitute #\A #\a (copy-seq "aaaaaaaaaa") :count 9 :from-end t) + "aAAAAAAAAA") +(string= (nsubstitute #\A #\a (copy-seq "aaaaaaaaaa") + :start 2 + :end 8 + :count 3) + "aaAAAaaaaa") +(string= (nsubstitute #\A #\a (copy-seq "aaaaaaaaaa") + :start 2 + :end 8 + :from-end t + :count 3) + "aaaaaAAAaa") +(string= (nsubstitute #\x #\A (copy-seq "aaaaaaaaaa") + :start 2 + :end 8 + :from-end t + :count 3) + "aaaaaaaaaa") +(string= (nsubstitute #\X #\A (copy-seq "aaaaaaaaaa") + :start 2 + :end 8 + :from-end t + :key #'char-upcase + :count 3) + "aaaaaXXXaa") +(string= (nsubstitute #\X #\D (copy-seq "abcdefghij") + :start 2 + :end 8 + :from-end t + :key #'char-upcase + :test #'char< + :count 3) + "abcdeXXXij") +(equalp (nsubstitute 0 1 (copy-seq #*1111)) #*0000) +(equalp (nsubstitute 0 1 (copy-seq #*1111) :start 1 :end nil) #*1000) +(equalp (nsubstitute 0 1 (copy-seq #*1111) :start 1 :end 3) #*1001) +(equalp (nsubstitute 0 1 (copy-seq #*11111111) :start 1 :end 7) #*10000001) +(equalp (nsubstitute 0 1 (copy-seq #*11111111) :start 1 :end 7 :count 3) + #*10001111) +(equalp (nsubstitute 0 1 (copy-seq #*11111111) + :start 1 :end 7 :count 3 :from-end t) + #*11110001) +(equalp (nsubstitute 1 1 (copy-seq #*10101010) + :start 1 :end 7 :count 3 :from-end t + :key #'(lambda (x) (if (zerop x) 1 0))) + #*11111110) +(equalp (nsubstitute 1 1 (copy-seq #*10101010) + :start 1 :end 7 :count 3 :from-end t + :key #'(lambda (x) (if (zerop x) 1 0)) + :test #'>=) + #*10101110) + + + +(equal (nsubstitute-if 'a #'(lambda (arg) (eq arg 'x)) (copy-seq '(x y z))) + '(a y z)) +(equal (nsubstitute-if 'b #'(lambda (arg) (eq arg 'y)) (copy-seq '(x y z))) + '(x b z)) +(equal (nsubstitute-if 'c #'(lambda (arg) (eq arg 'z)) (copy-seq '(x y z))) + '(x y c)) +(equal (nsubstitute-if 'a #'(lambda (arg) (eq arg 'p)) (copy-seq '(x y z))) + '(x y z)) +(equal (nsubstitute-if 'a #'(lambda (arg) (eq arg 'x)) (copy-seq '())) + '()) +(equal (nsubstitute-if #\x #'(lambda (arg) (char< #\b arg)) + (copy-seq '(#\a #\b #\c #\d #\e))) + '(#\a #\b #\x #\x #\x)) +(equal (nsubstitute-if '(a) #'(lambda (arg) (eq arg 'x)) + (copy-seq '((x) (y) (z))) :key #'car) + '((a) (y) (z))) +(equal (nsubstitute-if 'c #'(lambda (arg) (eq arg 'b)) + (copy-seq '(a b a b a b a b))) '(a c a c a c a c)) +(equal (nsubstitute-if 'a #'(lambda (arg) (eq arg 'b)) + (copy-seq '(b b b))) '(a a a)) +(equal (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x)) + (copy-seq '(a x b x c x d x e x f))) + '(a z b z c z d z e z f)) +(equal (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x)) + (copy-seq '(a x b x c x d x e x f)) :count nil) + '(a z b z c z d z e z f)) +(equal (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x)) + (copy-seq '(a x b x c x d x e x f)) :count 0) + '(a x b x c x d x e x f)) +(equal (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x)) + (copy-seq '(a x b x c x d x e x f)) :count -100) + '(a x b x c x d x e x f)) +(equal (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x)) + (copy-seq '(a x b x c x d x e x f)) :count 1) + '(a z b x c x d x e x f)) +(equal (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x)) + (copy-seq '(a x b x c x d x e x f)) :count 2) + '(a z b z c x d x e x f)) +(equal (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x)) + (copy-seq '(a x b x c x d x e x f)) :count 3) + '(a z b z c z d x e x f)) +(equal (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x)) + (copy-seq '(a x b x c x d x e x f)) :count 4) + '(a z b z c z d z e x f)) +(equal (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x)) + (copy-seq '(a x b x c x d x e x f)) :count 5) + '(a z b z c z d z e z f)) +(equal (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x)) + (copy-seq '(a x b x c x d x e x f)) :count 6) + '(a z b z c z d z e z f)) +(equal (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x)) + (copy-seq '(a x b x c x d x e x f)) :count 7) + '(a z b z c z d z e z f)) +(equal (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x)) + (copy-seq '(a x b x c x d x e x f)) + :count nil :from-end t) + '(a z b z c z d z e z f)) +(equal (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x)) + (copy-seq '(a x b x c x d x e x f)) :count 0 :from-end t) + '(a x b x c x d x e x f)) +(equal (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x)) + (copy-seq '(a x b x c x d x e x f)) + :count -100 :from-end t) + '(a x b x c x d x e x f)) +(equal (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x)) + (copy-seq '(a x b x c x d x e x f)) + :count 1 :from-end t) + '(a x b x c x d x e z f)) +(equal (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x)) + (copy-seq '(a x b x c x d x e x f)) + :count 2 :from-end t) + '(a x b x c x d z e z f)) +(equal (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x)) + (copy-seq '(a x b x c x d x e x f)) + :count 3 :from-end t) + '(a x b x c z d z e z f)) +(equal (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x)) + (copy-seq '(a x b x c x d x e x f)) + :count 4 :from-end t) + '(a x b z c z d z e z f)) +(equal (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x)) + (copy-seq '(a x b x c x d x e x f)) + :count 5 :from-end t) + '(a z b z c z d z e z f)) +(equal (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x)) + (copy-seq '(a x b x c x d x e x f)) + :count 6 :from-end t) + '(a z b z c z d z e z f)) +(equal (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x)) + (copy-seq '(a x b x c x d x e x f)) + :count 7 :from-end t) + '(a z b z c z d z e z f)) +(equal (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x)) + (copy-seq '(a x b x c x d x e x f)) :start 2 :count 1) + '(a x b z c x d x e x f)) +(equal (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x)) + (copy-seq '(a x b x c x d x e x f)) + :start 2 :end nil :count 1) + '(a x b z c x d x e x f)) +(equal (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x)) + (copy-seq '(a x b x c x d x e x f)) + :start 2 :end 6 :count 100) + '(a x b z c z d x e x f)) +(equal (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x)) + (copy-seq '(a x b x c x d x e x f)) + :start 2 :end 11 :count 100) + '(a x b z c z d z e z f)) +(equal (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x)) + (copy-seq '(a x b x c x d x e x f)) + :start 2 :end 8 :count 10) + '(a x b z c z d z e x f)) +(equal (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x)) + (copy-seq '(a x b x c x d x e x f)) + :start 2 :end 8 :count 2 :from-end t) + '(a x b x c z d z e x f)) +(equal (nsubstitute-if #\z #'(lambda (arg) (char< #\c arg)) + (copy-seq '(#\a #\b #\c #\d #\e #\f))) + '(#\a #\b #\c #\z #\z #\z)) +(equal (nsubstitute-if "peace" #'(lambda (arg) (equal "war" arg)) + (copy-seq '("love" "hate" "war" "peace"))) + '("love" "hate" "peace" "peace")) +(equal (nsubstitute-if "peace" #'(lambda (arg) (string-equal "war" arg)) + (copy-seq '("war" "War" "WAr" "WAR"))) + '("peace" "peace" "peace" "peace")) +(equal (nsubstitute-if "peace" #'(lambda (arg) (string= "WAR" arg)) + (copy-seq '("war" "War" "WAr" "WAR")) + :key #'string-upcase) + '("peace" "peace" "peace" "peace")) +(equal (nsubstitute-if "peace" #'(lambda (arg) (string= "WAR" arg)) + (copy-seq '("war" "War" "WAr" "WAR")) + :start 1 + :end 2 + :key #'string-upcase) + '("war" "peace" "WAr" "WAR")) +(equal (nsubstitute-if "peace" #'(lambda (arg) (string= "WAR" arg)) + (copy-seq '("war" "War" "WAr" "WAR")) + :start 1 + :end nil + :key #'string-upcase) + '("war" "peace" "peace" "peace")) +(equal (nsubstitute-if "peace" #'(lambda (arg) (string= "war" arg)) + (copy-seq '("war" "War" "WAr" "WAR")) + :key #'string-upcase) + '("war" "War" "WAr" "WAR")) +(equal (nsubstitute-if "peace" #'(lambda (arg) (string= "WAR" arg)) + (copy-seq + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) + :start 1 + :end 7 + :count 1 + :key #'string-upcase) + '("war" "peace" "WAr" "WAR" "war" "War" "WAr" "WAR")) +(equal (nsubstitute-if "peace" #'(lambda (arg) (string= "WAR" arg)) + (copy-seq + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) + :start 1 + :end 7 + :count 2 + :key #'string-upcase) + '("war" "peace" "peace" "WAR" "war" "War" "WAr" "WAR")) +(equal (nsubstitute-if "peace" #'(lambda (arg) (string= "WAR" arg)) + (copy-seq + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) + :start 1 + :end 7 + :count 2 + :from-end t + :key #'string-upcase) + '("war" "War" "WAr" "WAR" "war" "peace" "peace" "WAR")) +(equal (nsubstitute-if "peace" #'(lambda (arg) (string= "WAR" arg)) + (copy-seq + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) + :start 1 + :end 7 + :count 0 + :from-end t + :key #'string-upcase) + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) +(equal (nsubstitute-if "peace" #'(lambda (arg) (string= "WAR" arg)) + (copy-seq + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) + :start 1 + :end 7 + :count -2 + :from-end t + :key #'string-upcase) + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) +(equal (nsubstitute-if "peace" #'(lambda (arg) (string= "WAR" arg)) + (copy-seq + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) + :start 1 + :end 7 + :count nil + :from-end t + :key #'string-upcase) + '("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR")) +(equal (nsubstitute-if "peace" #'(lambda (arg) (string= "WAR" arg)) + (copy-seq + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) + :start 1 + :end 7 + :count 6 + :from-end t + :key #'string-upcase) + '("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR")) +(equal (nsubstitute-if "peace" #'(lambda (arg) (string= "WAR" arg)) + (copy-seq + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) + :start 1 + :end 7 + :count 7 + :from-end t + :key #'string-upcase) + '("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR")) +(equal (nsubstitute-if "peace" #'(lambda (arg) (string= "WAR" arg)) + (copy-seq + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) + :start 1 + :end 7 + :count 100 + :from-end t + :key #'string-upcase) + '("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR")) + + +(equalp (nsubstitute-if 'a #'(lambda (arg) (eq arg 'x)) (copy-seq #(x y z))) + #(a y z)) +(equalp (nsubstitute-if 'b #'(lambda (arg) (eq arg 'y)) (copy-seq #(x y z))) + #(x b z)) +(equalp (nsubstitute-if 'c #'(lambda (arg) (eq arg 'z)) (copy-seq #(x y z))) + #(x y c)) +(equalp (nsubstitute-if 'a #'(lambda (arg) (eq arg 'p)) (copy-seq #(x y z))) + #(x y z)) +(equalp (nsubstitute-if 'a #'(lambda (arg) (eq arg 'x)) (copy-seq #())) #()) +(equalp (nsubstitute-if #\x #'(lambda (arg) (char< #\b arg)) + (copy-seq #(#\a #\b #\c #\d #\e))) + #(#\a #\b #\x #\x #\x)) +(equalp (nsubstitute-if '(a) #'(lambda (arg) (eq arg 'x)) + (copy-seq #((x) (y) (z))) :key #'car) + #((a) (y) (z))) +(equalp (nsubstitute-if 'c #'(lambda (arg) (eq arg 'b)) + (copy-seq #(a b a b a b a b))) #(a c a c a c a c)) +(equalp (nsubstitute-if 'a #'(lambda (arg) (eq arg 'b)) + (copy-seq #(b b b))) #(a a a)) +(equalp (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x)) + (copy-seq #(a x b x c x d x e x f))) + #(a z b z c z d z e z f)) +(equalp (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x)) + (copy-seq #(a x b x c x d x e x f)) :count nil) + #(a z b z c z d z e z f)) +(equalp (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x)) + (copy-seq #(a x b x c x d x e x f)) :count 0) + #(a x b x c x d x e x f)) +(equalp (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x)) + (copy-seq #(a x b x c x d x e x f)) :count -100) + #(a x b x c x d x e x f)) +(equalp (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x)) + (copy-seq #(a x b x c x d x e x f)) :count 1) + #(a z b x c x d x e x f)) +(equalp (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x)) + (copy-seq #(a x b x c x d x e x f)) :count 2) + #(a z b z c x d x e x f)) +(equalp (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x)) + (copy-seq #(a x b x c x d x e x f)) :count 3) + #(a z b z c z d x e x f)) +(equalp (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x)) + (copy-seq #(a x b x c x d x e x f)) :count 4) + #(a z b z c z d z e x f)) +(equalp (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x)) + (copy-seq #(a x b x c x d x e x f)) :count 5) + #(a z b z c z d z e z f)) +(equalp (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x)) + (copy-seq #(a x b x c x d x e x f)) :count 6) + #(a z b z c z d z e z f)) +(equalp (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x)) + (copy-seq #(a x b x c x d x e x f)) :count 7) + #(a z b z c z d z e z f)) +(equalp (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x)) + (copy-seq #(a x b x c x d x e x f)) + :count nil :from-end t) + #(a z b z c z d z e z f)) +(equalp (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x)) + (copy-seq #(a x b x c x d x e x f)) + :count 0 :from-end t) + #(a x b x c x d x e x f)) +(equalp (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x)) + (copy-seq #(a x b x c x d x e x f)) + :count -100 :from-end t) + #(a x b x c x d x e x f)) +(equalp (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x)) + (copy-seq #(a x b x c x d x e x f)) + :count 1 :from-end t) + #(a x b x c x d x e z f)) +(equalp (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x)) + (copy-seq #(a x b x c x d x e x f)) + :count 2 :from-end t) + #(a x b x c x d z e z f)) +(equalp (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x)) + (copy-seq #(a x b x c x d x e x f)) + :count 3 :from-end t) + #(a x b x c z d z e z f)) +(equalp (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x)) + (copy-seq #(a x b x c x d x e x f)) + :count 4 :from-end t) + #(a x b z c z d z e z f)) +(equalp (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x)) + (copy-seq #(a x b x c x d x e x f)) + :count 5 :from-end t) + #(a z b z c z d z e z f)) +(equalp (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x)) + (copy-seq #(a x b x c x d x e x f)) + :count 6 :from-end t) + #(a z b z c z d z e z f)) +(equalp (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x)) + (copy-seq #(a x b x c x d x e x f)) + :count 7 :from-end t) + #(a z b z c z d z e z f)) +(equalp (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x)) + (copy-seq #(a x b x c x d x e x f)) + :start 2 :count 1) + #(a x b z c x d x e x f)) +(equalp (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x)) + (copy-seq #(a x b x c x d x e x f)) + :start 2 :end nil :count 1) + #(a x b z c x d x e x f)) +(equalp (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x)) + (copy-seq #(a x b x c x d x e x f)) + :start 2 :end 6 :count 100) + #(a x b z c z d x e x f)) +(equalp (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x)) + (copy-seq #(a x b x c x d x e x f)) + :start 2 :end 11 :count 100) + #(a x b z c z d z e z f)) +(equalp (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x)) + (copy-seq #(a x b x c x d x e x f)) + :start 2 :end 8 :count 10) + #(a x b z c z d z e x f)) +(equalp (nsubstitute-if 'z #'(lambda (arg) (eq arg 'x)) + (copy-seq #(a x b x c x d x e x f)) + :start 2 :end 8 :count 2 :from-end t) + #(a x b x c z d z e x f)) +(equalp (nsubstitute-if #\z #'(lambda (arg) (char< #\c arg)) + (copy-seq #(#\a #\b #\c #\d #\e #\f))) + #(#\a #\b #\c #\z #\z #\z)) +(equalp (nsubstitute-if "peace" #'(lambda (arg) (equal "war" arg)) + (copy-seq #("love" "hate" "war" "peace"))) + #("love" "hate" "peace" "peace")) +(equalp (nsubstitute-if "peace" #'(lambda (arg) (string-equal "war" arg)) + (copy-seq #("war" "War" "WAr" "WAR"))) + #("peace" "peace" "peace" "peace")) +(equalp (nsubstitute-if "peace" #'(lambda (arg) (string= "WAR" arg)) + (copy-seq #("war" "War" "WAr" "WAR")) + :key #'string-upcase) + #("peace" "peace" "peace" "peace")) +(equalp (nsubstitute-if "peace" #'(lambda (arg) (string= "WAR" arg)) + (copy-seq #("war" "War" "WAr" "WAR")) + :start 1 + :end 2 + :key #'string-upcase) + #("war" "peace" "WAr" "WAR")) +(equalp (nsubstitute-if "peace" #'(lambda (arg) (string= "WAR" arg)) + (copy-seq #("war" "War" "WAr" "WAR")) + :start 1 + :end nil + :key #'string-upcase) + #("war" "peace" "peace" "peace")) +(equalp (nsubstitute-if "peace" #'(lambda (arg) (string= "war" arg)) + (copy-seq #("war" "War" "WAr" "WAR")) + :key #'string-upcase) + #("war" "War" "WAr" "WAR")) +(equalp (nsubstitute-if "peace" #'(lambda (arg) (string= "WAR" arg)) + (copy-seq + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) + :start 1 + :end 7 + :count 1 + :key #'string-upcase) + #("war" "peace" "WAr" "WAR" "war" "War" "WAr" "WAR")) +(equalp (nsubstitute-if "peace" #'(lambda (arg) (string= "WAR" arg)) + (copy-seq + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) + :start 1 + :end 7 + :count 2 + :key #'string-upcase) + #("war" "peace" "peace" "WAR" "war" "War" "WAr" "WAR")) +(equalp (nsubstitute-if "peace" #'(lambda (arg) (string= "WAR" arg)) + (copy-seq + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) + :start 1 + :end 7 + :count 2 + :from-end t + :key #'string-upcase) + #("war" "War" "WAr" "WAR" "war" "peace" "peace" "WAR")) +(equalp (nsubstitute-if "peace" #'(lambda (arg) (string= "WAR" arg)) + (copy-seq + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) + :start 1 + :end 7 + :count 0 + :from-end t + :key #'string-upcase) + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) +(equalp (nsubstitute-if "peace" #'(lambda (arg) (string= "WAR" arg)) + (copy-seq + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) + :start 1 + :end 7 + :count -2 + :from-end t + :key #'string-upcase) + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) +(equalp (nsubstitute-if "peace" #'(lambda (arg) (string= "WAR" arg)) + (copy-seq + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) + :start 1 + :end 7 + :count nil + :from-end t + :key #'string-upcase) + #("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR")) +(equalp (nsubstitute-if "peace" #'(lambda (arg) (string= "WAR" arg)) + (copy-seq + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) + :start 1 + :end 7 + :count 6 + :from-end t + :key #'string-upcase) + #("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR")) +(equalp (nsubstitute-if "peace" #'(lambda (arg) (string= "WAR" arg)) + (copy-seq + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) + :start 1 + :end 7 + :count 7 + :from-end t + :key #'string-upcase) + #("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR")) +(equalp (nsubstitute-if "peace" #'(lambda (arg) (string= "WAR" arg)) + (copy-seq + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) + :start 1 + :end 7 + :count 100 + :from-end t + :key #'string-upcase) + #("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR")) + +(string= (nsubstitute-if #\A #'(lambda (arg) (eql #\a arg)) + (copy-seq "abcabc")) "AbcAbc") +(string= (nsubstitute-if #\A #'(lambda (arg) (eql #\a arg)) (copy-seq "")) "") +(string= (nsubstitute-if #\A #'(lambda (arg) (eql #\a arg)) (copy-seq "xyz")) + "xyz") +(string= (nsubstitute-if #\A #'(lambda (arg) (eql #\a arg)) + (copy-seq "aaaaaaaaaa") :start 5 :end nil) + "aaaaaAAAAA") +(string= (nsubstitute-if #\x #'(lambda (arg) (char< #\5 arg)) + (copy-seq "0123456789")) "012345xxxx") +(string= (nsubstitute-if #\x #'(lambda (arg) (char> #\5 arg)) + (copy-seq "0123456789")) "xxxxx56789") +(string= (nsubstitute-if #\x #'(lambda (arg) (char> #\D arg)) + (copy-seq "abcdefg") + :key #'char-upcase) + "xxxdefg") +(string= (nsubstitute-if #\x #'(lambda (arg) (char> #\D arg)) + (copy-seq "abcdefg") + :start 1 + :end 2 + :key #'char-upcase) + "axcdefg") +(string= (nsubstitute-if #\A #'(lambda (arg) (eql #\a arg)) + (copy-seq "aaaaaaaaaa") :count 2) "AAaaaaaaaa") +(string= (nsubstitute-if #\A #'(lambda (arg) (eql #\a arg)) + (copy-seq "aaaaaaaaaa") :count -1) "aaaaaaaaaa") +(string= (nsubstitute-if #\A #'(lambda (arg) (eql #\a arg)) + (copy-seq "aaaaaaaaaa") :count 0) "aaaaaaaaaa") +(string= (nsubstitute-if #\A #'(lambda (arg) (eql #\a arg)) + (copy-seq "aaaaaaaaaa") :count nil) "AAAAAAAAAA") +(string= (nsubstitute-if #\A #'(lambda (arg) (eql #\a arg)) + (copy-seq "aaaaaaaaaa") :count 100) "AAAAAAAAAA") +(string= (nsubstitute-if #\A #'(lambda (arg) (eql #\a arg)) + (copy-seq "aaaaaaaaaa") :count 9) "AAAAAAAAAa") +(string= (nsubstitute-if #\A #'(lambda (arg) (eql #\a arg)) + (copy-seq "aaaaaaaaaa") :count 9 :from-end t) + "aAAAAAAAAA") +(string= (nsubstitute-if #\A #'(lambda (arg) (eql #\a arg)) + (copy-seq "aaaaaaaaaa") + :start 2 + :end 8 + :count 3) + "aaAAAaaaaa") +(string= (nsubstitute-if #\A #'(lambda (arg) (eql #\a arg)) + (copy-seq "aaaaaaaaaa") + :start 2 + :end 8 + :from-end t + :count 3) + "aaaaaAAAaa") +(string= (nsubstitute-if #\x #'(lambda (arg) (eql #\A arg)) + (copy-seq "aaaaaaaaaa") + :start 2 + :end 8 + :from-end t + :count 3) + "aaaaaaaaaa") +(string= (nsubstitute-if #\X #'(lambda (arg) (eql #\A arg)) + (copy-seq "aaaaaaaaaa") + :start 2 + :end 8 + :from-end t + :key #'char-upcase + :count 3) + "aaaaaXXXaa") +(string= (nsubstitute-if #\X #'(lambda (arg) (char< #\D arg)) + (copy-seq "abcdefghij") + :start 2 + :end 8 + :from-end t + :key #'char-upcase + :count 3) + "abcdeXXXij") +(equalp (nsubstitute-if 0 #'(lambda (arg) (= 1 arg)) (copy-seq #*1111)) #*0000) +(equalp (nsubstitute-if 0 #'(lambda (arg) (= 1 arg)) + (copy-seq #*1111) :start 1 :end nil) #*1000) +(equalp (nsubstitute-if 0 #'(lambda (arg) (= 1 arg)) + (copy-seq #*1111) :start 1 :end 3) #*1001) +(equalp (nsubstitute-if 0 #'(lambda (arg) (= 1 arg)) + (copy-seq #*11111111) :start 1 :end 7) #*10000001) +(equalp (nsubstitute-if 0 #'(lambda (arg) (= 1 arg)) + (copy-seq #*11111111) :start 1 :end 7 :count 3) + #*10001111) +(equalp (nsubstitute-if 0 #'(lambda (arg) (= 1 arg)) + (copy-seq #*11111111) + :start 1 :end 7 :count 3 :from-end t) + #*11110001) +(equalp (nsubstitute-if 1 #'(lambda (arg) (= 1 arg)) + (copy-seq #*10101010) + :start 1 :end 7 :count 3 :from-end t + :key #'(lambda (x) (if (zerop x) 1 0))) + #*11111110) +(equalp (nsubstitute-if 1 #'(lambda (arg) (>= 1 arg)) + (copy-seq #*10101010) + :start 1 :end 7 :count 3 :from-end t + :key #'(lambda (x) (if (zerop x) 1 0))) + #*10101110) + + +(equal (nsubstitute-if-not 'a #'(lambda (arg) (not (eq arg 'x))) + (copy-seq '(x y z))) + '(a y z)) +(equal (nsubstitute-if-not 'b #'(lambda (arg) (not (eq arg 'y))) + (copy-seq '(x y z))) + '(x b z)) +(equal (nsubstitute-if-not 'c #'(lambda (arg) (not (eq arg 'z))) + (copy-seq '(x y z))) + '(x y c)) +(equal (nsubstitute-if-not 'a #'(lambda (arg) (not (eq arg 'p))) + (copy-seq '(x y z))) + '(x y z)) +(equal (nsubstitute-if-not 'a #'(lambda (arg) (not (eq arg 'x))) + (copy-seq '())) '()) +(equal (nsubstitute-if-not #\x #'(lambda (arg) (not (char< #\b arg))) + (copy-seq '(#\a #\b #\c #\d #\e))) + '(#\a #\b #\x #\x #\x)) +(equal (nsubstitute-if-not '(a) #'(lambda (arg) (not (eq arg 'x))) + (copy-seq '((x) (y) (z))) :key #'car) + '((a) (y) (z))) +(equal (nsubstitute-if-not 'c #'(lambda (arg) (not (eq arg 'b))) + (copy-seq '(a b a b a b a b))) '(a c a c a c a c)) +(equal (nsubstitute-if-not 'a #'(lambda (arg) (not (eq arg 'b))) + (copy-seq '(b b b))) '(a a a)) +(equal (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + (copy-seq '(a x b x c x d x e x f))) + '(a z b z c z d z e z f)) +(equal (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + (copy-seq '(a x b x c x d x e x f)) :count nil) + '(a z b z c z d z e z f)) +(equal (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + (copy-seq '(a x b x c x d x e x f)) :count 0) + '(a x b x c x d x e x f)) +(equal (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + (copy-seq '(a x b x c x d x e x f)) :count -100) + '(a x b x c x d x e x f)) +(equal (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + (copy-seq '(a x b x c x d x e x f)) :count 1) + '(a z b x c x d x e x f)) +(equal (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + (copy-seq '(a x b x c x d x e x f)) :count 2) + '(a z b z c x d x e x f)) +(equal (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + (copy-seq '(a x b x c x d x e x f)) :count 3) + '(a z b z c z d x e x f)) +(equal (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + (copy-seq '(a x b x c x d x e x f)) :count 4) + '(a z b z c z d z e x f)) +(equal (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + (copy-seq '(a x b x c x d x e x f)) :count 5) + '(a z b z c z d z e z f)) +(equal (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + (copy-seq '(a x b x c x d x e x f)) :count 6) + '(a z b z c z d z e z f)) +(equal (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + (copy-seq '(a x b x c x d x e x f)) :count 7) + '(a z b z c z d z e z f)) +(equal (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + (copy-seq '(a x b x c x d x e x f)) + :count nil :from-end t) + '(a z b z c z d z e z f)) +(equal (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + (copy-seq '(a x b x c x d x e x f)) + :count 0 :from-end t) + '(a x b x c x d x e x f)) +(equal (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + (copy-seq '(a x b x c x d x e x f)) + :count -100 :from-end t) + '(a x b x c x d x e x f)) +(equal (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + (copy-seq '(a x b x c x d x e x f)) + :count 1 :from-end t) + '(a x b x c x d x e z f)) +(equal (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + (copy-seq '(a x b x c x d x e x f)) + :count 2 :from-end t) + '(a x b x c x d z e z f)) +(equal (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + (copy-seq '(a x b x c x d x e x f)) + :count 3 :from-end t) + '(a x b x c z d z e z f)) +(equal (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + (copy-seq '(a x b x c x d x e x f)) + :count 4 :from-end t) + '(a x b z c z d z e z f)) +(equal (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + (copy-seq '(a x b x c x d x e x f)) + :count 5 :from-end t) + '(a z b z c z d z e z f)) +(equal (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + (copy-seq '(a x b x c x d x e x f)) + :count 6 :from-end t) + '(a z b z c z d z e z f)) +(equal (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + (copy-seq '(a x b x c x d x e x f)) + :count 7 :from-end t) + '(a z b z c z d z e z f)) +(equal (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + (copy-seq '(a x b x c x d x e x f)) + :start 2 :count 1) + '(a x b z c x d x e x f)) +(equal (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + (copy-seq '(a x b x c x d x e x f)) + :start 2 :end nil :count 1) + '(a x b z c x d x e x f)) +(equal (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + (copy-seq '(a x b x c x d x e x f)) + :start 2 :end 6 :count 100) + '(a x b z c z d x e x f)) +(equal (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + (copy-seq '(a x b x c x d x e x f)) + :start 2 :end 11 :count 100) + '(a x b z c z d z e z f)) +(equal (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + (copy-seq '(a x b x c x d x e x f)) + :start 2 :end 8 :count 10) + '(a x b z c z d z e x f)) +(equal (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + (copy-seq '(a x b x c x d x e x f)) + :start 2 :end 8 :count 2 :from-end t) + '(a x b x c z d z e x f)) +(equal (nsubstitute-if-not #\z #'(lambda (arg) (not (char< #\c arg))) + (copy-seq '(#\a #\b #\c #\d #\e #\f))) + '(#\a #\b #\c #\z #\z #\z)) +(equal (nsubstitute-if-not "peace" #'(lambda (arg) (not (equal "war" arg))) + (copy-seq '("love" "hate" "war" "peace"))) + '("love" "hate" "peace" "peace")) +(equal (nsubstitute-if-not "peace" + #'(lambda (arg) (not (string-equal "war" arg))) + (copy-seq '("war" "War" "WAr" "WAR"))) + '("peace" "peace" "peace" "peace")) +(equal (nsubstitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg))) + (copy-seq '("war" "War" "WAr" "WAR")) + :key #'string-upcase) + '("peace" "peace" "peace" "peace")) +(equal (nsubstitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg))) + (copy-seq '("war" "War" "WAr" "WAR")) + :start 1 + :end 2 + :key #'string-upcase) + '("war" "peace" "WAr" "WAR")) +(equal (nsubstitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg))) + (copy-seq '("war" "War" "WAr" "WAR")) + :start 1 + :end nil + :key #'string-upcase) + '("war" "peace" "peace" "peace")) +(equal (nsubstitute-if-not "peace" #'(lambda (arg) (not (string= "war" arg))) + (copy-seq '("war" "War" "WAr" "WAR")) + :key #'string-upcase) + '("war" "War" "WAr" "WAR")) +(equal (nsubstitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg))) + (copy-seq + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) + :start 1 + :end 7 + :count 1 + :key #'string-upcase) + '("war" "peace" "WAr" "WAR" "war" "War" "WAr" "WAR")) +(equal (nsubstitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg))) + (copy-seq + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) + :start 1 + :end 7 + :count 2 + :key #'string-upcase) + '("war" "peace" "peace" "WAR" "war" "War" "WAr" "WAR")) +(equal (nsubstitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg))) + (copy-seq + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) + :start 1 + :end 7 + :count 2 + :from-end t + :key #'string-upcase) + '("war" "War" "WAr" "WAR" "war" "peace" "peace" "WAR")) +(equal (nsubstitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg))) + (copy-seq + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) + :start 1 + :end 7 + :count 0 + :from-end t + :key #'string-upcase) + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) +(equal (nsubstitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg))) + (copy-seq + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) + :start 1 + :end 7 + :count -2 + :from-end t + :key #'string-upcase) + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) +(equal (nsubstitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg))) + (copy-seq + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) + :start 1 + :end 7 + :count nil + :from-end t + :key #'string-upcase) + '("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR")) +(equal (nsubstitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg))) + (copy-seq + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) + :start 1 + :end 7 + :count 6 + :from-end t + :key #'string-upcase) + '("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR")) +(equal (nsubstitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg))) + (copy-seq + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) + :start 1 + :end 7 + :count 7 + :from-end t + :key #'string-upcase) + '("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR")) +(equal (nsubstitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg))) + (copy-seq + '("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) + :start 1 + :end 7 + :count 100 + :from-end t + :key #'string-upcase) + '("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR")) + + +(equalp (nsubstitute-if-not 'a #'(lambda (arg) (not (eq arg 'x))) + (copy-seq #(x y z))) #(a y z)) +(equalp (nsubstitute-if-not 'b #'(lambda (arg) (not (eq arg 'y))) + (copy-seq #(x y z))) #(x b z)) +(equalp (nsubstitute-if-not 'c #'(lambda (arg) (not (eq arg 'z))) + (copy-seq #(x y z))) #(x y c)) +(equalp (nsubstitute-if-not 'a #'(lambda (arg) (not (eq arg 'p))) + (copy-seq #(x y z))) #(x y z)) +(equalp (nsubstitute-if-not 'a #'(lambda (arg) (not (eq arg 'x))) + (copy-seq #())) #()) +(equalp (nsubstitute-if-not #\x #'(lambda (arg) (not (char< #\b arg))) + (copy-seq #(#\a #\b #\c #\d #\e))) + #(#\a #\b #\x #\x #\x)) +(equalp (nsubstitute-if-not '(a) #'(lambda (arg) (not (eq arg 'x))) + (copy-seq #((x) (y) (z))) :key #'car) + #((a) (y) (z))) +(equalp (nsubstitute-if-not 'c #'(lambda (arg) (not (eq arg 'b))) + (copy-seq #(a b a b a b a b))) #(a c a c a c a c)) +(equalp (nsubstitute-if-not 'a #'(lambda (arg) (not (eq arg 'b))) + (copy-seq #(b b b))) #(a a a)) +(equalp (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + (copy-seq #(a x b x c x d x e x f))) + #(a z b z c z d z e z f)) +(equalp (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + (copy-seq #(a x b x c x d x e x f)) :count nil) + #(a z b z c z d z e z f)) +(equalp (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + (copy-seq #(a x b x c x d x e x f)) :count 0) + #(a x b x c x d x e x f)) +(equalp (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + (copy-seq #(a x b x c x d x e x f)) :count -100) + #(a x b x c x d x e x f)) +(equalp (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + (copy-seq #(a x b x c x d x e x f)) :count 1) + #(a z b x c x d x e x f)) +(equalp (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + (copy-seq #(a x b x c x d x e x f)) :count 2) + #(a z b z c x d x e x f)) +(equalp (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + (copy-seq #(a x b x c x d x e x f)) :count 3) + #(a z b z c z d x e x f)) +(equalp (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + (copy-seq #(a x b x c x d x e x f)) :count 4) + #(a z b z c z d z e x f)) +(equalp (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + (copy-seq #(a x b x c x d x e x f)) :count 5) + #(a z b z c z d z e z f)) +(equalp (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + (copy-seq #(a x b x c x d x e x f)) :count 6) + #(a z b z c z d z e z f)) +(equalp (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + (copy-seq #(a x b x c x d x e x f)) :count 7) + #(a z b z c z d z e z f)) +(equalp (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + (copy-seq #(a x b x c x d x e x f)) + :count nil :from-end t) + #(a z b z c z d z e z f)) +(equalp (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + (copy-seq #(a x b x c x d x e x f)) + :count 0 :from-end t) + #(a x b x c x d x e x f)) +(equalp (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + (copy-seq #(a x b x c x d x e x f)) + :count -100 :from-end t) + #(a x b x c x d x e x f)) +(equalp (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + (copy-seq #(a x b x c x d x e x f)) + :count 1 :from-end t) + #(a x b x c x d x e z f)) +(equalp (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + (copy-seq #(a x b x c x d x e x f)) + :count 2 :from-end t) + #(a x b x c x d z e z f)) +(equalp (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + (copy-seq #(a x b x c x d x e x f)) + :count 3 :from-end t) + #(a x b x c z d z e z f)) +(equalp (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + (copy-seq #(a x b x c x d x e x f)) + :count 4 :from-end t) + #(a x b z c z d z e z f)) +(equalp (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + (copy-seq #(a x b x c x d x e x f)) + :count 5 :from-end t) + #(a z b z c z d z e z f)) +(equalp (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + (copy-seq #(a x b x c x d x e x f)) + :count 6 :from-end t) + #(a z b z c z d z e z f)) +(equalp (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + (copy-seq #(a x b x c x d x e x f)) + :count 7 :from-end t) + #(a z b z c z d z e z f)) +(equalp (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + (copy-seq #(a x b x c x d x e x f)) + :start 2 :count 1) + #(a x b z c x d x e x f)) +(equalp (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + (copy-seq #(a x b x c x d x e x f)) + :start 2 :end nil :count 1) + #(a x b z c x d x e x f)) +(equalp (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + (copy-seq #(a x b x c x d x e x f)) + :start 2 :end 6 :count 100) + #(a x b z c z d x e x f)) +(equalp (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + (copy-seq #(a x b x c x d x e x f)) + :start 2 :end 11 :count 100) + #(a x b z c z d z e z f)) +(equalp (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + (copy-seq #(a x b x c x d x e x f)) + :start 2 :end 8 :count 10) + #(a x b z c z d z e x f)) +(equalp (nsubstitute-if-not 'z #'(lambda (arg) (not (eq arg 'x))) + (copy-seq #(a x b x c x d x e x f)) + :start 2 :end 8 :count 2 :from-end t) + #(a x b x c z d z e x f)) +(equalp (nsubstitute-if-not #\z #'(lambda (arg) (not (char< #\c arg))) + (copy-seq #(#\a #\b #\c #\d #\e #\f))) + #(#\a #\b #\c #\z #\z #\z)) +(equalp (nsubstitute-if-not "peace" #'(lambda (arg) (not (equal "war" arg))) + (copy-seq #("love" "hate" "war" "peace"))) + #("love" "hate" "peace" "peace")) +(equalp (nsubstitute-if-not "peace" + #'(lambda (arg) (not (string-equal "war" arg))) + (copy-seq #("war" "War" "WAr" "WAR"))) + #("peace" "peace" "peace" "peace")) +(equalp (nsubstitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg))) + (copy-seq #("war" "War" "WAr" "WAR")) + :key #'string-upcase) + #("peace" "peace" "peace" "peace")) +(equalp (nsubstitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg))) + (copy-seq #("war" "War" "WAr" "WAR")) + :start 1 + :end 2 + :key #'string-upcase) + #("war" "peace" "WAr" "WAR")) +(equalp (nsubstitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg))) + (copy-seq #("war" "War" "WAr" "WAR")) + :start 1 + :end nil + :key #'string-upcase) + #("war" "peace" "peace" "peace")) +(equalp (nsubstitute-if-not "peace" #'(lambda (arg) (not (string= "war" arg))) + (copy-seq #("war" "War" "WAr" "WAR")) + :key #'string-upcase) + #("war" "War" "WAr" "WAR")) +(equalp (nsubstitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg))) + (copy-seq + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) + :start 1 + :end 7 + :count 1 + :key #'string-upcase) + #("war" "peace" "WAr" "WAR" "war" "War" "WAr" "WAR")) +(equalp (nsubstitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg))) + (copy-seq + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) + :start 1 + :end 7 + :count 2 + :key #'string-upcase) + #("war" "peace" "peace" "WAR" "war" "War" "WAr" "WAR")) +(equalp (nsubstitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg))) + (copy-seq + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) + :start 1 + :end 7 + :count 2 + :from-end t + :key #'string-upcase) + #("war" "War" "WAr" "WAR" "war" "peace" "peace" "WAR")) +(equalp (nsubstitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg))) + (copy-seq + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) + :start 1 + :end 7 + :count 0 + :from-end t + :key #'string-upcase) + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) +(equalp (nsubstitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg))) + (copy-seq + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) + :start 1 + :end 7 + :count -2 + :from-end t + :key #'string-upcase) + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) +(equalp (nsubstitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg))) + (copy-seq + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) + :start 1 + :end 7 + :count nil + :from-end t + :key #'string-upcase) + #("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR")) +(equalp (nsubstitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg))) + (copy-seq + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) + :start 1 + :end 7 + :count 6 + :from-end t + :key #'string-upcase) + #("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR")) +(equalp (nsubstitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg))) + (copy-seq + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) + :start 1 + :end 7 + :count 7 + :from-end t + :key #'string-upcase) + #("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR")) +(equalp (nsubstitute-if-not "peace" #'(lambda (arg) (not (string= "WAR" arg))) + (copy-seq + #("war" "War" "WAr" "WAR" "war" "War" "WAr" "WAR")) + :start 1 + :end 7 + :count 100 + :from-end t + :key #'string-upcase) + #("war" "peace" "peace" "peace" "peace" "peace" "peace" "WAR")) + +(string= (nsubstitute-if-not #\A #'(lambda (arg) (not (eql #\a arg))) + (copy-seq "abcabc")) + "AbcAbc") +(string= (nsubstitute-if-not #\A #'(lambda (arg) (not (eql #\a arg))) + (copy-seq "")) "") +(string= (nsubstitute-if-not #\A #'(lambda (arg) (not (eql #\a arg))) + (copy-seq "xyz")) + "xyz") +(string= (nsubstitute-if-not #\A #'(lambda (arg) (not (eql #\a arg))) + (copy-seq "aaaaaaaaaa") :start 5 :end nil) + "aaaaaAAAAA") +(string= (nsubstitute-if-not #\x #'(lambda (arg) (not (char< #\5 arg))) + (copy-seq "0123456789")) "012345xxxx") +(string= (nsubstitute-if-not #\x #'(lambda (arg) (not (char> #\5 arg))) + (copy-seq "0123456789")) "xxxxx56789") +(string= (nsubstitute-if-not #\x #'(lambda (arg) (not (char> #\D arg))) + (copy-seq "abcdefg") + :key #'char-upcase) + "xxxdefg") +(string= (nsubstitute-if-not #\x #'(lambda (arg) (not (char> #\D arg))) + (copy-seq "abcdefg") + :start 1 + :end 2 + :key #'char-upcase) + "axcdefg") +(string= (nsubstitute-if-not #\A #'(lambda (arg) (not (eql #\a arg))) + (copy-seq "aaaaaaaaaa") :count 2) "AAaaaaaaaa") +(string= (nsubstitute-if-not #\A #'(lambda (arg) (not (eql #\a arg))) + (copy-seq "aaaaaaaaaa") :count -1) "aaaaaaaaaa") +(string= (nsubstitute-if-not #\A #'(lambda (arg) (not (eql #\a arg))) + (copy-seq "aaaaaaaaaa") :count 0) "aaaaaaaaaa") +(string= (nsubstitute-if-not #\A #'(lambda (arg) (not (eql #\a arg))) + (copy-seq "aaaaaaaaaa") :count nil) "AAAAAAAAAA") +(string= (nsubstitute-if-not #\A #'(lambda (arg) (not (eql #\a arg))) + (copy-seq "aaaaaaaaaa") :count 100) "AAAAAAAAAA") +(string= (nsubstitute-if-not #\A #'(lambda (arg) (not (eql #\a arg))) + (copy-seq "aaaaaaaaaa") :count 9) "AAAAAAAAAa") +(string= (nsubstitute-if-not #\A #'(lambda (arg) (not (eql #\a arg))) + (copy-seq "aaaaaaaaaa") :count 9 :from-end t) + "aAAAAAAAAA") +(string= (nsubstitute-if-not #\A #'(lambda (arg) (not (eql #\a arg))) + (copy-seq "aaaaaaaaaa") + :start 2 + :end 8 + :count 3) + "aaAAAaaaaa") +(string= (nsubstitute-if-not #\A #'(lambda (arg) (not (eql #\a arg))) + (copy-seq "aaaaaaaaaa") + :start 2 + :end 8 + :from-end t + :count 3) + "aaaaaAAAaa") +(string= (nsubstitute-if-not #\x #'(lambda (arg) (not (eql #\A arg))) + (copy-seq "aaaaaaaaaa") + :start 2 + :end 8 + :from-end t + :count 3) + "aaaaaaaaaa") +(string= (nsubstitute-if-not #\X #'(lambda (arg) (not (eql #\A arg))) + (copy-seq "aaaaaaaaaa") + :start 2 + :end 8 + :from-end t + :key #'char-upcase + :count 3) + "aaaaaXXXaa") +(string= (nsubstitute-if-not #\X #'(lambda (arg) (not (char< #\D arg))) + (copy-seq "abcdefghij") + :start 2 + :end 8 + :from-end t + :key #'char-upcase + :count 3) + "abcdeXXXij") +(equalp (nsubstitute-if-not 0 #'(lambda (arg) (not (= 1 arg))) + (copy-seq #*1111)) #*0000) +(equalp (nsubstitute-if-not 0 #'(lambda (arg) (not (= 1 arg))) + (copy-seq #*1111) :start 1 :end nil) #*1000) +(equalp (nsubstitute-if-not 0 #'(lambda (arg) (not (= 1 arg))) + (copy-seq #*1111) :start 1 :end 3) #*1001) +(equalp (nsubstitute-if-not 0 #'(lambda (arg) (not (= 1 arg))) + (copy-seq #*11111111) :start 1 :end 7) #*10000001) +(equalp (nsubstitute-if-not 0 #'(lambda (arg) (not (= 1 arg))) + (copy-seq #*11111111) :start 1 :end 7 :count 3) + #*10001111) +(equalp (nsubstitute-if-not 0 #'(lambda (arg) (not (= 1 arg))) + (copy-seq #*11111111) + :start 1 :end 7 :count 3 :from-end t) + #*11110001) +(equalp (nsubstitute-if-not 1 #'(lambda (arg) (not (= 1 arg))) + (copy-seq #*10101010) + :start 1 :end 7 :count 3 :from-end t + :key #'(lambda (x) (if (zerop x) 1 0))) + #*11111110) +(equalp (nsubstitute-if-not 1 #'(lambda (arg) (not (>= 1 arg))) + (copy-seq #*10101010) + :start 1 :end 7 :count 3 :from-end t + :key #'(lambda (x) (if (zerop x) 1 0))) + #*10101110) + + +(string= (concatenate 'string "all" " " "together" " " "now") + "all together now") +(equal (concatenate 'list "ABC" '(d e f) #(1 2 3) #*1011) + '(#\A #\B #\C D E F 1 2 3 1 0 1 1)) +(null (concatenate 'list)) +(HANDLER-CASE (PROGN (CONCATENATE 'SYMBOL)) + (ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (CONCATENATE 'CLASS)) + (ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + + +(equal (concatenate 'list '() '(a b c) '(x y z)) '(a b c x y z)) +(equal (concatenate 'list '(a) #(b) '(c) #(x y) '(z)) '(a b c x y z)) +(equal (concatenate 'list '(a b c) #(d e f) "ghi" #*0101) + '(a b c d e f #\g #\h #\i 0 1 0 1)) +(null (concatenate 'list)) +(let* ((list0 '(a b c)) + (list (concatenate 'list list0))) + (and (not (eq list0 list)) + (equal list list0) + (equal list '(a b c)))) +(null (concatenate 'list '() #() "" #*)) +(equal (concatenate 'list #(a b c) '() '() '(x y z) #() #() #* #(j k l)) + '(a b c x y z j k l)) + +(equalp (concatenate 'vector '() '(a b c) '(x y z)) #(a b c x y z)) +(equalp (concatenate 'vector '(a) #(b) '(c) #(x y) '(z)) #(a b c x y z)) +(equalp (concatenate 'vector '(a b c) #(d e f) "ghi" #*0101) + #(a b c d e f #\g #\h #\i 0 1 0 1)) +(equalp (concatenate 'vector) #()) +(let* ((vector0 #(a b c)) + (vector (concatenate 'vector vector0))) + (and (not (eq vector0 vector)) + (equalp vector vector0) + (equalp vector #(a b c)))) +(equalp (concatenate 'vector '() #() "" #*) #()) +(equalp (concatenate 'vector #(a b c) '() '() '(x y z) #() #() #* #(j k l)) + #(a b c x y z j k l)) + +(string= (concatenate 'string "abc" "def" "ghi" "jkl" "mno" "pqr") + "abcdefghijklmnopqr") +(string= (concatenate + 'string + "" "abc" "" "def" "" "ghi" "" "" "jkl" "" "mno" "" "pqr" "" "") + "abcdefghijklmnopqr") +(string= (concatenate 'string) "") +(string= (concatenate 'string "" '() #* #()) "") +(string= (concatenate 'string "abc" '(#\d #\e #\f #\g) #(#\h #\i #\j #\k #\l)) + "abcdefghijkl") +(equal (concatenate 'bit-vector #*0101 #*1010) #*01011010) +(equal (concatenate 'bit-vector #*0101 #*1010 #* #*11 #*1 #*1) + #*010110101111) +(equal (concatenate 'bit-vector '(0 1 0 1) '(0 1 0 1) #(0 1 0 1) #*0101) + #*0101010101010101) +(equal (concatenate 'bit-vector) #*) +(equal (concatenate 'bit-vector #*) #*) +(equal (concatenate 'bit-vector #* '() #()) #*) + + + +(let ((test1 (list 1 3 4 6 7)) + (test2 (list 2 5 8))) + (equal (merge 'list test1 test2 #'<) '(1 2 3 4 5 6 7 8))) +(let ((test1 (copy-seq "BOY")) + (test2 (copy-seq "nosy"))) + (equal (merge 'string test1 test2 #'char-lessp) "BnOosYy")) +(let ((test1 (vector '(red . 1) '(blue . 4))) + (test2 (vector '(yellow . 2) '(green . 7)))) + (equalp (merge 'vector test1 test2 #'< :key #'cdr) + #((RED . 1) (YELLOW . 2) (BLUE . 4) (GREEN . 7)))) + + +(equal (merge 'list (list 1 3 5 7 9) (list 0 2 4 6 8) #'<) + '(0 1 2 3 4 5 6 7 8 9)) +(equal (merge 'cons (list 1 3 5 7 9) (list 0 2 4 6 8) #'<) + '(0 1 2 3 4 5 6 7 8 9)) +(equal (merge 'list (list 0 1 2) nil #'<) '(0 1 2)) +(equal (merge 'list nil (list 0 1 2) #'<) '(0 1 2)) +(equal (merge 'list nil nil #'<) nil) +(equal (merge 'list + (list '(1 1) '(2 1) '(3 1)) + (list '(1 2) '(2 2) '(3 2)) #'< :key #'car) + '((1 1) (1 2) (2 1) (2 2) (3 1) (3 2))) +(equal (merge 'list + (list '(1 1) '(2 1) '(2 1 1) '(3 1)) + (list '(1 2) '(2 2) '(3 2)) #'< :key #'car) + '((1 1) (1 2) (2 1) (2 1 1) (2 2) (3 1) (3 2))) +(equal (merge 'list + (list '(1 1) '(2 1) '(2 1 1) '(3 1)) + (list '(1 2) '(2 2) '(3 2) '(3 2 2)) #'< :key #'car) + '((1 1) (1 2) (2 1) (2 1 1) (2 2) (3 1) (3 2) (3 2 2))) +(equal (merge 'list (list 3 1 9 5 7) (list 8 6 0 2 4) #'<) + '(3 1 8 6 0 2 4 9 5 7)) + + +(equal (merge 'list (vector 1 3 5 7 9) (list 0 2 4 6 8) #'<) + '(0 1 2 3 4 5 6 7 8 9)) +(equal (merge 'cons (vector 1 3 5 7 9) (list 0 2 4 6 8) #'<) + '(0 1 2 3 4 5 6 7 8 9)) +(equal (merge 'list (vector 0 1 2) nil #'<) '(0 1 2)) +(equal (merge 'list #() (list 0 1 2) #'<) '(0 1 2)) +(equal (merge 'list #() #() #'<) nil) +(equal (merge 'list + (vector '(1 1) '(2 1) '(3 1)) + (list '(1 2) '(2 2) '(3 2)) #'< :key #'car) + '((1 1) (1 2) (2 1) (2 2) (3 1) (3 2))) +(equal (merge 'list + (vector '(1 1) '(2 1) '(2 1 1) '(3 1)) + (list '(1 2) '(2 2) '(3 2)) #'< :key #'car) + '((1 1) (1 2) (2 1) (2 1 1) (2 2) (3 1) (3 2))) +(equal (merge 'list + (vector '(1 1) '(2 1) '(2 1 1) '(3 1)) + (list '(1 2) '(2 2) '(3 2) '(3 2 2)) #'< :key #'car) + '((1 1) (1 2) (2 1) (2 1 1) (2 2) (3 1) (3 2) (3 2 2))) +(equal (merge 'list (vector 3 1 9 5 7) (list 8 6 0 2 4) #'<) + '(3 1 8 6 0 2 4 9 5 7)) + + +(equal (merge 'list (list 1 3 5 7 9) (vector 0 2 4 6 8) #'<) + '(0 1 2 3 4 5 6 7 8 9)) +(equal (merge 'cons (list 1 3 5 7 9) (vector 0 2 4 6 8) #'<) + '(0 1 2 3 4 5 6 7 8 9)) +(equal (merge 'list (list 0 1 2) #() #'<) '(0 1 2)) +(equal (merge 'list nil (vector 0 1 2) #'<) '(0 1 2)) +(equal (merge 'list nil #() #'<) nil) +(equal (merge 'list + (list '(1 1) '(2 1) '(3 1)) + (vector '(1 2) '(2 2) '(3 2)) #'< :key #'car) + '((1 1) (1 2) (2 1) (2 2) (3 1) (3 2))) +(equal (merge 'list + (list '(1 1) '(2 1) '(2 1 1) '(3 1)) + (vector '(1 2) '(2 2) '(3 2)) #'< :key #'car) + '((1 1) (1 2) (2 1) (2 1 1) (2 2) (3 1) (3 2))) +(equal (merge 'list + (list '(1 1) '(2 1) '(2 1 1) '(3 1)) + (vector '(1 2) '(2 2) '(3 2) '(3 2 2)) #'< :key #'car) + '((1 1) (1 2) (2 1) (2 1 1) (2 2) (3 1) (3 2) (3 2 2))) +(equal (merge 'list (list 3 1 9 5 7) (vector 8 6 0 2 4) #'<) + '(3 1 8 6 0 2 4 9 5 7)) + + +(equal (merge 'list (vector 1 3 5 7 9) (vector 0 2 4 6 8) #'<) + '(0 1 2 3 4 5 6 7 8 9)) +(equal (merge 'cons (vector 1 3 5 7 9) (vector 0 2 4 6 8) #'<) + '(0 1 2 3 4 5 6 7 8 9)) +(equal (merge 'list (vector 0 1 2) #() #'<) '(0 1 2)) +(equal (merge 'list #() (vector 0 1 2) #'<) '(0 1 2)) +(equal (merge 'list #() #() #'<) nil) +(equal (merge 'list + (vector '(1 1) '(2 1) '(3 1)) + (vector '(1 2) '(2 2) '(3 2)) #'< :key #'car) + '((1 1) (1 2) (2 1) (2 2) (3 1) (3 2))) +(equal (merge 'list + (vector '(1 1) '(2 1) '(2 1 1) '(3 1)) + (vector '(1 2) '(2 2) '(3 2)) #'< :key #'car) + '((1 1) (1 2) (2 1) (2 1 1) (2 2) (3 1) (3 2))) +(equal (merge 'list + (vector '(1 1) '(2 1) '(2 1 1) '(3 1)) + (vector '(1 2) '(2 2) '(3 2) '(3 2 2)) #'< :key #'car) + '((1 1) (1 2) (2 1) (2 1 1) (2 2) (3 1) (3 2) (3 2 2))) +(equal (merge 'list (vector 3 1 9 5 7) (vector 8 6 0 2 4) #'<) + '(3 1 8 6 0 2 4 9 5 7)) + + +(equalp (merge 'vector (list 1 3 5 7 9) (list 0 2 4 6 8) #'<) + #(0 1 2 3 4 5 6 7 8 9)) +(equalp (merge 'vector (list 1 3 5 7 9) (list 0 2 4 6 8) #'<) + #(0 1 2 3 4 5 6 7 8 9)) +(equalp (merge 'vector (list 0 1 2) nil #'<) #(0 1 2)) +(equalp (merge 'vector nil (list 0 1 2) #'<) #(0 1 2)) +(equalp (merge 'vector nil nil #'<) #()) +(equalp (merge 'vector + (list '(1 1) '(2 1) '(3 1)) + (list '(1 2) '(2 2) '(3 2)) #'< :key #'car) + #((1 1) (1 2) (2 1) (2 2) (3 1) (3 2))) +(equalp (merge 'vector + (list '(1 1) '(2 1) '(2 1 1) '(3 1)) + (list '(1 2) '(2 2) '(3 2)) #'< :key #'car) + #((1 1) (1 2) (2 1) (2 1 1) (2 2) (3 1) (3 2))) +(equalp (merge 'vector + (list '(1 1) '(2 1) '(2 1 1) '(3 1)) + (list '(1 2) '(2 2) '(3 2) '(3 2 2)) #'< :key #'car) + #((1 1) (1 2) (2 1) (2 1 1) (2 2) (3 1) (3 2) (3 2 2))) +(equalp (merge 'vector (list 3 1 9 5 7) (list 8 6 0 2 4) #'<) + #(3 1 8 6 0 2 4 9 5 7)) + + +(equalp (merge 'vector (vector 1 3 5 7 9) (list 0 2 4 6 8) #'<) + #(0 1 2 3 4 5 6 7 8 9)) +(equalp (merge 'vector (vector 1 3 5 7 9) (list 0 2 4 6 8) #'<) + #(0 1 2 3 4 5 6 7 8 9)) +(equalp (merge 'vector (vector 0 1 2) nil #'<) #(0 1 2)) +(equalp (merge 'vector #() (list 0 1 2) #'<) #(0 1 2)) +(equalp (merge 'vector #() #() #'<) #()) +(equalp (merge 'vector + (vector '(1 1) '(2 1) '(3 1)) + (list '(1 2) '(2 2) '(3 2)) #'< :key #'car) + #((1 1) (1 2) (2 1) (2 2) (3 1) (3 2))) +(equalp (merge 'vector + (vector '(1 1) '(2 1) '(2 1 1) '(3 1)) + (list '(1 2) '(2 2) '(3 2)) #'< :key #'car) + #((1 1) (1 2) (2 1) (2 1 1) (2 2) (3 1) (3 2))) +(equalp (merge 'vector + (vector '(1 1) '(2 1) '(2 1 1) '(3 1)) + (list '(1 2) '(2 2) '(3 2) '(3 2 2)) #'< :key #'car) + #((1 1) (1 2) (2 1) (2 1 1) (2 2) (3 1) (3 2) (3 2 2))) +(equalp (merge 'vector (vector 3 1 9 5 7) (list 8 6 0 2 4) #'<) + #(3 1 8 6 0 2 4 9 5 7)) + + +(equalp (merge 'vector (list 1 3 5 7 9) (vector 0 2 4 6 8) #'<) + #(0 1 2 3 4 5 6 7 8 9)) +(equalp (merge 'vector (list 1 3 5 7 9) (vector 0 2 4 6 8) #'<) + #(0 1 2 3 4 5 6 7 8 9)) +(equalp (merge 'vector (list 0 1 2) #() #'<) #(0 1 2)) +(equalp (merge 'vector nil (vector 0 1 2) #'<) #(0 1 2)) +(equalp (merge 'vector nil #() #'<) #()) +(equalp (merge 'vector + (list '(1 1) '(2 1) '(3 1)) + (vector '(1 2) '(2 2) '(3 2)) #'< :key #'car) + #((1 1) (1 2) (2 1) (2 2) (3 1) (3 2))) +(equalp (merge 'vector + (list '(1 1) '(2 1) '(2 1 1) '(3 1)) + (vector '(1 2) '(2 2) '(3 2)) #'< :key #'car) + #((1 1) (1 2) (2 1) (2 1 1) (2 2) (3 1) (3 2))) +(equalp (merge 'vector + (list '(1 1) '(2 1) '(2 1 1) '(3 1)) + (vector '(1 2) '(2 2) '(3 2) '(3 2 2)) #'< :key #'car) + #((1 1) (1 2) (2 1) (2 1 1) (2 2) (3 1) (3 2) (3 2 2))) +(equalp (merge 'vector (list 3 1 9 5 7) (vector 8 6 0 2 4) #'<) + #(3 1 8 6 0 2 4 9 5 7)) + + +(equalp (merge 'vector (vector 1 3 5 7 9) (vector 0 2 4 6 8) #'<) + #(0 1 2 3 4 5 6 7 8 9)) +(equalp (merge 'vector (vector 0 1 2) #() #'<) #(0 1 2)) +(equalp (merge 'vector #() (vector 0 1 2) #'<) #(0 1 2)) +(equalp (merge 'vector #() #() #'<) #()) +(equalp (merge 'vector + (vector '(1 1) '(2 1) '(3 1)) + (vector '(1 2) '(2 2) '(3 2)) #'< :key #'car) + #((1 1) (1 2) (2 1) (2 2) (3 1) (3 2))) +(equalp (merge 'vector + (vector '(1 1) '(2 1) '(2 1 1) '(3 1)) + (vector '(1 2) '(2 2) '(3 2)) #'< :key #'car) + #((1 1) (1 2) (2 1) (2 1 1) (2 2) (3 1) (3 2))) +(equalp (merge 'vector + (vector '(1 1) '(2 1) '(2 1 1) '(3 1)) + (vector '(1 2) '(2 2) '(3 2) '(3 2 2)) #'< :key #'car) + #((1 1) (1 2) (2 1) (2 1 1) (2 2) (3 1) (3 2) (3 2 2))) +(equalp (merge 'vector (vector 3 1 9 5 7) (vector 8 6 0 2 4) #'<) + #(3 1 8 6 0 2 4 9 5 7)) + + +(string= (merge 'string (list #\a #\c #\e) (list #\b #\d #\f) #'char<) "abcdef") +(string= (merge 'string (list #\a #\b #\c) (list #\d #\e #\f) #'char<) "abcdef") +(string= (merge 'string (list #\a #\b #\c) '() #'char<) "abc") +(string= (merge 'string '() (list #\a #\b #\c) #'char<) "abc") +(string= (merge 'string (list #\a #\b #\c) (copy-seq "") #'char<) "abc") +(string= (merge 'string (list #\a #\b #\c) (copy-seq "BCD") #'char-lessp) + "abBcCD") +(string= (merge 'string (list #\a #\b #\z) #(#\c #\x #\y) #'char<) "abcxyz") + +(equal (merge 'bit-vector (copy-seq #*0101) (copy-seq #*1010) #'<) #*01011010) +(equal (merge 'bit-vector (copy-seq #*0101) (copy-seq #*) #'<) #*0101) +(equal (merge 'bit-vector (copy-seq #*0101) '() #'<) #*0101) +(equal (merge 'bit-vector nil (copy-seq #*0101) #'<) #*0101) +(equal (merge 'bit-vector (copy-seq #*0101) (copy-seq #*0101) #'<) #*00101101) + + + + +(equal (remove 4 '(1 3 4 5 9)) '(1 3 5 9)) +(equal (remove 4 '(1 2 4 1 3 4 5)) '(1 2 1 3 5)) +(equal (remove 4 '(1 2 4 1 3 4 5) :count 1) '(1 2 1 3 4 5)) +(equal (remove 4 '(1 2 4 1 3 4 5) :count 1 :from-end t) '(1 2 4 1 3 5)) +(equal (remove 3 '(1 2 4 1 3 4 5) :test #'>) '(4 3 4 5)) +(let* ((lst '(list of four elements)) + (lst2 (copy-seq lst)) + (lst3 (delete 'four lst))) + (and (equal lst3 '(LIST OF ELEMENTS)) + (not (equal lst lst2)))) +(equal (remove-if #'oddp '(1 2 4 1 3 4 5)) '(2 4 4)) +(equal (remove-if #'evenp '(1 2 4 1 3 4 5) :count 1 :from-end t) + '(1 2 4 1 3 5)) +(equal (remove-if-not #'evenp '(1 2 3 4 5 6 7 8 9) :count 2 :from-end t) + '(1 2 3 4 5 6 8)) +(equal (delete 4 (list 1 2 4 1 3 4 5)) '(1 2 1 3 5)) +(equal (delete 4 (list 1 2 4 1 3 4 5) :count 1) '(1 2 1 3 4 5)) +(equal (delete 4 (list 1 2 4 1 3 4 5) :count 1 :from-end t) '(1 2 4 1 3 5)) +(equal (delete 3 (list 1 2 4 1 3 4 5) :test #'>) '(4 3 4 5)) +(equal (delete-if #'oddp (list 1 2 4 1 3 4 5)) '(2 4 4)) +(equal (delete-if #'evenp (list 1 2 4 1 3 4 5) :count 1 :from-end t) + '(1 2 4 1 3 5)) +(equal (delete-if #'evenp (list 1 2 3 4 5 6)) '(1 3 5)) + + +(let* ((list0 (list 0 1 2 3 4)) + (list (remove 3 list0))) + (and (not (eq list0 list)) + (equal list0 '(0 1 2 3 4)) + (equal list '(0 1 2 4)))) +(equal (remove 'a (list 'a 'b 'c 'a 'b 'c)) '(b c b c)) +(equal (remove 'b (list 'a 'b 'c 'a 'b 'c)) '(a c a c)) +(equal (remove 'c (list 'a 'b 'c 'a 'b 'c)) '(a b a b)) +(equal (remove 'a (list 'a 'a 'a)) '()) +(equal (remove 'z (list 'a 'b 'c)) '(a b c)) +(equal (remove 'a '()) '()) +(equal (remove 'a (list 'a 'b 'c 'a 'b 'c) :count 0) '(a b c a b c)) +(equal (remove 'a (list 'a 'b 'c 'a 'b 'c) :count 1) '(b c a b c)) +(equal (remove 'a (list 'a 'b 'c 'a 'b 'c) :count 1 :from-end t) '(a b c b c)) +(equal (remove 'a (list 'a 'b 'c 'a 'b 'c) :count 2) '(b c b c)) +(equal (remove 'a (list 'a 'b 'c 'a 'b 'c) :count 2 :from-end t) '(b c b c)) +(equal (remove 'a (list 'a 'b 'c 'a 'b 'c) :count 3) '(b c b c)) +(equal (remove 'a (list 'a 'b 'c 'a 'b 'c) :count 3 :from-end t) '(b c b c)) +(equal (remove 'a (list 'a 'b 'c 'a 'b 'c) :count 4) '(b c b c)) +(equal (remove 'a (list 'a 'b 'c 'a 'b 'c) :count 4 :from-end t) '(b c b c)) +(equal (remove 'a (list 'a 'b 'c 'a 'b 'c) :count -1) '(a b c a b c)) +(equal (remove 'a (list 'a 'b 'c 'a 'b 'c) :count -10) '(a b c a b c)) +(equal (remove 'a (list 'a 'b 'c 'a 'b 'c) :count -100) '(a b c a b c)) +(equal (remove 'a (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1) + '(a b c b c b c b c)) +(equal (remove 'a (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :count 1) + '(a b c b c a b c a b c)) +(equal (remove 'a (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :count 2) + '(a b c b c b c a b c)) +(equal (remove 'a (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :end nil :count 2) + '(a b c b c b c a b c)) +(equal (remove 'a (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :end 8) + '(a b c b c b c a b c)) +(equal (remove 'a (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :end 8 :count 1) + '(a b c b c a b c a b c)) +(equal (remove 'a (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :end 8 :count 1 :from-end t) + '(a b c a b c b c a b c)) +(equal (remove 'a (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :end 8 :count 0 :from-end t) + '(a b c a b c a b c a b c)) +(equal (remove 'a (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :end 8 :count -100 :from-end t) + '(a b c a b c a b c a b c)) +(equal (remove 'a (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :end 1) + '(a b c a b c a b c a b c)) +(equal (remove 'a (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 2 :end 2) + '(a b c a b c a b c a b c)) +(equal (remove 'a (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 12 :end 12) + '(a b c a b c a b c a b c)) +(equal (remove 'a (list '(a) '(b) '(c) '(a) '(b) '(c)) :key #'car) + '((b) (c) (b) (c))) +(equal (remove 'a (list '(a . b) '(b . c) '(c . a) + '(a . b) '(b . c) '(c . a)) + :key #'cdr) + '((a . b) (b . c) (a . b) (b . c))) +(equal (remove "love" (list '("Love") '("LOve") '("LOVe") '("LOVE")) :key #'car) + '(("Love") ("LOve") ("LOVe") ("LOVE"))) +(equal (remove "love" (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count -10) + '(("Love") ("LOve") ("LOVe") ("LOVE"))) +(equal (remove "love" (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test #'string-equal) + '()) +(equal (remove "love" (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test-not (complement #'string-equal)) + '()) +(equal (remove "love" (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test #'string-equal :count 1) + '(("LOve") ("LOVe") ("LOVE"))) +(equal (remove "love" (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test-not (complement #'string-equal) :count 1) + '(("LOve") ("LOVe") ("LOVE"))) +(equal (remove "love" (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test #'string-equal :count 1 :from-end t) + '(("Love") ("LOve") ("LOVe"))) +(equal (remove "love" (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test-not (complement #'string-equal) + :count 1 :from-end t) + '(("Love") ("LOve") ("LOVe"))) +(equal (remove "love" (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test #'string-equal :count 2 :from-end t) + '(("Love") ("LOve"))) +(equal (remove "love" (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test-not (complement #'string-equal) + :count 2 :from-end t) + '(("Love") ("LOve"))) +(equal (remove "love" (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test #'string-equal :start 1 :end 3) + '(("Love") ("LOVE"))) +(equal (remove "love" (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test-not (complement #'string-equal) :start 1 :end 3) + '(("Love") ("LOVE"))) +(equal (remove "love" (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test #'string-equal :count 1 :start 1 :end 3) + '(("Love") ("LOVe") ("LOVE"))) +(equal (remove "love" (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test-not (complement #'string-equal) + :count 1 :start 1 :end 3) + '(("Love") ("LOVe") ("LOVE"))) +(equal (remove "love" (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test #'string-equal :count 1 :from-end t + :start 1 :end 3) + '(("Love") ("LOve") ("LOVE"))) +(equal (remove "love" (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test-not (complement #'string-equal) + :count 1 :from-end t :start 1 :end 3) + '(("Love") ("LOve") ("LOVE"))) +(equal (remove "love" (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test #'string-equal :count 10 :from-end t + :start 1 :end 3) + '(("Love") ("LOVE"))) +(equal (remove "love" (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test-not (complement #'string-equal) + :count 10 :from-end t :start 1 :end 3) + '(("Love") ("LOVE"))) + + +(let* ((vector0 (vector 0 1 2 3 4)) + (vector (remove 3 vector0))) + (and (not (eq vector0 vector)) + (equalp vector0 #(0 1 2 3 4)) + (equalp vector #(0 1 2 4)))) +(equalp (remove 'a (vector 'a 'b 'c 'a 'b 'c)) #(b c b c)) +(equalp (remove 'b (vector 'a 'b 'c 'a 'b 'c)) #(a c a c)) +(equalp (remove 'c (vector 'a 'b 'c 'a 'b 'c)) #(a b a b)) +(equalp (remove 'a (vector 'a 'a 'a)) #()) +(equalp (remove 'z (vector 'a 'b 'c)) #(a b c)) +(equalp (remove 'a #()) #()) +(equalp (remove 'a (vector 'a 'b 'c 'a 'b 'c) :count 0) #(a b c a b c)) +(equalp (remove 'a (vector 'a 'b 'c 'a 'b 'c) :count 1) #(b c a b c)) +(equalp (remove 'a (vector 'a 'b 'c 'a 'b 'c) :count 1 :from-end t) #(a b c b c)) +(equalp (remove 'a (vector 'a 'b 'c 'a 'b 'c) :count 2) #(b c b c)) +(equalp (remove 'a (vector 'a 'b 'c 'a 'b 'c) :count 2 :from-end t) #(b c b c)) +(equalp (remove 'a (vector 'a 'b 'c 'a 'b 'c) :count 3) #(b c b c)) +(equalp (remove 'a (vector 'a 'b 'c 'a 'b 'c) :count 3 :from-end t) #(b c b c)) +(equalp (remove 'a (vector 'a 'b 'c 'a 'b 'c) :count 4) #(b c b c)) +(equalp (remove 'a (vector 'a 'b 'c 'a 'b 'c) :count 4 :from-end t) #(b c b c)) +(equalp (remove 'a (vector 'a 'b 'c 'a 'b 'c) :count -1) #(a b c a b c)) +(equalp (remove 'a (vector 'a 'b 'c 'a 'b 'c) :count -10) #(a b c a b c)) +(equalp (remove 'a (vector 'a 'b 'c 'a 'b 'c) :count -100) #(a b c a b c)) +(equalp (remove 'a (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1) + #(a b c b c b c b c)) +(equalp (remove 'a (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :count 1) + #(a b c b c a b c a b c)) +(equalp (remove 'a (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :count 2) + #(a b c b c b c a b c)) +(equalp (remove 'a (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :end nil :count 2) + #(a b c b c b c a b c)) +(equalp (remove 'a (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :end 8) + #(a b c b c b c a b c)) +(equalp (remove 'a (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :end 8 :count 1) + #(a b c b c a b c a b c)) +(equalp (remove 'a (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :end 8 :count 1 :from-end t) + #(a b c a b c b c a b c)) +(equalp (remove 'a (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :end 8 :count 0 :from-end t) + #(a b c a b c a b c a b c)) +(equalp (remove 'a (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :end 8 :count -100 :from-end t) + #(a b c a b c a b c a b c)) +(equalp (remove 'a (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :end 1) + #(a b c a b c a b c a b c)) +(equalp (remove 'a (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 2 :end 2) + #(a b c a b c a b c a b c)) +(equalp (remove 'a (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 12 :end 12) + #(a b c a b c a b c a b c)) +(equalp (remove 'a (vector '(a) '(b) '(c) '(a) '(b) '(c)) :key #'car) + #((b) (c) (b) (c))) +(equalp (remove 'a (vector '(a . b) '(b . c) '(c . a) + '(a . b) '(b . c) '(c . a)) + :key #'cdr) + #((a . b) (b . c) (a . b) (b . c))) +(equalp (remove "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car) + #(("Love") ("LOve") ("LOVe") ("LOVE"))) +(equalp (remove "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count -10) + #(("Love") ("LOve") ("LOVe") ("LOVE"))) +(equalp (remove "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test #'string-equal) + #()) +(equalp (remove "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test-not (complement #'string-equal)) + #()) +(equalp (remove "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test #'string-equal :count 1) + #(("LOve") ("LOVe") ("LOVE"))) +(equalp (remove "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test-not (complement #'string-equal) :count 1) + #(("LOve") ("LOVe") ("LOVE"))) +(equalp (remove "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test #'string-equal :count 1 :from-end t) + #(("Love") ("LOve") ("LOVe"))) +(equalp (remove "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test-not (complement #'string-equal) + :count 1 :from-end t) + #(("Love") ("LOve") ("LOVe"))) +(equalp (remove "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test #'string-equal :count 2 :from-end t) + #(("Love") ("LOve"))) +(equalp (remove "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test-not (complement #'string-equal) + :count 2 :from-end t) + #(("Love") ("LOve"))) +(equalp (remove "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test #'string-equal :start 1 :end 3) + #(("Love") ("LOVE"))) +(equalp (remove "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test-not (complement #'string-equal) :start 1 :end 3) + #(("Love") ("LOVE"))) +(equalp (remove "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test #'string-equal :count 1 :start 1 :end 3) + #(("Love") ("LOVe") ("LOVE"))) +(equalp (remove "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test-not (complement #'string-equal) + :count 1 :start 1 :end 3) + #(("Love") ("LOVe") ("LOVE"))) +(equalp (remove "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test #'string-equal :count 1 :from-end t + :start 1 :end 3) + #(("Love") ("LOve") ("LOVE"))) +(equalp (remove "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test-not (complement #'string-equal) + :count 1 :from-end t :start 1 :end 3) + #(("Love") ("LOve") ("LOVE"))) +(equalp (remove "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test #'string-equal :count 10 :from-end t + :start 1 :end 3) + #(("Love") ("LOVE"))) +(equalp (remove "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test-not (complement #'string-equal) + :count 10 :from-end t :start 1 :end 3) + #(("Love") ("LOVE"))) + +(string= (remove #\a (copy-seq "abcabc")) "bcbc") +(string= (remove #\a (copy-seq "")) "") +(string= (remove #\a (copy-seq "xyz")) "xyz") +(string= (remove #\a (copy-seq "ABCABC")) "ABCABC") +(string= (remove #\a (copy-seq "ABCABC") :key #'char-downcase) "BCBC") +(string= (remove #\a (copy-seq "abcabc") :count 1) "bcabc") +(string= (remove #\a (copy-seq "abcabc") :count 1 :from-end t) "abcbc") +(string= (remove #\a (copy-seq "abcabc") :count 0) "abcabc") +(string= (remove #\a (copy-seq "abcabc") :count -10) "abcabc") +(let* ((str0 (copy-seq "abc")) + (str (remove #\a str0))) + (and (not (eq str0 str)) + (string= str0 "abc") + (string= str "bc"))) +(string= (remove #\a (copy-seq "abcabc") :count 0) "abcabc") +(string= (remove #\a (copy-seq "abcabc")) "bcbc") +(string= (remove #\b (copy-seq "abcabc")) "acac") +(string= (remove #\c (copy-seq "abcabc")) "abab") +(string= (remove #\a (copy-seq "abcabc") :count 0) "abcabc") +(string= (remove #\a (copy-seq "abcabc") :count 1) "bcabc") +(string= (remove #\a (copy-seq "abcabc") :count 1 :from-end t) "abcbc") +(string= (remove #\a (copy-seq "abcabc") :count 2) "bcbc") +(string= (remove #\a (copy-seq "abcabc") :count 2 :from-end t) "bcbc") +(string= (remove #\a (copy-seq "abcabc") :count 3) "bcbc") +(string= (remove #\a (copy-seq "abcabc") :count 3 :from-end t) "bcbc") +(string= (remove #\a (copy-seq "abcabc") :count 4) "bcbc") +(string= (remove #\a (copy-seq "abcabc") :count 4 :from-end t) "bcbc") +(string= (remove #\a (copy-seq "abcabc") :count -1) "abcabc") +(string= (remove #\a (copy-seq "abcabc") :count -10) "abcabc") +(string= (remove #\a (copy-seq "abcabc") :count -100) "abcabc") +(string= (remove #\a (copy-seq "abcabcabcabc") :start 1) "abcbcbcbc") +(string= (remove #\a (copy-seq "abcabcabcabc") :start 1 :count 1) "abcbcabcabc") +(string= (remove #\a (copy-seq "abcabcabcabc") :start 1 :count 2) "abcbcbcabc") +(string= (remove #\a (copy-seq "abcabcabcabc") :start 1 :end nil :count 2) + "abcbcbcabc") +(string= (remove #\a (copy-seq "abcabcabcabc") :start 1 :end 8) "abcbcbcabc") +(string= (remove #\a (copy-seq "abcabcabcabc") :start 1 :end 8 :count 1) + "abcbcabcabc") +(string= (remove #\a (copy-seq "abcabcabcabc") + :start 1 :end 8 :count 1 :from-end t) + "abcabcbcabc") +(string= (remove #\a (copy-seq "abcabcabcabc") + :start 1 :end 8 :count 0 :from-end t) + "abcabcabcabc") +(string= (remove #\a (copy-seq "abcabcabcabc") + :start 1 :end 8 :count -100 :from-end t) + "abcabcabcabc") +(string= (remove #\a (copy-seq "abcabcabcabc") :start 1 :end 1) + "abcabcabcabc") +(string= (remove #\a (copy-seq "abcabcabcabc") :start 2 :end 2) "abcabcabcabc") +(string= (remove #\a (copy-seq "abcabcabcabc") :start 12 :end 12) "abcabcabcabc") +(equal (remove 0 #*0101) #*11) +(equal (remove 0 #*01010101 :count 1) #*1010101) +(equal (remove 0 #*01010101 :count 1 :from-end t) #*0101011) +(equal (remove 0 #*01010101 :start 1) #*01111) +(equal (remove 0 #*01010101 :start 1 :end nil) #*01111) +(equal (remove 0 #*01010101 :start 1 :end 6) #*011101) +(equal (remove 0 #*01010101 :start 1 :end 6 :count 1) #*0110101) +(equal (remove 0 #*01010101 :start 1 :end 6 :count 1 :from-end t) #*0101101) +(equal (remove 0 #*01010101 + :start 1 :end 6 :count 1 :from-end t + :test #'(lambda (a b) (declare (ignore a)) (oddp b))) + #*0101001) +(equal (remove 0 #*01010101 + :start 1 :end 6 :count 1 :from-end t + :test-not #'(lambda (a b) (declare (ignore a)) (evenp b))) + #*0101001) +(equal (remove 0 #*01010101 + :start 1 :end 6 :count 1 :from-end t + :test #'(lambda (a b) (declare (ignore a)) (evenp b))) + #*0101101) +(equal (remove 0 #*01010101 + :start 1 :end 6 :count 1 :from-end t + :test-not #'(lambda (a b) (declare (ignore a)) (oddp b))) + #*0101101) +(equal (remove 0 #*01010101 + :start 1 :end 6 :count 1 :from-end t + :key #'(lambda (arg) (* arg 10)) + :test #'(lambda (a b) (declare (ignore a)) (> b 1))) + #*0101001) + + +(let* ((list0 (list 0 1 2 3 4)) + (list (remove-if #'(lambda (arg) (eql arg 3)) list0))) + (and (not (eq list0 list)) + (equal list0 '(0 1 2 3 4)) + (equal list '(0 1 2 4)))) +(equal (remove-if #'(lambda (arg) (eql arg 'a)) (list 'a 'b 'c 'a 'b 'c)) + '(b c b c)) +(equal (remove-if #'(lambda (arg) (eql arg 'b)) (list 'a 'b 'c 'a 'b 'c)) + '(a c a c)) +(equal (remove-if #'(lambda (arg) (eql arg 'c)) (list 'a 'b 'c 'a 'b 'c)) + '(a b a b)) +(equal (remove-if #'(lambda (arg) (eql arg 'a)) (list 'a 'a 'a)) '()) +(equal (remove-if #'(lambda (arg) (eql arg 'z)) (list 'a 'b 'c)) '(a b c)) +(equal (remove-if #'(lambda (arg) (eql arg 'a)) '()) '()) +(equal (remove-if #'(lambda (arg) (eql arg 'a)) (list 'a 'b 'c 'a 'b 'c) + :count 0) '(a b c a b c)) +(equal (remove-if #'(lambda (arg) (eql arg 'a)) (list 'a 'b 'c 'a 'b 'c) + :count 1) '(b c a b c)) +(equal (remove-if #'(lambda (arg) (eql arg 'a)) (list 'a 'b 'c 'a 'b 'c) + :count 1 :from-end t) '(a b c b c)) +(equal (remove-if #'(lambda (arg) (eql arg 'a)) (list 'a 'b 'c 'a 'b 'c) + :count 2) '(b c b c)) +(equal (remove-if #'(lambda (arg) (eql arg 'a)) (list 'a 'b 'c 'a 'b 'c) + :count 2 :from-end t) '(b c b c)) +(equal (remove-if #'(lambda (arg) (eql arg 'a)) (list 'a 'b 'c 'a 'b 'c) + :count 3) '(b c b c)) +(equal (remove-if #'(lambda (arg) (eql arg 'a)) (list 'a 'b 'c 'a 'b 'c) + :count 3 :from-end t) '(b c b c)) +(equal (remove-if #'(lambda (arg) (eql arg 'a)) (list 'a 'b 'c 'a 'b 'c) + :count 4) '(b c b c)) +(equal (remove-if #'(lambda (arg) (eql arg 'a)) (list 'a 'b 'c 'a 'b 'c) + :count 4 :from-end t) '(b c b c)) +(equal (remove-if #'(lambda (arg) (eql arg 'a)) (list 'a 'b 'c 'a 'b 'c) + :count -1) '(a b c a b c)) +(equal (remove-if #'(lambda (arg) (eql arg 'a)) (list 'a 'b 'c 'a 'b 'c) + :count -10) '(a b c a b c)) +(equal (remove-if #'(lambda (arg) (eql arg 'a)) (list 'a 'b 'c 'a 'b 'c) + :count -100) '(a b c a b c)) +(equal (remove-if #'(lambda (arg) (eql arg 'a)) + (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1) + '(a b c b c b c b c)) +(equal (remove-if #'(lambda (arg) (eql arg 'a)) + (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :count 1) + '(a b c b c a b c a b c)) +(equal (remove-if #'(lambda (arg) (eql arg 'a)) + (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :count 2) + '(a b c b c b c a b c)) +(equal (remove-if #'(lambda (arg) (eql arg 'a)) + (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :end nil :count 2) + '(a b c b c b c a b c)) +(equal (remove-if #'(lambda (arg) (eql arg 'a)) + (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :end 8) + '(a b c b c b c a b c)) +(equal (remove-if #'(lambda (arg) (eql arg 'a)) + (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :end 8 :count 1) + '(a b c b c a b c a b c)) +(equal (remove-if #'(lambda (arg) (eql arg 'a)) + (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :end 8 :count 1 :from-end t) + '(a b c a b c b c a b c)) +(equal (remove-if #'(lambda (arg) (eql arg 'a)) + (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :end 8 :count 0 :from-end t) + '(a b c a b c a b c a b c)) +(equal (remove-if #'(lambda (arg) (eql arg 'a)) + (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :end 8 :count -100 :from-end t) + '(a b c a b c a b c a b c)) +(equal (remove-if #'(lambda (arg) (eql arg 'a)) + (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :end 1) + '(a b c a b c a b c a b c)) +(equal (remove-if #'(lambda (arg) (eql arg 'a)) + (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 2 :end 2) + '(a b c a b c a b c a b c)) +(equal (remove-if #'(lambda (arg) (eql arg 'a)) + (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 12 :end 12) + '(a b c a b c a b c a b c)) +(equal (remove-if #'(lambda (arg) (eql arg 'a)) + (list '(a) '(b) '(c) '(a) '(b) '(c)) :key #'car) + '((b) (c) (b) (c))) +(equal (remove-if #'(lambda (arg) (eql arg 'a)) + (list '(a . b) '(b . c) '(c . a) + '(a . b) '(b . c) '(c . a)) + :key #'cdr) + '((a . b) (b . c) (a . b) (b . c))) +(equal (remove-if #'(lambda (arg) (eql arg "love")) + (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car) + '(("Love") ("LOve") ("LOVe") ("LOVE"))) +(equal (remove-if #'(lambda (arg) (eql arg "love")) + (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count -10) + '(("Love") ("LOve") ("LOVe") ("LOVE"))) +(equal (remove-if #'(lambda (arg) (string-equal arg "love")) + (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car) + '()) +(equal (remove-if #'(lambda (arg) (string-equal arg "love")) + (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count 1) + '(("LOve") ("LOVe") ("LOVE"))) +(equal (remove-if #'(lambda (arg) (string-equal arg "love")) + (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count 1 :from-end t) + '(("Love") ("LOve") ("LOVe"))) +(equal (remove-if #'(lambda (arg) (string-equal arg "love")) + (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count 2 :from-end t) + '(("Love") ("LOve"))) +(equal (remove-if #'(lambda (arg) (string-equal arg "love")) + (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :start 1 :end 3) + '(("Love") ("LOVE"))) +(equal (remove-if #'(lambda (arg) (string-equal arg "love")) + (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count 1 :start 1 :end 3) + '(("Love") ("LOVe") ("LOVE"))) +(equal (remove-if #'(lambda (arg) (string-equal arg "love")) + (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count 1 :from-end t + :start 1 :end 3) + '(("Love") ("LOve") ("LOVE"))) +(equal (remove-if #'(lambda (arg) (string-equal arg "love")) + (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count 10 :from-end t :start 1 :end 3) + '(("Love") ("LOVE"))) + + +(let* ((vector0 (vector 0 1 2 3 4)) + (vector (remove-if #'(lambda (arg) (eql arg 3)) vector0))) + (and (not (eq vector0 vector)) + (equalp vector0 #(0 1 2 3 4)) + (equalp vector #(0 1 2 4)))) +(equalp (remove-if #'(lambda (arg) (eql arg 'a)) + (vector 'a 'b 'c 'a 'b 'c)) #(b c b c)) +(equalp (remove-if #'(lambda (arg) (eql arg 'b)) + (vector 'a 'b 'c 'a 'b 'c)) #(a c a c)) +(equalp (remove-if #'(lambda (arg) (eql arg 'c)) + (vector 'a 'b 'c 'a 'b 'c)) #(a b a b)) +(equalp (remove-if #'(lambda (arg) (eql arg 'a)) + (vector 'a 'a 'a)) #()) +(equalp (remove-if #'(lambda (arg) (eql arg 'z)) + (vector 'a 'b 'c)) #(a b c)) +(equalp (remove-if #'(lambda (arg) (eql arg 'a)) #()) #()) +(equalp (remove-if #'(lambda (arg) (eql arg 'a)) + (vector 'a 'b 'c 'a 'b 'c) :count 0) #(a b c a b c)) +(equalp (remove-if #'(lambda (arg) (eql arg 'a)) + (vector 'a 'b 'c 'a 'b 'c) :count 1) #(b c a b c)) +(equalp (remove-if #'(lambda (arg) (eql arg 'a)) + (vector 'a 'b 'c 'a 'b 'c) :count 1 :from-end t) #(a b c b c)) +(equalp (remove-if #'(lambda (arg) (eql arg 'a)) + (vector 'a 'b 'c 'a 'b 'c) :count 2) #(b c b c)) +(equalp (remove-if #'(lambda (arg) (eql arg 'a)) + (vector 'a 'b 'c 'a 'b 'c) :count 2 :from-end t) #(b c b c)) +(equalp (remove-if #'(lambda (arg) (eql arg 'a)) + (vector 'a 'b 'c 'a 'b 'c) :count 3) #(b c b c)) +(equalp (remove-if #'(lambda (arg) (eql arg 'a)) + (vector 'a 'b 'c 'a 'b 'c) :count 3 :from-end t) #(b c b c)) +(equalp (remove-if #'(lambda (arg) (eql arg 'a)) + (vector 'a 'b 'c 'a 'b 'c) :count 4) #(b c b c)) +(equalp (remove-if #'(lambda (arg) (eql arg 'a)) + (vector 'a 'b 'c 'a 'b 'c) :count 4 :from-end t) #(b c b c)) +(equalp (remove-if #'(lambda (arg) (eql arg 'a)) + (vector 'a 'b 'c 'a 'b 'c) :count -1) #(a b c a b c)) +(equalp (remove-if #'(lambda (arg) (eql arg 'a)) + (vector 'a 'b 'c 'a 'b 'c) :count -10) #(a b c a b c)) +(equalp (remove-if #'(lambda (arg) (eql arg 'a)) + (vector 'a 'b 'c 'a 'b 'c) :count -100) #(a b c a b c)) +(equalp (remove-if #'(lambda (arg) (eql arg 'a)) + (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1) + #(a b c b c b c b c)) +(equalp (remove-if #'(lambda (arg) (eql arg 'a)) + (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :count 1) + #(a b c b c a b c a b c)) +(equalp (remove-if #'(lambda (arg) (eql arg 'a)) + (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :count 2) + #(a b c b c b c a b c)) +(equalp (remove-if #'(lambda (arg) (eql arg 'a)) + (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :end nil :count 2) + #(a b c b c b c a b c)) +(equalp (remove-if #'(lambda (arg) (eql arg 'a)) + (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :end 8) + #(a b c b c b c a b c)) +(equalp (remove-if #'(lambda (arg) (eql arg 'a)) + (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :end 8 :count 1) + #(a b c b c a b c a b c)) +(equalp (remove-if #'(lambda (arg) (eql arg 'a)) + (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :end 8 :count 1 :from-end t) + #(a b c a b c b c a b c)) +(equalp (remove-if #'(lambda (arg) (eql arg 'a)) + (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :end 8 :count 0 :from-end t) + #(a b c a b c a b c a b c)) +(equalp (remove-if #'(lambda (arg) (eql arg 'a)) + (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :end 8 :count -100 :from-end t) + #(a b c a b c a b c a b c)) +(equalp (remove-if #'(lambda (arg) (eql arg 'a)) + (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :end 1) + #(a b c a b c a b c a b c)) +(equalp (remove-if #'(lambda (arg) (eql arg 'a)) + (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 2 :end 2) + #(a b c a b c a b c a b c)) +(equalp (remove-if #'(lambda (arg) (eql arg 'a)) + (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 12 :end 12) + #(a b c a b c a b c a b c)) +(equalp (remove-if #'(lambda (arg) (eql arg 'a)) + (vector '(a) '(b) '(c) '(a) '(b) '(c)) :key #'car) + #((b) (c) (b) (c))) +(equalp (remove-if #'(lambda (arg) (eql arg 'a)) + (vector '(a . b) '(b . c) '(c . a) + '(a . b) '(b . c) '(c . a)) + :key #'cdr) + #((a . b) (b . c) (a . b) (b . c))) +(equalp (remove-if #'(lambda (arg) (eql arg "love")) + (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car) + #(("Love") ("LOve") ("LOVe") ("LOVE"))) +(equalp (remove-if #'(lambda (arg) (eql arg "love")) + (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count -10) + #(("Love") ("LOve") ("LOVe") ("LOVE"))) +(equalp (remove-if #'(lambda (arg) (string-equal arg "love")) + (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car) + #()) +(equalp (remove-if #'(lambda (arg) (string-equal arg "love")) + (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car) + #()) +(equalp (remove-if #'(lambda (arg) (string-equal arg "love")) + (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count 1) + #(("LOve") ("LOVe") ("LOVE"))) +(equalp (remove-if #'(lambda (arg) (string-equal arg "love")) + (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count 1) + #(("LOve") ("LOVe") ("LOVE"))) +(equalp (remove-if #'(lambda (arg) (string-equal arg "love")) + (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count 1 :from-end t) + #(("Love") ("LOve") ("LOVe"))) +(equalp (remove-if #'(lambda (arg) (string-equal arg "love")) + (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count 1 :from-end t) + #(("Love") ("LOve") ("LOVe"))) +(equalp (remove-if #'(lambda (arg) (string-equal arg "love")) + (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count 2 :from-end t) + #(("Love") ("LOve"))) +(equalp (remove-if #'(lambda (arg) (string-equal arg "love")) + (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count 2 :from-end t) + #(("Love") ("LOve"))) +(equalp (remove-if #'(lambda (arg) (string-equal arg "love")) + (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :start 1 :end 3) + #(("Love") ("LOVE"))) +(equalp (remove-if #'(lambda (arg) (string-equal arg "love")) + (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count 1 :start 1 :end 3) + #(("Love") ("LOVe") ("LOVE"))) +(equalp (remove-if #'(lambda (arg) (string-equal arg "love")) + (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count 1 :from-end t + :start 1 :end 3) + #(("Love") ("LOve") ("LOVE"))) +(equalp (remove-if #'(lambda (arg) (string-equal arg "love")) + (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count 10 :from-end t + :start 1 :end 3) + #(("Love") ("LOVE"))) + +(string= (remove-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc")) + "bcbc") +(string= (remove-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "")) "") +(string= (remove-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "xyz")) + "xyz") +(string= (remove-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "ABCABC") + :key #'char-downcase) "BCBC") +(string= (remove-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc") + :count 1) "bcabc") +(string= (remove-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc") + :count 1 :from-end t) "abcbc") +(string= (remove-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc") + :count 0) "abcabc") +(string= (remove-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc") + :count -10) "abcabc") +(let* ((str0 (copy-seq "abc")) + (str (remove-if #'(lambda (arg) (string-equal arg #\a)) str0))) + (and (not (eq str0 str)) + (string= str0 "abc") + (string= str "bc"))) +(string= (remove-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc") + :count 0) "abcabc") +(string= (remove-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc")) + "bcbc") +(string= (remove-if #'(lambda (arg) (string-equal arg #\b)) (copy-seq "abcabc")) + "acac") +(string= (remove-if #'(lambda (arg) (string-equal arg #\c)) (copy-seq "abcabc")) + "abab") +(string= (remove-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc") + :count 0) "abcabc") +(string= (remove-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc") + :count 1) "bcabc") +(string= (remove-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc") + :count 1 :from-end t) "abcbc") +(string= (remove-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc") + :count 2) "bcbc") +(string= (remove-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc") + :count 2 :from-end t) "bcbc") +(string= (remove-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc") + :count 3) "bcbc") +(string= (remove-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc") + :count 3 :from-end t) "bcbc") +(string= (remove-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc") + :count 4) "bcbc") +(string= (remove-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc") + :count 4 :from-end t) "bcbc") +(string= (remove-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc") + :count -1) "abcabc") +(string= (remove-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc") + :count -10) "abcabc") +(string= (remove-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc") + :count -100) "abcabc") +(string= (remove-if #'(lambda (arg) (string-equal arg #\a)) + (copy-seq "abcabcabcabc") :start 1) "abcbcbcbc") +(string= (remove-if #'(lambda (arg) (string-equal arg #\a)) + (copy-seq "abcabcabcabc") :start 1 :count 1) "abcbcabcabc") +(string= (remove-if #'(lambda (arg) (eql arg #\a)) (copy-seq "abcabcabcabc") + :start 1 :count 2) + "abcbcbcabc") +(string= (remove-if #'(lambda (arg) (eql arg #\a)) (copy-seq "abcabcabcabc") + :start 1 :end nil :count 2) + "abcbcbcabc") +(string= (remove-if #'(lambda (arg) (eql arg #\a)) (copy-seq "abcabcabcabc") + :start 1 :end 8) "abcbcbcabc") +(string= (remove-if #'(lambda (arg) (eql arg #\a)) (copy-seq "abcabcabcabc") + :start 1 :end 8 :count 1) + "abcbcabcabc") +(string= (remove-if #'(lambda (arg) (eql arg #\a)) (copy-seq "abcabcabcabc") + :start 1 :end 8 :count 1 :from-end t) + "abcabcbcabc") +(string= (remove-if #'(lambda (arg) (eql arg #\a)) (copy-seq "abcabcabcabc") + :start 1 :end 8 :count 0 :from-end t) + "abcabcabcabc") +(string= (remove-if #'(lambda (arg) (eql arg #\a)) (copy-seq "abcabcabcabc") + :start 1 :end 8 :count -100 :from-end t) + "abcabcabcabc") +(string= (remove-if #'(lambda (arg) (eql arg #\a)) (copy-seq "abcabcabcabc") + :start 1 :end 1) + "abcabcabcabc") +(string= (remove-if #'(lambda (arg) (eql arg #\a)) (copy-seq "abcabcabcabc") + :start 2 :end 2) "abcabcabcabc") +(string= (remove-if #'(lambda (arg) (eql arg #\a)) (copy-seq "abcabcabcabc") + :start 12 :end 12) "abcabcabcabc") +(equal (remove-if #'zerop #*0101) #*11) +(equal (remove-if #'zerop #*01010101 :count 1) #*1010101) +(equal (remove-if #'zerop #*01010101 :count 1 :from-end t) #*0101011) +(equal (remove-if #'zerop #*01010101 :start 1) #*01111) +(equal (remove-if #'zerop #*01010101 :start 1 :end nil) #*01111) +(equal (remove-if #'zerop #*01010101 :start 1 :end 6) #*011101) +(equal (remove-if #'zerop #*01010101 :start 1 :end 6 :count 1) #*0110101) +(equal (remove-if #'zerop #*01010101 :start 1 :end 6 :count 1 :from-end t) + #*0101101) +(equal (remove-if #'oddp #*01010101 :start 1 :end 6 :count 1 :from-end t) + #*0101001) +(equal (remove-if #'evenp #*01010101 :start 1 :end 6 :count 1 :from-end t) + #*0101101) +(equal (remove-if #'plusp #*01010101 + :start 1 :end 6 :count 1 :from-end t + :key #'(lambda (arg) (* arg 10))) + #*0101001) + + +(let* ((list0 (list 0 1 2 3 4)) + (list (remove-if-not #'(lambda (arg) (not (eql arg 3))) list0))) + (and (not (eq list0 list)) + (equal list0 '(0 1 2 3 4)) + (equal list '(0 1 2 4)))) +(equal (remove-if-not #'(lambda (arg) (not (eql arg 'a))) + (list 'a 'b 'c 'a 'b 'c)) + '(b c b c)) +(equal (remove-if-not #'(lambda (arg) (not (eql arg 'b))) + (list 'a 'b 'c 'a 'b 'c)) + '(a c a c)) +(equal (remove-if-not #'(lambda (arg) (not (eql arg 'c))) + (list 'a 'b 'c 'a 'b 'c)) + '(a b a b)) +(equal (remove-if-not #'(lambda (arg) (not (eql arg 'a))) + (list 'a 'a 'a)) '()) +(equal (remove-if-not #'(lambda (arg) (not (eql arg 'z))) + (list 'a 'b 'c)) '(a b c)) +(equal (remove-if-not #'(lambda (arg) (not (eql arg 'a))) '()) '()) +(equal (remove-if-not #'(lambda (arg) (not (eql arg 'a))) + (list 'a 'b 'c 'a 'b 'c) :count 0) '(a b c a b c)) +(equal (remove-if-not #'(lambda (arg) (not (eql arg 'a))) + (list 'a 'b 'c 'a 'b 'c) :count 1) '(b c a b c)) +(equal (remove-if-not #'(lambda (arg) (not (eql arg 'a))) + (list 'a 'b 'c 'a 'b 'c) :count 1 :from-end t) + '(a b c b c)) +(equal (remove-if-not #'(lambda (arg) (not (eql arg 'a))) + (list 'a 'b 'c 'a 'b 'c) :count 2) + '(b c b c)) +(equal (remove-if-not #'(lambda (arg) (not (eql arg 'a))) + (list 'a 'b 'c 'a 'b 'c) :count 2 :from-end t) + '(b c b c)) +(equal (remove-if-not #'(lambda (arg) (not (eql arg 'a))) + (list 'a 'b 'c 'a 'b 'c) :count 3) + '(b c b c)) +(equal (remove-if-not #'(lambda (arg) (not (eql arg 'a))) + (list 'a 'b 'c 'a 'b 'c) :count 3 :from-end t) + '(b c b c)) +(equal (remove-if-not #'(lambda (arg) (not (eql arg 'a))) + (list 'a 'b 'c 'a 'b 'c) :count 4) + '(b c b c)) +(equal (remove-if-not #'(lambda (arg) (not (eql arg 'a))) + (list 'a 'b 'c 'a 'b 'c) :count 4 :from-end t) + '(b c b c)) +(equal (remove-if-not #'(lambda (arg) (not (eql arg 'a))) + (list 'a 'b 'c 'a 'b 'c) :count -1) + '(a b c a b c)) +(equal (remove-if-not #'(lambda (arg) (not (eql arg 'a))) + (list 'a 'b 'c 'a 'b 'c) :count -10) + '(a b c a b c)) +(equal (remove-if-not #'(lambda (arg) (not (eql arg 'a))) + (list 'a 'b 'c 'a 'b 'c) :count -100) + '(a b c a b c)) +(equal (remove-if-not #'(lambda (arg) (not (eql arg 'a))) + (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1) + '(a b c b c b c b c)) +(equal (remove-if-not #'(lambda (arg) (not (eql arg 'a))) + (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :count 1) + '(a b c b c a b c a b c)) +(equal (remove-if-not #'(lambda (arg) (not (eql arg 'a))) + (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :count 2) + '(a b c b c b c a b c)) +(equal (remove-if-not #'(lambda (arg) (not (eql arg 'a))) + (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :end nil :count 2) + '(a b c b c b c a b c)) +(equal (remove-if-not #'(lambda (arg) (not (eql arg 'a))) + (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :end 8) + '(a b c b c b c a b c)) +(equal (remove-if-not #'(lambda (arg) (not (eql arg 'a))) + (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :end 8 :count 1) + '(a b c b c a b c a b c)) +(equal (remove-if-not #'(lambda (arg) (not (eql arg 'a))) + (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :end 8 :count 1 :from-end t) + '(a b c a b c b c a b c)) +(equal (remove-if-not #'(lambda (arg) (not (eql arg 'a))) + (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :end 8 :count 0 :from-end t) + '(a b c a b c a b c a b c)) +(equal (remove-if-not #'(lambda (arg) (not (eql arg 'a))) + (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :end 8 :count -100 :from-end t) + '(a b c a b c a b c a b c)) +(equal (remove-if-not #'(lambda (arg) (not (eql arg 'a))) + (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :end 1) + '(a b c a b c a b c a b c)) +(equal (remove-if-not #'(lambda (arg) (not (eql arg 'a))) + (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 2 :end 2) + '(a b c a b c a b c a b c)) +(equal (remove-if-not #'(lambda (arg) (not (eql arg 'a))) + (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 12 :end 12) + '(a b c a b c a b c a b c)) +(equal (remove-if-not #'(lambda (arg) (not (eql arg 'a))) + (list '(a) '(b) '(c) '(a) '(b) '(c)) :key #'car) + '((b) (c) (b) (c))) +(equal (remove-if-not #'(lambda (arg) (not (eql arg 'a))) + (list '(a . b) '(b . c) '(c . a) + '(a . b) '(b . c) '(c . a)) + :key #'cdr) + '((a . b) (b . c) (a . b) (b . c))) +(equal (remove-if-not #'(lambda (arg) (not (eql arg "love"))) + (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car) + '(("Love") ("LOve") ("LOVe") ("LOVE"))) +(equal (remove-if-not #'(lambda (arg) (not (eql arg "love"))) + (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count -10) + '(("Love") ("LOve") ("LOVe") ("LOVE"))) +(equal (remove-if-not #'(lambda (arg) (not (string-equal arg "love"))) + (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car) + '()) +(equal (remove-if-not #'(lambda (arg) (not (string-equal arg "love"))) + (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count 1) + '(("LOve") ("LOVe") ("LOVE"))) +(equal (remove-if-not #'(lambda (arg) (not (string-equal arg "love"))) + (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count 1 :from-end t) + '(("Love") ("LOve") ("LOVe"))) +(equal (remove-if-not #'(lambda (arg) (not (string-equal arg "love"))) + (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count 2 :from-end t) + '(("Love") ("LOve"))) +(equal (remove-if-not #'(lambda (arg) (not (string-equal arg "love"))) + (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :start 1 :end 3) + '(("Love") ("LOVE"))) +(equal (remove-if-not #'(lambda (arg) (not (string-equal arg "love"))) + (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count 1 :start 1 :end 3) + '(("Love") ("LOVe") ("LOVE"))) +(equal (remove-if-not #'(lambda (arg) (not (string-equal arg "love"))) + (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count 1 :from-end t + :start 1 :end 3) + '(("Love") ("LOve") ("LOVE"))) +(equal (remove-if-not #'(lambda (arg) (not (string-equal arg "love"))) + (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count 10 :from-end t :start 1 :end 3) + '(("Love") ("LOVE"))) + + +(let* ((vector0 (vector 0 1 2 3 4)) + (vector (remove-if-not #'(lambda (arg) (not (eql arg 3))) vector0))) + (and (not (eq vector0 vector)) + (equalp vector0 #(0 1 2 3 4)) + (equalp vector #(0 1 2 4)))) +(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'a))) + (vector 'a 'b 'c 'a 'b 'c)) #(b c b c)) +(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'b))) + (vector 'a 'b 'c 'a 'b 'c)) #(a c a c)) +(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'c))) + (vector 'a 'b 'c 'a 'b 'c)) #(a b a b)) +(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'a))) + (vector 'a 'a 'a)) #()) +(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'z))) + (vector 'a 'b 'c)) #(a b c)) +(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'a))) #()) #()) +(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'a))) + (vector 'a 'b 'c 'a 'b 'c) :count 0) #(a b c a b c)) +(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'a))) + (vector 'a 'b 'c 'a 'b 'c) :count 1) #(b c a b c)) +(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'a))) + (vector 'a 'b 'c 'a 'b 'c) :count 1 :from-end t) #(a b c b c)) +(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'a))) + (vector 'a 'b 'c 'a 'b 'c) :count 2) #(b c b c)) +(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'a))) + (vector 'a 'b 'c 'a 'b 'c) :count 2 :from-end t) #(b c b c)) +(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'a))) + (vector 'a 'b 'c 'a 'b 'c) :count 3) #(b c b c)) +(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'a))) + (vector 'a 'b 'c 'a 'b 'c) :count 3 :from-end t) #(b c b c)) +(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'a))) + (vector 'a 'b 'c 'a 'b 'c) :count 4) #(b c b c)) +(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'a))) + (vector 'a 'b 'c 'a 'b 'c) :count 4 :from-end t) #(b c b c)) +(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'a))) + (vector 'a 'b 'c 'a 'b 'c) :count -1) #(a b c a b c)) +(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'a))) + (vector 'a 'b 'c 'a 'b 'c) :count -10) #(a b c a b c)) +(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'a))) + (vector 'a 'b 'c 'a 'b 'c) :count -100) #(a b c a b c)) +(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'a))) + (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1) + #(a b c b c b c b c)) +(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'a))) + (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :count 1) + #(a b c b c a b c a b c)) +(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'a))) + (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :count 2) + #(a b c b c b c a b c)) +(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'a))) + (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :end nil :count 2) + #(a b c b c b c a b c)) +(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'a))) + (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :end 8) + #(a b c b c b c a b c)) +(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'a))) + (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :end 8 :count 1) + #(a b c b c a b c a b c)) +(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'a))) + (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :end 8 :count 1 :from-end t) + #(a b c a b c b c a b c)) +(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'a))) + (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :end 8 :count 0 :from-end t) + #(a b c a b c a b c a b c)) +(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'a))) + (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :end 8 :count -100 :from-end t) + #(a b c a b c a b c a b c)) +(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'a))) + (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :end 1) + #(a b c a b c a b c a b c)) +(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'a))) + (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 2 :end 2) + #(a b c a b c a b c a b c)) +(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'a))) + (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 12 :end 12) + #(a b c a b c a b c a b c)) +(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'a))) + (vector '(a) '(b) '(c) '(a) '(b) '(c)) :key #'car) + #((b) (c) (b) (c))) +(equalp (remove-if-not #'(lambda (arg) (not (eql arg 'a))) + (vector '(a . b) '(b . c) '(c . a) + '(a . b) '(b . c) '(c . a)) + :key #'cdr) + #((a . b) (b . c) (a . b) (b . c))) +(equalp (remove-if-not #'(lambda (arg) (not (eql arg "love"))) + (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car) + #(("Love") ("LOve") ("LOVe") ("LOVE"))) +(equalp (remove-if-not #'(lambda (arg) (not (eql arg "love"))) + (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count -10) + #(("Love") ("LOve") ("LOVe") ("LOVE"))) +(equalp (remove-if-not #'(lambda (arg) (not (string-equal arg "love"))) + (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car) + #()) +(equalp (remove-if-not #'(lambda (arg) (not (string-equal arg "love"))) + (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car) + #()) +(equalp (remove-if-not #'(lambda (arg) (not (string-equal arg "love"))) + (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count 1) + #(("LOve") ("LOVe") ("LOVE"))) +(equalp (remove-if-not #'(lambda (arg) (not (string-equal arg "love"))) + (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count 1) + #(("LOve") ("LOVe") ("LOVE"))) +(equalp (remove-if-not #'(lambda (arg) (not (string-equal arg "love"))) + (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count 1 :from-end t) + #(("Love") ("LOve") ("LOVe"))) +(equalp (remove-if-not #'(lambda (arg) (not (string-equal arg "love"))) + (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count 1 :from-end t) + #(("Love") ("LOve") ("LOVe"))) +(equalp (remove-if-not #'(lambda (arg) (not (string-equal arg "love"))) + (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count 2 :from-end t) + #(("Love") ("LOve"))) +(equalp (remove-if-not #'(lambda (arg) (not (string-equal arg "love"))) + (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count 2 :from-end t) + #(("Love") ("LOve"))) +(equalp (remove-if-not #'(lambda (arg) (not (string-equal arg "love"))) + (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :start 1 :end 3) + #(("Love") ("LOVE"))) +(equalp (remove-if-not #'(lambda (arg) (not (string-equal arg "love"))) + (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count 1 :start 1 :end 3) + #(("Love") ("LOVe") ("LOVE"))) +(equalp (remove-if-not #'(lambda (arg) (not (string-equal arg "love"))) + (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count 1 :from-end t + :start 1 :end 3) + #(("Love") ("LOve") ("LOVE"))) +(equalp (remove-if-not #'(lambda (arg) (not (string-equal arg "love"))) + (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count 10 :from-end t + :start 1 :end 3) + #(("Love") ("LOVE"))) + +(string= (remove-if-not #'(lambda (arg) (not (string-equal arg #\a))) + (copy-seq "abcabc")) + "bcbc") +(string= (remove-if-not #'(lambda (arg) (not (string-equal arg #\a))) + (copy-seq "")) "") +(string= (remove-if-not #'(lambda (arg) (not (string-equal arg #\a))) + (copy-seq "xyz")) + "xyz") +(string= (remove-if-not #'(lambda (arg) (not (string-equal arg #\a))) + (copy-seq "ABCABC") + :key #'char-downcase) "BCBC") +(string= (remove-if-not #'(lambda (arg) (not (string-equal arg #\a))) + (copy-seq "abcabc") + :count 1) "bcabc") +(string= (remove-if-not #'(lambda (arg) (not (string-equal arg #\a))) + (copy-seq "abcabc") + :count 1 :from-end t) "abcbc") +(string= (remove-if-not #'(lambda (arg) (not (string-equal arg #\a))) + (copy-seq "abcabc") + :count 0) "abcabc") +(string= (remove-if-not #'(lambda (arg) (not (string-equal arg #\a))) + (copy-seq "abcabc") + :count -10) "abcabc") +(let* ((str0 (copy-seq "abc")) + (str (remove-if-not #'(lambda (arg) (not (string-equal arg #\a))) str0))) + (and (not (eq str0 str)) + (string= str0 "abc") + (string= str "bc"))) +(string= (remove-if-not #'(lambda (arg) (not (string-equal arg #\a))) + (copy-seq "abcabc") + :count 0) "abcabc") +(string= (remove-if-not #'(lambda (arg) (not (string-equal arg #\a))) + (copy-seq "abcabc")) + "bcbc") +(string= (remove-if-not #'(lambda (arg) (not (string-equal arg #\b))) + (copy-seq "abcabc")) + "acac") +(string= (remove-if-not #'(lambda (arg) (not (string-equal arg #\c))) + (copy-seq "abcabc")) + "abab") +(string= (remove-if-not #'(lambda (arg) (not (string-equal arg #\a))) + (copy-seq "abcabc") + :count 0) "abcabc") +(string= (remove-if-not #'(lambda (arg) (not (string-equal arg #\a))) + (copy-seq "abcabc") + :count 1) "bcabc") +(string= (remove-if-not #'(lambda (arg) (not (string-equal arg #\a))) + (copy-seq "abcabc") + :count 1 :from-end t) "abcbc") +(string= (remove-if-not #'(lambda (arg) (not (string-equal arg #\a))) + (copy-seq "abcabc") + :count 2) "bcbc") +(string= (remove-if-not #'(lambda (arg) (not (string-equal arg #\a))) + (copy-seq "abcabc") + :count 2 :from-end t) "bcbc") +(string= (remove-if-not #'(lambda (arg) (not (string-equal arg #\a))) + (copy-seq "abcabc") + :count 3) "bcbc") +(string= (remove-if-not #'(lambda (arg) (not (string-equal arg #\a))) + (copy-seq "abcabc") + :count 3 :from-end t) "bcbc") +(string= (remove-if-not #'(lambda (arg) (not (string-equal arg #\a))) + (copy-seq "abcabc") + :count 4) "bcbc") +(string= (remove-if-not #'(lambda (arg) (not (string-equal arg #\a))) + (copy-seq "abcabc") + :count 4 :from-end t) "bcbc") +(string= (remove-if-not #'(lambda (arg) (not (string-equal arg #\a))) + (copy-seq "abcabc") + :count -1) "abcabc") +(string= (remove-if-not #'(lambda (arg) (not (string-equal arg #\a))) + (copy-seq "abcabc") + :count -10) "abcabc") +(string= (remove-if-not #'(lambda (arg) (not (string-equal arg #\a))) + (copy-seq "abcabc") + :count -100) "abcabc") +(string= (remove-if-not #'(lambda (arg) (not (string-equal arg #\a))) + (copy-seq "abcabcabcabc") :start 1) "abcbcbcbc") +(string= (remove-if-not #'(lambda (arg) (not (string-equal arg #\a))) + (copy-seq "abcabcabcabc") :start 1 :count 1) "abcbcabcabc") +(string= (remove-if-not #'(lambda (arg) (not (eql arg #\a))) + (copy-seq "abcabcabcabc") :start 1 :count 2) + "abcbcbcabc") +(string= (remove-if-not #'(lambda (arg) (not (eql arg #\a))) + (copy-seq "abcabcabcabc") :start 1 :end nil :count 2) + "abcbcbcabc") +(string= (remove-if-not #'(lambda (arg) (not (eql arg #\a))) + (copy-seq "abcabcabcabc") :start 1 :end 8) "abcbcbcabc") +(string= (remove-if-not #'(lambda (arg) (not (eql arg #\a))) + (copy-seq "abcabcabcabc") :start 1 :end 8 :count 1) + "abcbcabcabc") +(string= (remove-if-not #'(lambda (arg) (not (eql arg #\a))) + (copy-seq "abcabcabcabc") + :start 1 :end 8 :count 1 :from-end t) + "abcabcbcabc") +(string= (remove-if-not #'(lambda (arg) (not (eql arg #\a))) + (copy-seq "abcabcabcabc") + :start 1 :end 8 :count 0 :from-end t) + "abcabcabcabc") +(string= (remove-if-not #'(lambda (arg) (not (eql arg #\a))) + (copy-seq "abcabcabcabc") + :start 1 :end 8 :count -100 :from-end t) + "abcabcabcabc") +(string= (remove-if-not #'(lambda (arg) (not (eql arg #\a))) + (copy-seq "abcabcabcabc") :start 1 :end 1) + "abcabcabcabc") +(string= (remove-if-not #'(lambda (arg) (not (eql arg #\a))) + (copy-seq "abcabcabcabc") + :start 2 :end 2) "abcabcabcabc") +(string= (remove-if-not #'(lambda (arg) (not (eql arg #\a))) + (copy-seq "abcabcabcabc") + :start 12 :end 12) "abcabcabcabc") +(equal (remove-if-not (complement #'zerop) #*0101) #*11) +(equal (remove-if-not (complement #'zerop) #*01010101 :count 1) #*1010101) +(equal (remove-if-not (complement #'zerop) #*01010101 :count 1 :from-end t) + #*0101011) +(equal (remove-if-not (complement #'zerop) #*01010101 :start 1) #*01111) +(equal (remove-if-not (complement #'zerop) #*01010101 :start 1 :end nil) #*01111) +(equal (remove-if-not (complement #'zerop) #*01010101 :start 1 :end 6) #*011101) +(equal (remove-if-not (complement #'zerop) #*01010101 :start 1 :end 6 :count 1) + #*0110101) +(equal (remove-if-not (complement #'zerop) #*01010101 + :start 1 :end 6 :count 1 :from-end t) + #*0101101) +(equal (remove-if-not (complement #'oddp) #*01010101 + :start 1 :end 6 :count 1 :from-end t) + #*0101001) +(equal (remove-if-not (complement #'evenp) + #*01010101 :start 1 :end 6 :count 1 :from-end t) + #*0101101) +(equal (remove-if-not (complement #'plusp) #*01010101 + :start 1 :end 6 :count 1 :from-end t + :key #'(lambda (arg) (* arg 10))) + #*0101001) + + +(equal (delete 'a (list 'a 'b 'c 'a 'b 'c)) '(b c b c)) +(equal (delete 'b (list 'a 'b 'c 'a 'b 'c)) '(a c a c)) +(equal (delete 'c (list 'a 'b 'c 'a 'b 'c)) '(a b a b)) +(equal (delete 'a (list 'a 'a 'a)) '()) +(equal (delete 'z (list 'a 'b 'c)) '(a b c)) +(equal (delete 'a '()) '()) +(equal (delete 'a (list 'a 'b 'c 'a 'b 'c) :count 0) '(a b c a b c)) +(equal (delete 'a (list 'a 'b 'c 'a 'b 'c) :count 1) '(b c a b c)) +(equal (delete 'a (list 'a 'b 'c 'a 'b 'c) :count 1 :from-end t) '(a b c b c)) +(equal (delete 'a (list 'a 'b 'c 'a 'b 'c) :count 2) '(b c b c)) +(equal (delete 'a (list 'a 'b 'c 'a 'b 'c) :count 2 :from-end t) '(b c b c)) +(equal (delete 'a (list 'a 'b 'c 'a 'b 'c) :count 3) '(b c b c)) +(equal (delete 'a (list 'a 'b 'c 'a 'b 'c) :count 3 :from-end t) '(b c b c)) +(equal (delete 'a (list 'a 'b 'c 'a 'b 'c) :count 4) '(b c b c)) +(equal (delete 'a (list 'a 'b 'c 'a 'b 'c) :count 4 :from-end t) '(b c b c)) +(equal (delete 'a (list 'a 'b 'c 'a 'b 'c) :count -1) '(a b c a b c)) +(equal (delete 'a (list 'a 'b 'c 'a 'b 'c) :count -10) '(a b c a b c)) +(equal (delete 'a (list 'a 'b 'c 'a 'b 'c) :count -100) '(a b c a b c)) +(equal (delete 'a (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1) + '(a b c b c b c b c)) +(equal (delete 'a (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :count 1) + '(a b c b c a b c a b c)) +(equal (delete 'a (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :count 2) + '(a b c b c b c a b c)) +(equal (delete 'a (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :end nil :count 2) + '(a b c b c b c a b c)) +(equal (delete 'a (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :end 8) + '(a b c b c b c a b c)) +(equal (delete 'a (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :end 8 :count 1) + '(a b c b c a b c a b c)) +(equal (delete 'a (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :end 8 :count 1 :from-end t) + '(a b c a b c b c a b c)) +(equal (delete 'a (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :end 8 :count 0 :from-end t) + '(a b c a b c a b c a b c)) +(equal (delete 'a (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :end 8 :count -100 :from-end t) + '(a b c a b c a b c a b c)) +(equal (delete 'a (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :end 1) + '(a b c a b c a b c a b c)) +(equal (delete 'a (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 2 :end 2) + '(a b c a b c a b c a b c)) +(equal (delete 'a (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 12 :end 12) + '(a b c a b c a b c a b c)) +(equal (delete 'a (list '(a) '(b) '(c) '(a) '(b) '(c)) :key #'car) + '((b) (c) (b) (c))) +(equal (delete 'a (list '(a . b) '(b . c) '(c . a) + '(a . b) '(b . c) '(c . a)) + :key #'cdr) + '((a . b) (b . c) (a . b) (b . c))) +(equal (delete "love" (list '("Love") '("LOve") '("LOVe") '("LOVE")) :key #'car) + '(("Love") ("LOve") ("LOVe") ("LOVE"))) +(equal (delete "love" (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count -10) + '(("Love") ("LOve") ("LOVe") ("LOVE"))) +(equal (delete "love" (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test #'string-equal) + '()) +(equal (delete "love" (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test-not (complement #'string-equal)) + '()) +(equal (delete "love" (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test #'string-equal :count 1) + '(("LOve") ("LOVe") ("LOVE"))) +(equal (delete "love" (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test-not (complement #'string-equal) :count 1) + '(("LOve") ("LOVe") ("LOVE"))) +(equal (delete "love" (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test #'string-equal :count 1 :from-end t) + '(("Love") ("LOve") ("LOVe"))) +(equal (delete "love" (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test-not (complement #'string-equal) + :count 1 :from-end t) + '(("Love") ("LOve") ("LOVe"))) +(equal (delete "love" (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test #'string-equal :count 2 :from-end t) + '(("Love") ("LOve"))) +(equal (delete "love" (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test-not (complement #'string-equal) + :count 2 :from-end t) + '(("Love") ("LOve"))) +(equal (delete "love" (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test #'string-equal :start 1 :end 3) + '(("Love") ("LOVE"))) +(equal (delete "love" (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test-not (complement #'string-equal) :start 1 :end 3) + '(("Love") ("LOVE"))) +(equal (delete "love" (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test #'string-equal :count 1 :start 1 :end 3) + '(("Love") ("LOVe") ("LOVE"))) +(equal (delete "love" (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test-not (complement #'string-equal) + :count 1 :start 1 :end 3) + '(("Love") ("LOVe") ("LOVE"))) +(equal (delete "love" (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test #'string-equal :count 1 :from-end t + :start 1 :end 3) + '(("Love") ("LOve") ("LOVE"))) +(equal (delete "love" (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test-not (complement #'string-equal) + :count 1 :from-end t :start 1 :end 3) + '(("Love") ("LOve") ("LOVE"))) +(equal (delete "love" (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test #'string-equal :count 10 :from-end t + :start 1 :end 3) + '(("Love") ("LOVE"))) +(equal (delete "love" (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test-not (complement #'string-equal) + :count 10 :from-end t :start 1 :end 3) + '(("Love") ("LOVE"))) + + +(equalp (delete 'a (vector 'a 'b 'c 'a 'b 'c)) #(b c b c)) +(equalp (delete 'b (vector 'a 'b 'c 'a 'b 'c)) #(a c a c)) +(equalp (delete 'c (vector 'a 'b 'c 'a 'b 'c)) #(a b a b)) +(equalp (delete 'a (vector 'a 'a 'a)) #()) +(equalp (delete 'z (vector 'a 'b 'c)) #(a b c)) +(equalp (delete 'a #()) #()) +(equalp (delete 'a (vector 'a 'b 'c 'a 'b 'c) :count 0) #(a b c a b c)) +(equalp (delete 'a (vector 'a 'b 'c 'a 'b 'c) :count 1) #(b c a b c)) +(equalp (delete 'a (vector 'a 'b 'c 'a 'b 'c) :count 1 :from-end t) #(a b c b c)) +(equalp (delete 'a (vector 'a 'b 'c 'a 'b 'c) :count 2) #(b c b c)) +(equalp (delete 'a (vector 'a 'b 'c 'a 'b 'c) :count 2 :from-end t) #(b c b c)) +(equalp (delete 'a (vector 'a 'b 'c 'a 'b 'c) :count 3) #(b c b c)) +(equalp (delete 'a (vector 'a 'b 'c 'a 'b 'c) :count 3 :from-end t) #(b c b c)) +(equalp (delete 'a (vector 'a 'b 'c 'a 'b 'c) :count 4) #(b c b c)) +(equalp (delete 'a (vector 'a 'b 'c 'a 'b 'c) :count 4 :from-end t) #(b c b c)) +(equalp (delete 'a (vector 'a 'b 'c 'a 'b 'c) :count -1) #(a b c a b c)) +(equalp (delete 'a (vector 'a 'b 'c 'a 'b 'c) :count -10) #(a b c a b c)) +(equalp (delete 'a (vector 'a 'b 'c 'a 'b 'c) :count -100) #(a b c a b c)) +(equalp (delete 'a (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1) + #(a b c b c b c b c)) +(equalp (delete 'a (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :count 1) + #(a b c b c a b c a b c)) +(equalp (delete 'a (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :count 2) + #(a b c b c b c a b c)) +(equalp (delete 'a (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :end nil :count 2) + #(a b c b c b c a b c)) +(equalp (delete 'a (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :end 8) + #(a b c b c b c a b c)) +(equalp (delete 'a (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :end 8 :count 1) + #(a b c b c a b c a b c)) +(equalp (delete 'a (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :end 8 :count 1 :from-end t) + #(a b c a b c b c a b c)) +(equalp (delete 'a (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :end 8 :count 0 :from-end t) + #(a b c a b c a b c a b c)) +(equalp (delete 'a (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :end 8 :count -100 :from-end t) + #(a b c a b c a b c a b c)) +(equalp (delete 'a (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :end 1) + #(a b c a b c a b c a b c)) +(equalp (delete 'a (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 2 :end 2) + #(a b c a b c a b c a b c)) +(equalp (delete 'a (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 12 :end 12) + #(a b c a b c a b c a b c)) +(equalp (delete 'a (vector '(a) '(b) '(c) '(a) '(b) '(c)) :key #'car) + #((b) (c) (b) (c))) +(equalp (delete 'a (vector '(a . b) '(b . c) '(c . a) + '(a . b) '(b . c) '(c . a)) + :key #'cdr) + #((a . b) (b . c) (a . b) (b . c))) +(equalp (delete "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car) + #(("Love") ("LOve") ("LOVe") ("LOVE"))) +(equalp (delete "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count -10) + #(("Love") ("LOve") ("LOVe") ("LOVE"))) +(equalp (delete "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test #'string-equal) + #()) +(equalp (delete "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test-not (complement #'string-equal)) + #()) +(equalp (delete "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test #'string-equal :count 1) + #(("LOve") ("LOVe") ("LOVE"))) +(equalp (delete "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test-not (complement #'string-equal) :count 1) + #(("LOve") ("LOVe") ("LOVE"))) +(equalp (delete "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test #'string-equal :count 1 :from-end t) + #(("Love") ("LOve") ("LOVe"))) +(equalp (delete "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test-not (complement #'string-equal) + :count 1 :from-end t) + #(("Love") ("LOve") ("LOVe"))) +(equalp (delete "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test #'string-equal :count 2 :from-end t) + #(("Love") ("LOve"))) +(equalp (delete "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test-not (complement #'string-equal) + :count 2 :from-end t) + #(("Love") ("LOve"))) +(equalp (delete "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test #'string-equal :start 1 :end 3) + #(("Love") ("LOVE"))) +(equalp (delete "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test-not (complement #'string-equal) :start 1 :end 3) + #(("Love") ("LOVE"))) +(equalp (delete "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test #'string-equal :count 1 :start 1 :end 3) + #(("Love") ("LOVe") ("LOVE"))) +(equalp (delete "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test-not (complement #'string-equal) + :count 1 :start 1 :end 3) + #(("Love") ("LOVe") ("LOVE"))) +(equalp (delete "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test #'string-equal :count 1 :from-end t + :start 1 :end 3) + #(("Love") ("LOve") ("LOVE"))) +(equalp (delete "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test-not (complement #'string-equal) + :count 1 :from-end t :start 1 :end 3) + #(("Love") ("LOve") ("LOVE"))) +(equalp (delete "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test #'string-equal :count 10 :from-end t + :start 1 :end 3) + #(("Love") ("LOVE"))) +(equalp (delete "love" (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :test-not (complement #'string-equal) + :count 10 :from-end t :start 1 :end 3) + #(("Love") ("LOVE"))) + +(string= (delete #\a (copy-seq "abcabc")) "bcbc") +(string= (delete #\a (copy-seq "")) "") +(string= (delete #\a (copy-seq "xyz")) "xyz") +(string= (delete #\a (copy-seq "ABCABC")) "ABCABC") +(string= (delete #\a (copy-seq "ABCABC") :key #'char-downcase) "BCBC") +(string= (delete #\a (copy-seq "abcabc") :count 1) "bcabc") +(string= (delete #\a (copy-seq "abcabc") :count 1 :from-end t) "abcbc") +(string= (delete #\a (copy-seq "abcabc") :count 0) "abcabc") +(string= (delete #\a (copy-seq "abcabc") :count -10) "abcabc") +(string= (delete #\a (copy-seq "abcabc") :count 0) "abcabc") +(string= (delete #\a (copy-seq "abcabc")) "bcbc") +(string= (delete #\b (copy-seq "abcabc")) "acac") +(string= (delete #\c (copy-seq "abcabc")) "abab") +(string= (delete #\a (copy-seq "abcabc") :count 0) "abcabc") +(string= (delete #\a (copy-seq "abcabc") :count 1) "bcabc") +(string= (delete #\a (copy-seq "abcabc") :count 1 :from-end t) "abcbc") +(string= (delete #\a (copy-seq "abcabc") :count 2) "bcbc") +(string= (delete #\a (copy-seq "abcabc") :count 2 :from-end t) "bcbc") +(string= (delete #\a (copy-seq "abcabc") :count 3) "bcbc") +(string= (delete #\a (copy-seq "abcabc") :count 3 :from-end t) "bcbc") +(string= (delete #\a (copy-seq "abcabc") :count 4) "bcbc") +(string= (delete #\a (copy-seq "abcabc") :count 4 :from-end t) "bcbc") +(string= (delete #\a (copy-seq "abcabc") :count -1) "abcabc") +(string= (delete #\a (copy-seq "abcabc") :count -10) "abcabc") +(string= (delete #\a (copy-seq "abcabc") :count -100) "abcabc") +(string= (delete #\a (copy-seq "abcabcabcabc") :start 1) "abcbcbcbc") +(string= (delete #\a (copy-seq "abcabcabcabc") :start 1 :count 1) "abcbcabcabc") +(string= (delete #\a (copy-seq "abcabcabcabc") :start 1 :count 2) "abcbcbcabc") +(string= (delete #\a (copy-seq "abcabcabcabc") :start 1 :end nil :count 2) + "abcbcbcabc") +(string= (delete #\a (copy-seq "abcabcabcabc") :start 1 :end 8) "abcbcbcabc") +(string= (delete #\a (copy-seq "abcabcabcabc") :start 1 :end 8 :count 1) + "abcbcabcabc") +(string= (delete #\a (copy-seq "abcabcabcabc") + :start 1 :end 8 :count 1 :from-end t) + "abcabcbcabc") +(string= (delete #\a (copy-seq "abcabcabcabc") + :start 1 :end 8 :count 0 :from-end t) + "abcabcabcabc") +(string= (delete #\a (copy-seq "abcabcabcabc") + :start 1 :end 8 :count -100 :from-end t) + "abcabcabcabc") +(string= (delete #\a (copy-seq "abcabcabcabc") :start 1 :end 1) + "abcabcabcabc") +(string= (delete #\a (copy-seq "abcabcabcabc") :start 2 :end 2) "abcabcabcabc") +(string= (delete #\a (copy-seq "abcabcabcabc") :start 12 :end 12) "abcabcabcabc") +(equal (delete 0 #*0101) #*11) +(equal (delete 0 #*01010101 :count 1) #*1010101) +(equal (delete 0 #*01010101 :count 1 :from-end t) #*0101011) +(equal (delete 0 #*01010101 :start 1) #*01111) +(equal (delete 0 #*01010101 :start 1 :end nil) #*01111) +(equal (delete 0 #*01010101 :start 1 :end 6) #*011101) +(equal (delete 0 #*01010101 :start 1 :end 6 :count 1) #*0110101) +(equal (delete 0 #*01010101 :start 1 :end 6 :count 1 :from-end t) #*0101101) +(equal (delete 0 #*01010101 + :start 1 :end 6 :count 1 :from-end t + :test #'(lambda (a b) (declare (ignore a)) (oddp b))) + #*0101001) +(equal (delete 0 #*01010101 + :start 1 :end 6 :count 1 :from-end t + :test-not #'(lambda (a b) (declare (ignore a)) (evenp b))) + #*0101001) +(equal (delete 0 #*01010101 + :start 1 :end 6 :count 1 :from-end t + :test #'(lambda (a b) (declare (ignore a)) (evenp b))) + #*0101101) +(equal (delete 0 #*01010101 + :start 1 :end 6 :count 1 :from-end t + :test-not #'(lambda (a b) (declare (ignore a)) (oddp b))) + #*0101101) +(equal (delete 0 #*01010101 + :start 1 :end 6 :count 1 :from-end t + :key #'(lambda (arg) (* arg 10)) + :test #'(lambda (a b) (declare (ignore a)) (> b 1))) + #*0101001) + + +(equal (delete-if #'(lambda (arg) (eql arg 'a)) (list 'a 'b 'c 'a 'b 'c)) + '(b c b c)) +(equal (delete-if #'(lambda (arg) (eql arg 'b)) (list 'a 'b 'c 'a 'b 'c)) + '(a c a c)) +(equal (delete-if #'(lambda (arg) (eql arg 'c)) (list 'a 'b 'c 'a 'b 'c)) + '(a b a b)) +(equal (delete-if #'(lambda (arg) (eql arg 'a)) (list 'a 'a 'a)) '()) +(equal (delete-if #'(lambda (arg) (eql arg 'z)) (list 'a 'b 'c)) '(a b c)) +(equal (delete-if #'(lambda (arg) (eql arg 'a)) '()) '()) +(equal (delete-if #'(lambda (arg) (eql arg 'a)) (list 'a 'b 'c 'a 'b 'c) + :count 0) '(a b c a b c)) +(equal (delete-if #'(lambda (arg) (eql arg 'a)) (list 'a 'b 'c 'a 'b 'c) + :count 1) '(b c a b c)) +(equal (delete-if #'(lambda (arg) (eql arg 'a)) (list 'a 'b 'c 'a 'b 'c) + :count 1 :from-end t) '(a b c b c)) +(equal (delete-if #'(lambda (arg) (eql arg 'a)) (list 'a 'b 'c 'a 'b 'c) + :count 2) '(b c b c)) +(equal (delete-if #'(lambda (arg) (eql arg 'a)) (list 'a 'b 'c 'a 'b 'c) + :count 2 :from-end t) '(b c b c)) +(equal (delete-if #'(lambda (arg) (eql arg 'a)) (list 'a 'b 'c 'a 'b 'c) + :count 3) '(b c b c)) +(equal (delete-if #'(lambda (arg) (eql arg 'a)) (list 'a 'b 'c 'a 'b 'c) + :count 3 :from-end t) '(b c b c)) +(equal (delete-if #'(lambda (arg) (eql arg 'a)) (list 'a 'b 'c 'a 'b 'c) + :count 4) '(b c b c)) +(equal (delete-if #'(lambda (arg) (eql arg 'a)) (list 'a 'b 'c 'a 'b 'c) + :count 4 :from-end t) '(b c b c)) +(equal (delete-if #'(lambda (arg) (eql arg 'a)) (list 'a 'b 'c 'a 'b 'c) + :count -1) '(a b c a b c)) +(equal (delete-if #'(lambda (arg) (eql arg 'a)) (list 'a 'b 'c 'a 'b 'c) + :count -10) '(a b c a b c)) +(equal (delete-if #'(lambda (arg) (eql arg 'a)) (list 'a 'b 'c 'a 'b 'c) + :count -100) '(a b c a b c)) +(equal (delete-if #'(lambda (arg) (eql arg 'a)) + (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1) + '(a b c b c b c b c)) +(equal (delete-if #'(lambda (arg) (eql arg 'a)) + (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :count 1) + '(a b c b c a b c a b c)) +(equal (delete-if #'(lambda (arg) (eql arg 'a)) + (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :count 2) + '(a b c b c b c a b c)) +(equal (delete-if #'(lambda (arg) (eql arg 'a)) + (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :end nil :count 2) + '(a b c b c b c a b c)) +(equal (delete-if #'(lambda (arg) (eql arg 'a)) + (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :end 8) + '(a b c b c b c a b c)) +(equal (delete-if #'(lambda (arg) (eql arg 'a)) + (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :end 8 :count 1) + '(a b c b c a b c a b c)) +(equal (delete-if #'(lambda (arg) (eql arg 'a)) + (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :end 8 :count 1 :from-end t) + '(a b c a b c b c a b c)) +(equal (delete-if #'(lambda (arg) (eql arg 'a)) + (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :end 8 :count 0 :from-end t) + '(a b c a b c a b c a b c)) +(equal (delete-if #'(lambda (arg) (eql arg 'a)) + (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :end 8 :count -100 :from-end t) + '(a b c a b c a b c a b c)) +(equal (delete-if #'(lambda (arg) (eql arg 'a)) + (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :end 1) + '(a b c a b c a b c a b c)) +(equal (delete-if #'(lambda (arg) (eql arg 'a)) + (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 2 :end 2) + '(a b c a b c a b c a b c)) +(equal (delete-if #'(lambda (arg) (eql arg 'a)) + (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 12 :end 12) + '(a b c a b c a b c a b c)) +(equal (delete-if #'(lambda (arg) (eql arg 'a)) + (list '(a) '(b) '(c) '(a) '(b) '(c)) :key #'car) + '((b) (c) (b) (c))) +(equal (delete-if #'(lambda (arg) (eql arg 'a)) + (list '(a . b) '(b . c) '(c . a) + '(a . b) '(b . c) '(c . a)) + :key #'cdr) + '((a . b) (b . c) (a . b) (b . c))) +(equal (delete-if #'(lambda (arg) (eql arg "love")) + (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car) + '(("Love") ("LOve") ("LOVe") ("LOVE"))) +(equal (delete-if #'(lambda (arg) (eql arg "love")) + (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count -10) + '(("Love") ("LOve") ("LOVe") ("LOVE"))) +(equal (delete-if #'(lambda (arg) (string-equal arg "love")) + (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car) + '()) +(equal (delete-if #'(lambda (arg) (string-equal arg "love")) + (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count 1) + '(("LOve") ("LOVe") ("LOVE"))) +(equal (delete-if #'(lambda (arg) (string-equal arg "love")) + (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count 1 :from-end t) + '(("Love") ("LOve") ("LOVe"))) +(equal (delete-if #'(lambda (arg) (string-equal arg "love")) + (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count 2 :from-end t) + '(("Love") ("LOve"))) +(equal (delete-if #'(lambda (arg) (string-equal arg "love")) + (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :start 1 :end 3) + '(("Love") ("LOVE"))) +(equal (delete-if #'(lambda (arg) (string-equal arg "love")) + (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count 1 :start 1 :end 3) + '(("Love") ("LOVe") ("LOVE"))) +(equal (delete-if #'(lambda (arg) (string-equal arg "love")) + (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count 1 :from-end t + :start 1 :end 3) + '(("Love") ("LOve") ("LOVE"))) +(equal (delete-if #'(lambda (arg) (string-equal arg "love")) + (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count 10 :from-end t :start 1 :end 3) + '(("Love") ("LOVE"))) + + +(equalp (delete-if #'(lambda (arg) (eql arg 'a)) + (vector 'a 'b 'c 'a 'b 'c)) #(b c b c)) +(equalp (delete-if #'(lambda (arg) (eql arg 'b)) + (vector 'a 'b 'c 'a 'b 'c)) #(a c a c)) +(equalp (delete-if #'(lambda (arg) (eql arg 'c)) + (vector 'a 'b 'c 'a 'b 'c)) #(a b a b)) +(equalp (delete-if #'(lambda (arg) (eql arg 'a)) + (vector 'a 'a 'a)) #()) +(equalp (delete-if #'(lambda (arg) (eql arg 'z)) + (vector 'a 'b 'c)) #(a b c)) +(equalp (delete-if #'(lambda (arg) (eql arg 'a)) #()) #()) +(equalp (delete-if #'(lambda (arg) (eql arg 'a)) + (vector 'a 'b 'c 'a 'b 'c) :count 0) #(a b c a b c)) +(equalp (delete-if #'(lambda (arg) (eql arg 'a)) + (vector 'a 'b 'c 'a 'b 'c) :count 1) #(b c a b c)) +(equalp (delete-if #'(lambda (arg) (eql arg 'a)) + (vector 'a 'b 'c 'a 'b 'c) :count 1 :from-end t) #(a b c b c)) +(equalp (delete-if #'(lambda (arg) (eql arg 'a)) + (vector 'a 'b 'c 'a 'b 'c) :count 2) #(b c b c)) +(equalp (delete-if #'(lambda (arg) (eql arg 'a)) + (vector 'a 'b 'c 'a 'b 'c) :count 2 :from-end t) #(b c b c)) +(equalp (delete-if #'(lambda (arg) (eql arg 'a)) + (vector 'a 'b 'c 'a 'b 'c) :count 3) #(b c b c)) +(equalp (delete-if #'(lambda (arg) (eql arg 'a)) + (vector 'a 'b 'c 'a 'b 'c) :count 3 :from-end t) #(b c b c)) +(equalp (delete-if #'(lambda (arg) (eql arg 'a)) + (vector 'a 'b 'c 'a 'b 'c) :count 4) #(b c b c)) +(equalp (delete-if #'(lambda (arg) (eql arg 'a)) + (vector 'a 'b 'c 'a 'b 'c) :count 4 :from-end t) #(b c b c)) +(equalp (delete-if #'(lambda (arg) (eql arg 'a)) + (vector 'a 'b 'c 'a 'b 'c) :count -1) #(a b c a b c)) +(equalp (delete-if #'(lambda (arg) (eql arg 'a)) + (vector 'a 'b 'c 'a 'b 'c) :count -10) #(a b c a b c)) +(equalp (delete-if #'(lambda (arg) (eql arg 'a)) + (vector 'a 'b 'c 'a 'b 'c) :count -100) #(a b c a b c)) +(equalp (delete-if #'(lambda (arg) (eql arg 'a)) + (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1) + #(a b c b c b c b c)) +(equalp (delete-if #'(lambda (arg) (eql arg 'a)) + (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :count 1) + #(a b c b c a b c a b c)) +(equalp (delete-if #'(lambda (arg) (eql arg 'a)) + (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :count 2) + #(a b c b c b c a b c)) +(equalp (delete-if #'(lambda (arg) (eql arg 'a)) + (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :end nil :count 2) + #(a b c b c b c a b c)) +(equalp (delete-if #'(lambda (arg) (eql arg 'a)) + (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :end 8) + #(a b c b c b c a b c)) +(equalp (delete-if #'(lambda (arg) (eql arg 'a)) + (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :end 8 :count 1) + #(a b c b c a b c a b c)) +(equalp (delete-if #'(lambda (arg) (eql arg 'a)) + (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :end 8 :count 1 :from-end t) + #(a b c a b c b c a b c)) +(equalp (delete-if #'(lambda (arg) (eql arg 'a)) + (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :end 8 :count 0 :from-end t) + #(a b c a b c a b c a b c)) +(equalp (delete-if #'(lambda (arg) (eql arg 'a)) + (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :end 8 :count -100 :from-end t) + #(a b c a b c a b c a b c)) +(equalp (delete-if #'(lambda (arg) (eql arg 'a)) + (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :end 1) + #(a b c a b c a b c a b c)) +(equalp (delete-if #'(lambda (arg) (eql arg 'a)) + (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 2 :end 2) + #(a b c a b c a b c a b c)) +(equalp (delete-if #'(lambda (arg) (eql arg 'a)) + (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 12 :end 12) + #(a b c a b c a b c a b c)) +(equalp (delete-if #'(lambda (arg) (eql arg 'a)) + (vector '(a) '(b) '(c) '(a) '(b) '(c)) :key #'car) + #((b) (c) (b) (c))) +(equalp (delete-if #'(lambda (arg) (eql arg 'a)) + (vector '(a . b) '(b . c) '(c . a) + '(a . b) '(b . c) '(c . a)) + :key #'cdr) + #((a . b) (b . c) (a . b) (b . c))) +(equalp (delete-if #'(lambda (arg) (eql arg "love")) + (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car) + #(("Love") ("LOve") ("LOVe") ("LOVE"))) +(equalp (delete-if #'(lambda (arg) (eql arg "love")) + (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count -10) + #(("Love") ("LOve") ("LOVe") ("LOVE"))) +(equalp (delete-if #'(lambda (arg) (string-equal arg "love")) + (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car) + #()) +(equalp (delete-if #'(lambda (arg) (string-equal arg "love")) + (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car) + #()) +(equalp (delete-if #'(lambda (arg) (string-equal arg "love")) + (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count 1) + #(("LOve") ("LOVe") ("LOVE"))) +(equalp (delete-if #'(lambda (arg) (string-equal arg "love")) + (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count 1) + #(("LOve") ("LOVe") ("LOVE"))) +(equalp (delete-if #'(lambda (arg) (string-equal arg "love")) + (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count 1 :from-end t) + #(("Love") ("LOve") ("LOVe"))) +(equalp (delete-if #'(lambda (arg) (string-equal arg "love")) + (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count 1 :from-end t) + #(("Love") ("LOve") ("LOVe"))) +(equalp (delete-if #'(lambda (arg) (string-equal arg "love")) + (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count 2 :from-end t) + #(("Love") ("LOve"))) +(equalp (delete-if #'(lambda (arg) (string-equal arg "love")) + (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count 2 :from-end t) + #(("Love") ("LOve"))) +(equalp (delete-if #'(lambda (arg) (string-equal arg "love")) + (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :start 1 :end 3) + #(("Love") ("LOVE"))) +(equalp (delete-if #'(lambda (arg) (string-equal arg "love")) + (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count 1 :start 1 :end 3) + #(("Love") ("LOVe") ("LOVE"))) +(equalp (delete-if #'(lambda (arg) (string-equal arg "love")) + (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count 1 :from-end t + :start 1 :end 3) + #(("Love") ("LOve") ("LOVE"))) +(equalp (delete-if #'(lambda (arg) (string-equal arg "love")) + (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count 10 :from-end t + :start 1 :end 3) + #(("Love") ("LOVE"))) + +(string= (delete-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc")) + "bcbc") +(string= (delete-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "")) "") +(string= (delete-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "xyz")) + "xyz") +(string= (delete-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "ABCABC") + :key #'char-downcase) "BCBC") +(string= (delete-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc") + :count 1) "bcabc") +(string= (delete-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc") + :count 1 :from-end t) "abcbc") +(string= (delete-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc") + :count 0) "abcabc") +(string= (delete-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc") + :count -10) "abcabc") +(string= (delete-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc") + :count 0) "abcabc") +(string= (delete-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc")) + "bcbc") +(string= (delete-if #'(lambda (arg) (string-equal arg #\b)) (copy-seq "abcabc")) + "acac") +(string= (delete-if #'(lambda (arg) (string-equal arg #\c)) (copy-seq "abcabc")) + "abab") +(string= (delete-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc") + :count 0) "abcabc") +(string= (delete-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc") + :count 1) "bcabc") +(string= (delete-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc") + :count 1 :from-end t) "abcbc") +(string= (delete-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc") + :count 2) "bcbc") +(string= (delete-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc") + :count 2 :from-end t) "bcbc") +(string= (delete-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc") + :count 3) "bcbc") +(string= (delete-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc") + :count 3 :from-end t) "bcbc") +(string= (delete-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc") + :count 4) "bcbc") +(string= (delete-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc") + :count 4 :from-end t) "bcbc") +(string= (delete-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc") + :count -1) "abcabc") +(string= (delete-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc") + :count -10) "abcabc") +(string= (delete-if #'(lambda (arg) (string-equal arg #\a)) (copy-seq "abcabc") + :count -100) "abcabc") +(string= (delete-if #'(lambda (arg) (string-equal arg #\a)) + (copy-seq "abcabcabcabc") :start 1) "abcbcbcbc") +(string= (delete-if #'(lambda (arg) (string-equal arg #\a)) + (copy-seq "abcabcabcabc") :start 1 :count 1) "abcbcabcabc") +(string= (delete-if #'(lambda (arg) (eql arg #\a)) (copy-seq "abcabcabcabc") + :start 1 :count 2) + "abcbcbcabc") +(string= (delete-if #'(lambda (arg) (eql arg #\a)) (copy-seq "abcabcabcabc") + :start 1 :end nil :count 2) + "abcbcbcabc") +(string= (delete-if #'(lambda (arg) (eql arg #\a)) (copy-seq "abcabcabcabc") + :start 1 :end 8) "abcbcbcabc") +(string= (delete-if #'(lambda (arg) (eql arg #\a)) (copy-seq "abcabcabcabc") + :start 1 :end 8 :count 1) + "abcbcabcabc") +(string= (delete-if #'(lambda (arg) (eql arg #\a)) (copy-seq "abcabcabcabc") + :start 1 :end 8 :count 1 :from-end t) + "abcabcbcabc") +(string= (delete-if #'(lambda (arg) (eql arg #\a)) (copy-seq "abcabcabcabc") + :start 1 :end 8 :count 0 :from-end t) + "abcabcabcabc") +(string= (delete-if #'(lambda (arg) (eql arg #\a)) (copy-seq "abcabcabcabc") + :start 1 :end 8 :count -100 :from-end t) + "abcabcabcabc") +(string= (delete-if #'(lambda (arg) (eql arg #\a)) (copy-seq "abcabcabcabc") + :start 1 :end 1) + "abcabcabcabc") +(string= (delete-if #'(lambda (arg) (eql arg #\a)) (copy-seq "abcabcabcabc") + :start 2 :end 2) "abcabcabcabc") +(string= (delete-if #'(lambda (arg) (eql arg #\a)) (copy-seq "abcabcabcabc") + :start 12 :end 12) "abcabcabcabc") +(equal (delete-if #'zerop #*0101) #*11) +(equal (delete-if #'zerop #*01010101 :count 1) #*1010101) +(equal (delete-if #'zerop #*01010101 :count 1 :from-end t) #*0101011) +(equal (delete-if #'zerop #*01010101 :start 1) #*01111) +(equal (delete-if #'zerop #*01010101 :start 1 :end nil) #*01111) +(equal (delete-if #'zerop #*01010101 :start 1 :end 6) #*011101) +(equal (delete-if #'zerop #*01010101 :start 1 :end 6 :count 1) #*0110101) +(equal (delete-if #'zerop #*01010101 :start 1 :end 6 :count 1 :from-end t) + #*0101101) +(equal (delete-if #'oddp #*01010101 :start 1 :end 6 :count 1 :from-end t) + #*0101001) +(equal (delete-if #'evenp #*01010101 :start 1 :end 6 :count 1 :from-end t) + #*0101101) +(equal (delete-if #'plusp #*01010101 + :start 1 :end 6 :count 1 :from-end t + :key #'(lambda (arg) (* arg 10))) + #*0101001) + + +(equal (delete-if-not #'(lambda (arg) (not (eql arg 'a))) + (list 'a 'b 'c 'a 'b 'c)) + '(b c b c)) +(equal (delete-if-not #'(lambda (arg) (not (eql arg 'b))) + (list 'a 'b 'c 'a 'b 'c)) + '(a c a c)) +(equal (delete-if-not #'(lambda (arg) (not (eql arg 'c))) + (list 'a 'b 'c 'a 'b 'c)) + '(a b a b)) +(equal (delete-if-not #'(lambda (arg) (not (eql arg 'a))) + (list 'a 'a 'a)) '()) +(equal (delete-if-not #'(lambda (arg) (not (eql arg 'z))) + (list 'a 'b 'c)) '(a b c)) +(equal (delete-if-not #'(lambda (arg) (not (eql arg 'a))) '()) '()) +(equal (delete-if-not #'(lambda (arg) (not (eql arg 'a))) + (list 'a 'b 'c 'a 'b 'c) :count 0) '(a b c a b c)) +(equal (delete-if-not #'(lambda (arg) (not (eql arg 'a))) + (list 'a 'b 'c 'a 'b 'c) :count 1) '(b c a b c)) +(equal (delete-if-not #'(lambda (arg) (not (eql arg 'a))) + (list 'a 'b 'c 'a 'b 'c) :count 1 :from-end t) + '(a b c b c)) +(equal (delete-if-not #'(lambda (arg) (not (eql arg 'a))) + (list 'a 'b 'c 'a 'b 'c) :count 2) + '(b c b c)) +(equal (delete-if-not #'(lambda (arg) (not (eql arg 'a))) + (list 'a 'b 'c 'a 'b 'c) :count 2 :from-end t) + '(b c b c)) +(equal (delete-if-not #'(lambda (arg) (not (eql arg 'a))) + (list 'a 'b 'c 'a 'b 'c) :count 3) + '(b c b c)) +(equal (delete-if-not #'(lambda (arg) (not (eql arg 'a))) + (list 'a 'b 'c 'a 'b 'c) :count 3 :from-end t) + '(b c b c)) +(equal (delete-if-not #'(lambda (arg) (not (eql arg 'a))) + (list 'a 'b 'c 'a 'b 'c) :count 4) + '(b c b c)) +(equal (delete-if-not #'(lambda (arg) (not (eql arg 'a))) + (list 'a 'b 'c 'a 'b 'c) :count 4 :from-end t) + '(b c b c)) +(equal (delete-if-not #'(lambda (arg) (not (eql arg 'a))) + (list 'a 'b 'c 'a 'b 'c) :count -1) + '(a b c a b c)) +(equal (delete-if-not #'(lambda (arg) (not (eql arg 'a))) + (list 'a 'b 'c 'a 'b 'c) :count -10) + '(a b c a b c)) +(equal (delete-if-not #'(lambda (arg) (not (eql arg 'a))) + (list 'a 'b 'c 'a 'b 'c) :count -100) + '(a b c a b c)) +(equal (delete-if-not #'(lambda (arg) (not (eql arg 'a))) + (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1) + '(a b c b c b c b c)) +(equal (delete-if-not #'(lambda (arg) (not (eql arg 'a))) + (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :count 1) + '(a b c b c a b c a b c)) +(equal (delete-if-not #'(lambda (arg) (not (eql arg 'a))) + (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :count 2) + '(a b c b c b c a b c)) +(equal (delete-if-not #'(lambda (arg) (not (eql arg 'a))) + (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :end nil :count 2) + '(a b c b c b c a b c)) +(equal (delete-if-not #'(lambda (arg) (not (eql arg 'a))) + (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :end 8) + '(a b c b c b c a b c)) +(equal (delete-if-not #'(lambda (arg) (not (eql arg 'a))) + (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :end 8 :count 1) + '(a b c b c a b c a b c)) +(equal (delete-if-not #'(lambda (arg) (not (eql arg 'a))) + (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :end 8 :count 1 :from-end t) + '(a b c a b c b c a b c)) +(equal (delete-if-not #'(lambda (arg) (not (eql arg 'a))) + (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :end 8 :count 0 :from-end t) + '(a b c a b c a b c a b c)) +(equal (delete-if-not #'(lambda (arg) (not (eql arg 'a))) + (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :end 8 :count -100 :from-end t) + '(a b c a b c a b c a b c)) +(equal (delete-if-not #'(lambda (arg) (not (eql arg 'a))) + (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :end 1) + '(a b c a b c a b c a b c)) +(equal (delete-if-not #'(lambda (arg) (not (eql arg 'a))) + (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 2 :end 2) + '(a b c a b c a b c a b c)) +(equal (delete-if-not #'(lambda (arg) (not (eql arg 'a))) + (list 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 12 :end 12) + '(a b c a b c a b c a b c)) +(equal (delete-if-not #'(lambda (arg) (not (eql arg 'a))) + (list '(a) '(b) '(c) '(a) '(b) '(c)) :key #'car) + '((b) (c) (b) (c))) +(equal (delete-if-not #'(lambda (arg) (not (eql arg 'a))) + (list '(a . b) '(b . c) '(c . a) + '(a . b) '(b . c) '(c . a)) + :key #'cdr) + '((a . b) (b . c) (a . b) (b . c))) +(equal (delete-if-not #'(lambda (arg) (not (eql arg "love"))) + (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car) + '(("Love") ("LOve") ("LOVe") ("LOVE"))) +(equal (delete-if-not #'(lambda (arg) (not (eql arg "love"))) + (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count -10) + '(("Love") ("LOve") ("LOVe") ("LOVE"))) +(equal (delete-if-not #'(lambda (arg) (not (string-equal arg "love"))) + (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car) + '()) +(equal (delete-if-not #'(lambda (arg) (not (string-equal arg "love"))) + (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count 1) + '(("LOve") ("LOVe") ("LOVE"))) +(equal (delete-if-not #'(lambda (arg) (not (string-equal arg "love"))) + (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count 1 :from-end t) + '(("Love") ("LOve") ("LOVe"))) +(equal (delete-if-not #'(lambda (arg) (not (string-equal arg "love"))) + (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count 2 :from-end t) + '(("Love") ("LOve"))) +(equal (delete-if-not #'(lambda (arg) (not (string-equal arg "love"))) + (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :start 1 :end 3) + '(("Love") ("LOVE"))) +(equal (delete-if-not #'(lambda (arg) (not (string-equal arg "love"))) + (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count 1 :start 1 :end 3) + '(("Love") ("LOVe") ("LOVE"))) +(equal (delete-if-not #'(lambda (arg) (not (string-equal arg "love"))) + (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count 1 :from-end t + :start 1 :end 3) + '(("Love") ("LOve") ("LOVE"))) +(equal (delete-if-not #'(lambda (arg) (not (string-equal arg "love"))) + (list '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count 10 :from-end t :start 1 :end 3) + '(("Love") ("LOVE"))) + + +(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'a))) + (vector 'a 'b 'c 'a 'b 'c)) #(b c b c)) +(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'b))) + (vector 'a 'b 'c 'a 'b 'c)) #(a c a c)) +(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'c))) + (vector 'a 'b 'c 'a 'b 'c)) #(a b a b)) +(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'a))) + (vector 'a 'a 'a)) #()) +(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'z))) + (vector 'a 'b 'c)) #(a b c)) +(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'a))) #()) #()) +(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'a))) + (vector 'a 'b 'c 'a 'b 'c) :count 0) #(a b c a b c)) +(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'a))) + (vector 'a 'b 'c 'a 'b 'c) :count 1) #(b c a b c)) +(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'a))) + (vector 'a 'b 'c 'a 'b 'c) :count 1 :from-end t) #(a b c b c)) +(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'a))) + (vector 'a 'b 'c 'a 'b 'c) :count 2) #(b c b c)) +(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'a))) + (vector 'a 'b 'c 'a 'b 'c) :count 2 :from-end t) #(b c b c)) +(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'a))) + (vector 'a 'b 'c 'a 'b 'c) :count 3) #(b c b c)) +(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'a))) + (vector 'a 'b 'c 'a 'b 'c) :count 3 :from-end t) #(b c b c)) +(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'a))) + (vector 'a 'b 'c 'a 'b 'c) :count 4) #(b c b c)) +(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'a))) + (vector 'a 'b 'c 'a 'b 'c) :count 4 :from-end t) #(b c b c)) +(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'a))) + (vector 'a 'b 'c 'a 'b 'c) :count -1) #(a b c a b c)) +(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'a))) + (vector 'a 'b 'c 'a 'b 'c) :count -10) #(a b c a b c)) +(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'a))) + (vector 'a 'b 'c 'a 'b 'c) :count -100) #(a b c a b c)) +(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'a))) + (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1) + #(a b c b c b c b c)) +(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'a))) + (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :count 1) + #(a b c b c a b c a b c)) +(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'a))) + (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :count 2) + #(a b c b c b c a b c)) +(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'a))) + (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :end nil :count 2) + #(a b c b c b c a b c)) +(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'a))) + (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :end 8) + #(a b c b c b c a b c)) +(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'a))) + (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :end 8 :count 1) + #(a b c b c a b c a b c)) +(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'a))) + (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :end 8 :count 1 :from-end t) + #(a b c a b c b c a b c)) +(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'a))) + (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :end 8 :count 0 :from-end t) + #(a b c a b c a b c a b c)) +(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'a))) + (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 1 :end 8 :count -100 :from-end t) + #(a b c a b c a b c a b c)) +(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'a))) + (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 1 :end 1) + #(a b c a b c a b c a b c)) +(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'a))) + (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) :start 2 :end 2) + #(a b c a b c a b c a b c)) +(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'a))) + (vector 'a 'b 'c 'a 'b 'c 'a 'b 'c 'a 'b 'c) + :start 12 :end 12) + #(a b c a b c a b c a b c)) +(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'a))) + (vector '(a) '(b) '(c) '(a) '(b) '(c)) :key #'car) + #((b) (c) (b) (c))) +(equalp (delete-if-not #'(lambda (arg) (not (eql arg 'a))) + (vector '(a . b) '(b . c) '(c . a) + '(a . b) '(b . c) '(c . a)) + :key #'cdr) + #((a . b) (b . c) (a . b) (b . c))) +(equalp (delete-if-not #'(lambda (arg) (not (eql arg "love"))) + (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car) + #(("Love") ("LOve") ("LOVe") ("LOVE"))) +(equalp (delete-if-not #'(lambda (arg) (not (eql arg "love"))) + (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count -10) + #(("Love") ("LOve") ("LOVe") ("LOVE"))) +(equalp (delete-if-not #'(lambda (arg) (not (string-equal arg "love"))) + (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car) + #()) +(equalp (delete-if-not #'(lambda (arg) (not (string-equal arg "love"))) + (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car) + #()) +(equalp (delete-if-not #'(lambda (arg) (not (string-equal arg "love"))) + (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count 1) + #(("LOve") ("LOVe") ("LOVE"))) +(equalp (delete-if-not #'(lambda (arg) (not (string-equal arg "love"))) + (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count 1) + #(("LOve") ("LOVe") ("LOVE"))) +(equalp (delete-if-not #'(lambda (arg) (not (string-equal arg "love"))) + (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count 1 :from-end t) + #(("Love") ("LOve") ("LOVe"))) +(equalp (delete-if-not #'(lambda (arg) (not (string-equal arg "love"))) + (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count 1 :from-end t) + #(("Love") ("LOve") ("LOVe"))) +(equalp (delete-if-not #'(lambda (arg) (not (string-equal arg "love"))) + (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count 2 :from-end t) + #(("Love") ("LOve"))) +(equalp (delete-if-not #'(lambda (arg) (not (string-equal arg "love"))) + (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count 2 :from-end t) + #(("Love") ("LOve"))) +(equalp (delete-if-not #'(lambda (arg) (not (string-equal arg "love"))) + (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :start 1 :end 3) + #(("Love") ("LOVE"))) +(equalp (delete-if-not #'(lambda (arg) (not (string-equal arg "love"))) + (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count 1 :start 1 :end 3) + #(("Love") ("LOVe") ("LOVE"))) +(equalp (delete-if-not #'(lambda (arg) (not (string-equal arg "love"))) + (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count 1 :from-end t + :start 1 :end 3) + #(("Love") ("LOve") ("LOVE"))) +(equalp (delete-if-not #'(lambda (arg) (not (string-equal arg "love"))) + (vector '("Love") '("LOve") '("LOVe") '("LOVE")) + :key #'car :count 10 :from-end t + :start 1 :end 3) + #(("Love") ("LOVE"))) + +(string= (delete-if-not #'(lambda (arg) (not (string-equal arg #\a))) + (copy-seq "abcabc")) + "bcbc") +(string= (delete-if-not #'(lambda (arg) (not (string-equal arg #\a))) + (copy-seq "")) "") +(string= (delete-if-not #'(lambda (arg) (not (string-equal arg #\a))) + (copy-seq "xyz")) + "xyz") +(string= (delete-if-not #'(lambda (arg) (not (string-equal arg #\a))) + (copy-seq "ABCABC") + :key #'char-downcase) "BCBC") +(string= (delete-if-not #'(lambda (arg) (not (string-equal arg #\a))) + (copy-seq "abcabc") + :count 1) "bcabc") +(string= (delete-if-not #'(lambda (arg) (not (string-equal arg #\a))) + (copy-seq "abcabc") + :count 1 :from-end t) "abcbc") +(string= (delete-if-not #'(lambda (arg) (not (string-equal arg #\a))) + (copy-seq "abcabc") + :count 0) "abcabc") +(string= (delete-if-not #'(lambda (arg) (not (string-equal arg #\a))) + (copy-seq "abcabc") + :count -10) "abcabc") +(string= (delete-if-not #'(lambda (arg) (not (string-equal arg #\a))) + (copy-seq "abcabc") + :count 0) "abcabc") +(string= (delete-if-not #'(lambda (arg) (not (string-equal arg #\a))) + (copy-seq "abcabc")) + "bcbc") +(string= (delete-if-not #'(lambda (arg) (not (string-equal arg #\b))) + (copy-seq "abcabc")) + "acac") +(string= (delete-if-not #'(lambda (arg) (not (string-equal arg #\c))) + (copy-seq "abcabc")) + "abab") +(string= (delete-if-not #'(lambda (arg) (not (string-equal arg #\a))) + (copy-seq "abcabc") + :count 0) "abcabc") +(string= (delete-if-not #'(lambda (arg) (not (string-equal arg #\a))) + (copy-seq "abcabc") + :count 1) "bcabc") +(string= (delete-if-not #'(lambda (arg) (not (string-equal arg #\a))) + (copy-seq "abcabc") + :count 1 :from-end t) "abcbc") +(string= (delete-if-not #'(lambda (arg) (not (string-equal arg #\a))) + (copy-seq "abcabc") + :count 2) "bcbc") +(string= (delete-if-not #'(lambda (arg) (not (string-equal arg #\a))) + (copy-seq "abcabc") + :count 2 :from-end t) "bcbc") +(string= (delete-if-not #'(lambda (arg) (not (string-equal arg #\a))) + (copy-seq "abcabc") + :count 3) "bcbc") +(string= (delete-if-not #'(lambda (arg) (not (string-equal arg #\a))) + (copy-seq "abcabc") + :count 3 :from-end t) "bcbc") +(string= (delete-if-not #'(lambda (arg) (not (string-equal arg #\a))) + (copy-seq "abcabc") + :count 4) "bcbc") +(string= (delete-if-not #'(lambda (arg) (not (string-equal arg #\a))) + (copy-seq "abcabc") + :count 4 :from-end t) "bcbc") +(string= (delete-if-not #'(lambda (arg) (not (string-equal arg #\a))) + (copy-seq "abcabc") + :count -1) "abcabc") +(string= (delete-if-not #'(lambda (arg) (not (string-equal arg #\a))) + (copy-seq "abcabc") + :count -10) "abcabc") +(string= (delete-if-not #'(lambda (arg) (not (string-equal arg #\a))) + (copy-seq "abcabc") + :count -100) "abcabc") +(string= (delete-if-not #'(lambda (arg) (not (string-equal arg #\a))) + (copy-seq "abcabcabcabc") :start 1) "abcbcbcbc") +(string= (delete-if-not #'(lambda (arg) (not (string-equal arg #\a))) + (copy-seq "abcabcabcabc") :start 1 :count 1) "abcbcabcabc") +(string= (delete-if-not #'(lambda (arg) (not (eql arg #\a))) + (copy-seq "abcabcabcabc") :start 1 :count 2) + "abcbcbcabc") +(string= (delete-if-not #'(lambda (arg) (not (eql arg #\a))) + (copy-seq "abcabcabcabc") :start 1 :end nil :count 2) + "abcbcbcabc") +(string= (delete-if-not #'(lambda (arg) (not (eql arg #\a))) + (copy-seq "abcabcabcabc") :start 1 :end 8) "abcbcbcabc") +(string= (delete-if-not #'(lambda (arg) (not (eql arg #\a))) + (copy-seq "abcabcabcabc") :start 1 :end 8 :count 1) + "abcbcabcabc") +(string= (delete-if-not #'(lambda (arg) (not (eql arg #\a))) + (copy-seq "abcabcabcabc") + :start 1 :end 8 :count 1 :from-end t) + "abcabcbcabc") +(string= (delete-if-not #'(lambda (arg) (not (eql arg #\a))) + (copy-seq "abcabcabcabc") + :start 1 :end 8 :count 0 :from-end t) + "abcabcabcabc") +(string= (delete-if-not #'(lambda (arg) (not (eql arg #\a))) + (copy-seq "abcabcabcabc") + :start 1 :end 8 :count -100 :from-end t) + "abcabcabcabc") +(string= (delete-if-not #'(lambda (arg) (not (eql arg #\a))) + (copy-seq "abcabcabcabc") :start 1 :end 1) + "abcabcabcabc") +(string= (delete-if-not #'(lambda (arg) (not (eql arg #\a))) + (copy-seq "abcabcabcabc") + :start 2 :end 2) "abcabcabcabc") +(string= (delete-if-not #'(lambda (arg) (not (eql arg #\a))) + (copy-seq "abcabcabcabc") + :start 12 :end 12) "abcabcabcabc") +(equal (delete-if-not (complement #'zerop) #*0101) #*11) +(equal (delete-if-not (complement #'zerop) #*01010101 :count 1) #*1010101) +(equal (delete-if-not (complement #'zerop) #*01010101 :count 1 :from-end t) + #*0101011) +(equal (delete-if-not (complement #'zerop) #*01010101 :start 1) #*01111) +(equal (delete-if-not (complement #'zerop) #*01010101 :start 1 :end nil) #*01111) +(equal (delete-if-not (complement #'zerop) #*01010101 :start 1 :end 6) #*011101) +(equal (delete-if-not (complement #'zerop) #*01010101 :start 1 :end 6 :count 1) + #*0110101) +(equal (delete-if-not (complement #'zerop) #*01010101 + :start 1 :end 6 :count 1 :from-end t) + #*0101101) +(equal (delete-if-not (complement #'oddp) #*01010101 + :start 1 :end 6 :count 1 :from-end t) + #*0101001) +(equal (delete-if-not (complement #'evenp) + #*01010101 :start 1 :end 6 :count 1 :from-end t) + #*0101101) +(equal (delete-if-not (complement #'plusp) #*01010101 + :start 1 :end 6 :count 1 :from-end t + :key #'(lambda (arg) (* arg 10))) + #*0101001) + + +(equal (remove-duplicates "aBcDAbCd" :test #'char-equal :from-end t) "aBcD") +(equal (remove-duplicates '(a b c b d d e)) '(A C B D E)) +(equal (remove-duplicates '(a b c b d d e) :from-end t) '(A B C D E)) +(equal (remove-duplicates '((foo #\a) (bar #\%) (baz #\A)) + :test #'char-equal :key #'cadr) + '((BAR #\%) (BAZ #\A))) +(equal (remove-duplicates '((foo #\a) (bar #\%) (baz #\A)) + :test #'char-equal :key #'cadr :from-end t) + '((FOO #\a) (BAR #\%))) +(let* ((list0 (list 0 1 2 3 4 5 6)) + (list (delete-duplicates list0 :key #'oddp :start 1 :end 6))) + (equal list '(0 4 5 6))) + + +#-CLISP ;Bruno: The tests ignores ANSI CL "remove-duplicates returns a sequence + ; that may share with sequence or may be identical to sequence + ; if no elements need to be removed." +(let* ((list0 (list 0 1 2)) + (list (remove-duplicates list0))) + (and (not (eq list0 list)) + (equal list0 '(0 1 2)) + (equal list '(0 1 2)))) +(let* ((list0 (list 2 1 0 1 0 1 2)) + (list (remove-duplicates list0))) + (and (not (eq list0 list)) + (equal list0 '(2 1 0 1 0 1 2)) + (equal list '(0 1 2)))) +#-CLISP ;Bruno: The tests ignores ANSI CL "remove-duplicates returns a sequence + ; that may share with sequence or may be identical to sequence if no + ; elements need to be removed." +(let* ((vector0 (vector 0 1 2)) + (vector (remove-duplicates vector0))) + (and (not (eq vector0 vector)) + (equalp vector0 #(0 1 2)) + (equalp vector #(0 1 2)))) +(let* ((vector0 (vector 2 1 0 1 0 1 2)) + (vector (remove-duplicates vector0))) + (and (not (eq vector0 vector)) + (equalp vector0 #(2 1 0 1 0 1 2)) + (equalp vector #(0 1 2)))) + +(equal (remove-duplicates (list 0 1 2 2 3 3 3)) '(0 1 2 3)) +(equal (remove-duplicates (list 0 0 0 2 0 1 1 2 2 2 1 1 1 1 2)) '(0 1 2)) +(equal (remove-duplicates (list 'a 'a 'b 'c 'c)) '(a b c)) +(equal (remove-duplicates (list 0 1 2)) '(0 1 2)) +(equal (remove-duplicates (list 2 0 2 1 1 1 0 0 0 1 2)) '(0 1 2)) +(equal (remove-duplicates (list)) '()) +(equal (remove-duplicates (list '(x . 0) '(y . 1) '(z . 2) + '(a . 0) '(b . 1) '(c . 2)) :key #'cdr) + '((a . 0) (b . 1) (c . 2))) +(equal (remove-duplicates (list '(x . 0) '(y . 1) '(z . 2) + '(a . 0) '(b . 1) '(c . 2)) + :key #'cdr + :test #'(lambda (a b) (and (oddp a) (oddp b)))) + '((x . 0) (z . 2) (a . 0) (b . 1) (c . 2))) +(equal (remove-duplicates (list '(x . 0) '(y . 1) '(z . 2) + '(a . 0) '(b . 1) '(c . 2)) + :key #'cdr + :test-not #'(lambda (a b) + (not (and (oddp a) (oddp b))))) + '((x . 0) (z . 2) (a . 0) (b . 1) (c . 2))) +(equal (remove-duplicates (list '(x . 0) '(y . 1) '(z . 2) + '(a . 0) '(b . 1) '(c . 2)) + :key #'cdr + :test #'(lambda (a b) (and (evenp a) (evenp b)))) + '((y . 1) (b . 1) (c . 2))) +(equal (remove-duplicates (list '(x . 0) '(y . 1) '(z . 2) + '(a . 0) '(b . 1) '(c . 2)) + :key #'cdr + :test-not #'(lambda (a b) + (not (and (evenp a) (evenp b))))) + '((y . 1) (b . 1) (c . 2))) +(equal (remove-duplicates (list 0 1 2 0 1 2 0 1 2 0 1 2) :start 3 :end 9) + '(0 1 2 0 1 2 0 1 2)) +(equal (remove-duplicates (list '(0 . 0) '(1 . 1) '(2 . 2) + '(0 . 3) '(1 . 4) '(2 . 5) + '(0 . 6) '(1 . 7) '(2 . 8) + '(0 . 9) '(1 . 10) '(2 . 11))) + (list '(0 . 0) '(1 . 1) '(2 . 2) + '(0 . 3) '(1 . 4) '(2 . 5) + '(0 . 6) '(1 . 7) '(2 . 8) + '(0 . 9) '(1 . 10) '(2 . 11))) +(equal (remove-duplicates (list '(0 . 0) '(1 . 1) '(2 . 2) + '(0 . 3) '(1 . 4) '(2 . 5) + '(0 . 6) '(1 . 7) '(2 . 8) + '(0 . 9) '(1 . 10) '(2 . 11)) + :key #'car) + '((0 . 9) (1 . 10) (2 . 11))) +(equal (remove-duplicates (list '(0 . 0) '(1 . 1) '(2 . 2) + '(0 . 3) '(1 . 4) '(2 . 5) + '(0 . 6) '(1 . 7) '(2 . 8) + '(0 . 9) '(1 . 10) '(2 . 11)) + :key #'car :from-end t) + (list '(0 . 0) '(1 . 1) '(2 . 2))) +(equal (remove-duplicates (list '(0 . 0) '(1 . 1) '(2 . 2) + '(0 . 3) '(1 . 4) '(2 . 5) + '(0 . 6) '(1 . 7) '(2 . 8) + '(0 . 9) '(1 . 10) '(2 . 11)) + :start 3 :key #'car) + (list '(0 . 0) '(1 . 1) '(2 . 2) + '(0 . 9) '(1 . 10) '(2 . 11))) +(equal (remove-duplicates (list '(0 . 0) '(1 . 1) '(2 . 2) + '(0 . 3) '(1 . 4) '(2 . 5) + '(0 . 6) '(1 . 7) '(2 . 8) + '(0 . 9) '(1 . 10) '(2 . 11)) + :start 3 :key #'car :from-end t) + (list '(0 . 0) '(1 . 1) '(2 . 2) + '(0 . 3) '(1 . 4) '(2 . 5))) +(equal (remove-duplicates (list '(0 . 0) '(1 . 1) '(2 . 2) + '(0 . 3) '(1 . 4) '(2 . 5) + '(0 . 6) '(1 . 7) '(2 . 8) + '(0 . 9) '(1 . 10) '(2 . 11)) + :start 3 :end nil :key #'car) + (list '(0 . 0) '(1 . 1) '(2 . 2) + '(0 . 9) '(1 . 10) '(2 . 11))) +(equal (remove-duplicates (list '(0 . 0) '(1 . 1) '(2 . 2) + '(0 . 3) '(1 . 4) '(2 . 5) + '(0 . 6) '(1 . 7) '(2 . 8) + '(0 . 9) '(1 . 10) '(2 . 11)) + :start 3 :end 9 :key #'car) + '((0 . 0) (1 . 1) (2 . 2) + (0 . 6) (1 . 7) (2 . 8) + (0 . 9) (1 . 10) (2 . 11))) +(equal (remove-duplicates (list '(0 . 0) '(1 . 1) '(2 . 2) + '(0 . 3) '(1 . 4) '(2 . 5) + '(0 . 6) '(1 . 7) '(2 . 8) + '(0 . 9) '(1 . 10) '(2 . 11)) + :start 3 :end 9 :key #'car :from-end t) + (list '(0 . 0) '(1 . 1) '(2 . 2) + '(0 . 3) '(1 . 4) '(2 . 5) + '(0 . 9) '(1 . 10) '(2 . 11))) +(equal (remove-duplicates (list "Monday" "Tuesday" "Wednesday" "Thursday" + "Friday" "Saturday" "Sunday") + :key #'length) + (list "Tuesday" "Wednesday" "Saturday" "Sunday")) +(equal (remove-duplicates (list "Monday" "Tuesday" "Wednesday" "Thursday" + "Friday" "Saturday" "Sunday") + :key #'(lambda (arg) (char arg 0)) :test #'char=) + (list "Monday" "Wednesday" "Thursday" "Friday" "Sunday")) +(equal (remove-duplicates (list "Monday" "Tuesday" "Wednesday" "Thursday" + "Friday" "Saturday" "Sunday") + :key #'(lambda (arg) (char arg 0)) + :test-not (complement #'char=)) + (list "Monday" "Wednesday" "Thursday" "Friday" "Sunday")) +(equal (remove-duplicates (list #\a #\b #\c #\A #\B #\C) :key #'char-upcase) + '(#\A #\B #\C)) +(equal (remove-duplicates (list #\a #\b #\c #\A #\B #\C) + :key #'char-upcase :from-end t) + '(#\a #\b #\c)) +(equal (remove-duplicates (list #\a #\b #\c #\A #\B #\C) :test #'char=) + (list #\a #\b #\c #\A #\B #\C)) +(equal (remove-duplicates (list #\a #\b #\c #\A #\B #\C) + :test-not (complement #'char=)) + (list #\a #\b #\c #\A #\B #\C)) +(equal (remove-duplicates (list #\a #\b #\c #\A #\B #\C) :test #'char-equal) + (list #\A #\B #\C)) +(equal (remove-duplicates (list #\a #\b #\c #\A #\B #\C) + :test-not (complement #'char-equal)) + (list #\A #\B #\C)) +(equal (remove-duplicates (list #\a #\b #\c #\A #\B #\C) + :test #'char-equal :from-end t) + (list #\a #\b #\c)) +(equal (remove-duplicates (list #\a #\b #\c #\A #\B #\C) + :test-not (complement #'char-equal) :from-end t) + (list #\a #\b #\c)) +(equal (remove-duplicates (list #\a #\1 #\b #\1 #\2 #\c #\0 #\A #\0 #\B #\C #\9) + :key #'alpha-char-p) + (list #\C #\9)) +(equal (remove-duplicates (list #\a #\1 #\b #\1 #\2 #\c #\0 #\A #\0 #\B #\C #\9) + :key #'alphanumericp) + (list #\9)) +(equal (remove-duplicates (list '(#\A . 0) '(#\b . 1) '(#\C . 2) + '(#\a . 3) '(#\B . 4) '(#\c . 5) + '(#\A . 6) '(#\b . 7) '(#\C . 8) + '(#\a . 9) '(#\B . 10) '(#\c . 11))) + (list '(#\A . 0) '(#\b . 1) '(#\C . 2) + '(#\a . 3) '(#\B . 4) '(#\c . 5) + '(#\A . 6) '(#\b . 7) '(#\C . 8) + '(#\a . 9) '(#\B . 10) '(#\c . 11))) +(equal (remove-duplicates (list '(#\A . 0) '(#\b . 1) '(#\C . 2) + '(#\a . 3) '(#\B . 4) '(#\c . 5) + '(#\A . 6) '(#\b . 7) '(#\C . 8) + '(#\a . 9) '(#\B . 10) '(#\c . 11)) + :key #'car) + (list '(#\A . 6) '(#\b . 7) '(#\C . 8) + '(#\a . 9) '(#\B . 10) '(#\c . 11))) +(equal (remove-duplicates (list '(#\A . 0) '(#\b . 1) '(#\C . 2) + '(#\a . 3) '(#\B . 4) '(#\c . 5) + '(#\A . 6) '(#\b . 7) '(#\C . 8) + '(#\a . 9) '(#\B . 10) '(#\c . 11)) + :key #'car :start 3 :end 9) + (list '(#\A . 0) '(#\b . 1) '(#\C . 2) + '(#\a . 3) '(#\B . 4) '(#\c . 5) + '(#\A . 6) '(#\b . 7) '(#\C . 8) + '(#\a . 9) '(#\B . 10) '(#\c . 11))) +(equal (remove-duplicates (list '(#\A . 0) '(#\b . 1) '(#\C . 2) + '(#\a . 3) '(#\B . 4) '(#\c . 5) + '(#\A . 6) '(#\b . 7) '(#\C . 8) + '(#\a . 9) '(#\B . 10) '(#\c . 11)) + :key #'car :start 3 :end 9 :test #'char-equal) + (list '(#\A . 0) '(#\b . 1) '(#\C . 2) + '(#\A . 6) '(#\b . 7) '(#\C . 8) + '(#\a . 9) '(#\B . 10) '(#\c . 11))) +(equal (remove-duplicates (list '(#\A . 0) '(#\b . 1) '(#\C . 2) + '(#\a . 3) '(#\B . 4) '(#\c . 5) + '(#\A . 6) '(#\b . 7) '(#\C . 8) + '(#\a . 9) '(#\B . 10) '(#\c . 11)) + :key #'car :start 3 :end 9 + :test-not (complement #'char-equal)) + (list '(#\A . 0) '(#\b . 1) '(#\C . 2) + '(#\A . 6) '(#\b . 7) '(#\C . 8) + '(#\a . 9) '(#\B . 10) '(#\c . 11))) +(equal (remove-duplicates (list '(#\A . 0) '(#\b . 1) '(#\C . 2) + '(#\a . 3) '(#\B . 4) '(#\c . 5) + '(#\A . 6) '(#\b . 7) '(#\C . 8) + '(#\a . 9) '(#\B . 10) '(#\c . 11)) + :key #'car :start 3 :end 9 :test #'char-equal + :from-end t) + (list '(#\A . 0) '(#\b . 1) '(#\C . 2) + '(#\a . 3) '(#\B . 4) '(#\c . 5) + '(#\a . 9) '(#\B . 10) '(#\c . 11))) +(equal (remove-duplicates (list '(#\A . 0) '(#\b . 1) '(#\C . 2) + '(#\a . 3) '(#\B . 4) '(#\c . 5) + '(#\A . 6) '(#\b . 7) '(#\C . 8) + '(#\a . 9) '(#\B . 10) '(#\c . 11)) + :key #'car :start 3 :end 9 + :test-not (complement #'char-equal) :from-end t) + (list '(#\A . 0) '(#\b . 1) '(#\C . 2) + '(#\a . 3) '(#\B . 4) '(#\c . 5) + '(#\a . 9) '(#\B . 10) '(#\c . 11))) +(equal (remove-duplicates (list '(#\A . 0) '(#\b . 1) '(#\C . 2) + '(#\a . 3) '(#\B . 4) '(#\c . 5) + '(#\A . 6) '(#\b . 7) '(#\C . 8) + '(#\a . 9) '(#\B . 10) '(#\c . 11)) + :key #'car :start 3) + (list '(#\A . 0) '(#\b . 1) '(#\C . 2) + '(#\A . 6) '(#\b . 7) '(#\C . 8) + '(#\a . 9) '(#\B . 10) '(#\c . 11))) +(equal (remove-duplicates (list '(#\A . 0) '(#\b . 1) '(#\C . 2) + '(#\a . 3) '(#\B . 4) '(#\c . 5) + '(#\A . 6) '(#\b . 7) '(#\C . 8) + '(#\a . 9) '(#\B . 10) '(#\c . 11)) + :key #'car :start 3 :end nil) + (list '(#\A . 0) '(#\b . 1) '(#\C . 2) + '(#\A . 6) '(#\b . 7) '(#\C . 8) + '(#\a . 9) '(#\B . 10) '(#\c . 11))) +(equal (remove-duplicates (list '(#\A . 0) '(#\b . 1) '(#\C . 2) + '(#\a . 3) '(#\B . 4) '(#\c . 5) + '(#\A . 6) '(#\b . 7) '(#\C . 8) + '(#\a . 9) '(#\B . 10) '(#\c . 11)) + :key #'car :start 3 :from-end t) + (list '(#\A . 0) '(#\b . 1) '(#\C . 2) + '(#\a . 3) '(#\B . 4) '(#\c . 5) + '(#\A . 6) '(#\b . 7) '(#\C . 8))) +(equal (remove-duplicates (list '(#\A . 0) '(#\b . 1) '(#\C . 2) + '(#\a . 3) '(#\B . 4) '(#\c . 5) + '(#\A . 6) '(#\b . 7) '(#\C . 8) + '(#\a . 9) '(#\B . 10) '(#\c . 11)) + :key #'car :end 9) + (list '(#\a . 3) '(#\B . 4) '(#\c . 5) + '(#\A . 6) '(#\b . 7) '(#\C . 8) + '(#\a . 9) '(#\B . 10) '(#\c . 11))) +(equal (remove-duplicates (list '(#\A . 0) '(#\b . 1) '(#\C . 2) + '(#\a . 3) '(#\B . 4) '(#\c . 5) + '(#\A . 6) '(#\b . 7) '(#\C . 8) + '(#\a . 9) '(#\B . 10) '(#\c . 11)) + :key #'car :end 9 :from-end t) + (list '(#\A . 0) '(#\b . 1) '(#\C . 2) + '(#\a . 3) '(#\B . 4) '(#\c . 5) + '(#\a . 9) '(#\B . 10) '(#\c . 11))) +(equal (remove-duplicates (list '(#\A . 0) '(#\b . 1) '(#\C . 2) + '(#\a . 3) '(#\B . 4) '(#\c . 5) + '(#\A . 6) '(#\b . 7) '(#\C . 8) + '(#\a . 9) '(#\B . 10) '(#\c . 11)) + :key #'car :start 0 :end 12 :test #'char-equal) + (list '(#\a . 9) '(#\B . 10) '(#\c . 11))) +(equal (remove-duplicates (list '(#\A . 0) '(#\b . 1) '(#\C . 2) + '(#\a . 3) '(#\B . 4) '(#\c . 5) + '(#\A . 6) '(#\b . 7) '(#\C . 8) + '(#\a . 9) '(#\B . 10) '(#\c . 11)) + :key #'car :start 0 :end 12 + :test-not (complement #'char-equal)) + (list '(#\a . 9) '(#\B . 10) '(#\c . 11))) +(equal (remove-duplicates (list '(#\A . 0) '(#\b . 1) '(#\C . 2) + '(#\a . 3) '(#\B . 4) '(#\c . 5) + '(#\A . 6) '(#\b . 7) '(#\C . 8) + '(#\a . 9) '(#\B . 10) '(#\c . 11)) + :key #'car :start 0 :end 12 :test #'char-equal + :from-end t) + '((#\A . 0) (#\b . 1) (#\C . 2))) +(equal (remove-duplicates (list '(#\A . 0) '(#\b . 1) '(#\C . 2) + '(#\a . 3) '(#\B . 4) '(#\c . 5) + '(#\A . 6) '(#\b . 7) '(#\C . 8) + '(#\a . 9) '(#\B . 10) '(#\c . 11)) + :key #'car :start 0 :end 12 + :test-not (complement #'char-equal) :from-end t) + '((#\A . 0) (#\b . 1) (#\C . 2))) + + +(equalp (remove-duplicates (vector 0 1 2 2 3 3 3)) #(0 1 2 3)) +(equalp (remove-duplicates (vector 0 0 0 2 0 1 1 2 2 2 1 1 1 1 2)) #(0 1 2)) +(equalp (remove-duplicates (vector 'a 'a 'b 'c 'c)) #(a b c)) +(equalp (remove-duplicates (vector 0 1 2)) #(0 1 2)) +(equalp (remove-duplicates (vector 2 0 2 1 1 1 0 0 0 1 2)) #(0 1 2)) +(equalp (remove-duplicates (vector)) #()) +(equalp (remove-duplicates (vector '(x . 0) '(y . 1) '(z . 2) + '(a . 0) '(b . 1) '(c . 2)) :key #'cdr) + #((a . 0) (b . 1) (c . 2))) +(equalp (remove-duplicates (vector '(x . 0) '(y . 1) '(z . 2) + '(a . 0) '(b . 1) '(c . 2)) + :key #'cdr + :test #'(lambda (a b) (and (oddp a) (oddp b)))) + #((x . 0) (z . 2) (a . 0) (b . 1) (c . 2))) +(equalp (remove-duplicates (vector '(x . 0) '(y . 1) '(z . 2) + '(a . 0) '(b . 1) '(c . 2)) + :key #'cdr + :test-not #'(lambda (a b) + (not (and (oddp a) (oddp b))))) + #((x . 0) (z . 2) (a . 0) (b . 1) (c . 2))) +(equalp (remove-duplicates (vector '(x . 0) '(y . 1) '(z . 2) + '(a . 0) '(b . 1) '(c . 2)) + :key #'cdr + :test #'(lambda (a b) (and (evenp a) (evenp b)))) + #((y . 1) (b . 1) (c . 2))) +(equalp (remove-duplicates (vector '(x . 0) '(y . 1) '(z . 2) + '(a . 0) '(b . 1) '(c . 2)) + :key #'cdr + :test-not #'(lambda (a b) + (not (and (evenp a) (evenp b))))) + #((y . 1) (b . 1) (c . 2))) +(equalp (remove-duplicates (vector 0 1 2 0 1 2 0 1 2 0 1 2) :start 3 :end 9) + #(0 1 2 0 1 2 0 1 2)) +(equalp (remove-duplicates (vector '(0 . 0) '(1 . 1) '(2 . 2) + '(0 . 3) '(1 . 4) '(2 . 5) + '(0 . 6) '(1 . 7) '(2 . 8) + '(0 . 9) '(1 . 10) '(2 . 11))) + (vector '(0 . 0) '(1 . 1) '(2 . 2) + '(0 . 3) '(1 . 4) '(2 . 5) + '(0 . 6) '(1 . 7) '(2 . 8) + '(0 . 9) '(1 . 10) '(2 . 11))) +(equalp (remove-duplicates (vector '(0 . 0) '(1 . 1) '(2 . 2) + '(0 . 3) '(1 . 4) '(2 . 5) + '(0 . 6) '(1 . 7) '(2 . 8) + '(0 . 9) '(1 . 10) '(2 . 11)) + :key #'car) + #((0 . 9) (1 . 10) (2 . 11))) +(equalp (remove-duplicates (vector '(0 . 0) '(1 . 1) '(2 . 2) + '(0 . 3) '(1 . 4) '(2 . 5) + '(0 . 6) '(1 . 7) '(2 . 8) + '(0 . 9) '(1 . 10) '(2 . 11)) + :key #'car :from-end t) + (vector '(0 . 0) '(1 . 1) '(2 . 2))) +(equalp (remove-duplicates (vector '(0 . 0) '(1 . 1) '(2 . 2) + '(0 . 3) '(1 . 4) '(2 . 5) + '(0 . 6) '(1 . 7) '(2 . 8) + '(0 . 9) '(1 . 10) '(2 . 11)) + :start 3 :key #'car) + (vector '(0 . 0) '(1 . 1) '(2 . 2) + '(0 . 9) '(1 . 10) '(2 . 11))) +(equalp (remove-duplicates (vector '(0 . 0) '(1 . 1) '(2 . 2) + '(0 . 3) '(1 . 4) '(2 . 5) + '(0 . 6) '(1 . 7) '(2 . 8) + '(0 . 9) '(1 . 10) '(2 . 11)) + :start 3 :key #'car :from-end t) + (vector '(0 . 0) '(1 . 1) '(2 . 2) + '(0 . 3) '(1 . 4) '(2 . 5))) +(equalp (remove-duplicates (vector '(0 . 0) '(1 . 1) '(2 . 2) + '(0 . 3) '(1 . 4) '(2 . 5) + '(0 . 6) '(1 . 7) '(2 . 8) + '(0 . 9) '(1 . 10) '(2 . 11)) + :start 3 :end nil :key #'car) + (vector '(0 . 0) '(1 . 1) '(2 . 2) + '(0 . 9) '(1 . 10) '(2 . 11))) +(equalp (remove-duplicates (vector '(0 . 0) '(1 . 1) '(2 . 2) + '(0 . 3) '(1 . 4) '(2 . 5) + '(0 . 6) '(1 . 7) '(2 . 8) + '(0 . 9) '(1 . 10) '(2 . 11)) + :start 3 :end 9 :key #'car) + #((0 . 0) (1 . 1) (2 . 2) + (0 . 6) (1 . 7) (2 . 8) + (0 . 9) (1 . 10) (2 . 11))) +(equalp (remove-duplicates (vector '(0 . 0) '(1 . 1) '(2 . 2) + '(0 . 3) '(1 . 4) '(2 . 5) + '(0 . 6) '(1 . 7) '(2 . 8) + '(0 . 9) '(1 . 10) '(2 . 11)) + :start 3 :end 9 :key #'car :from-end t) + (vector '(0 . 0) '(1 . 1) '(2 . 2) + '(0 . 3) '(1 . 4) '(2 . 5) + '(0 . 9) '(1 . 10) '(2 . 11))) +(equalp (remove-duplicates (vector "Monday" "Tuesday" "Wednesday" "Thursday" + "Friday" "Saturday" "Sunday") + :key #'length) + (vector "Tuesday" "Wednesday" "Saturday" "Sunday")) +(equalp (remove-duplicates (vector "Monday" "Tuesday" "Wednesday" "Thursday" + "Friday" "Saturday" "Sunday") + :key #'(lambda (arg) (char arg 0)) :test #'char=) + (vector "Monday" "Wednesday" "Thursday" "Friday" "Sunday")) +(equalp (remove-duplicates (vector "Monday" "Tuesday" "Wednesday" "Thursday" + "Friday" "Saturday" "Sunday") + :key #'(lambda (arg) (char arg 0)) + :test-not (complement #'char=)) + (vector "Monday" "Wednesday" "Thursday" "Friday" "Sunday")) +(equalp (remove-duplicates (vector #\a #\b #\c #\A #\B #\C) :key #'char-upcase) + #(#\A #\B #\C)) +(equalp (remove-duplicates (vector #\a #\b #\c #\A #\B #\C) + :key #'char-upcase :from-end t) + #(#\a #\b #\c)) +(equalp (remove-duplicates (vector #\a #\b #\c #\A #\B #\C) :test #'char=) + (vector #\a #\b #\c #\A #\B #\C)) +(equalp (remove-duplicates (vector #\a #\b #\c #\A #\B #\C) + :test-not (complement #'char=)) + (vector #\a #\b #\c #\A #\B #\C)) +(equalp (remove-duplicates (vector #\a #\b #\c #\A #\B #\C) :test #'char-equal) + (vector #\A #\B #\C)) +(equalp (remove-duplicates (vector #\a #\b #\c #\A #\B #\C) + :test-not (complement #'char-equal)) + (vector #\A #\B #\C)) +(equalp (remove-duplicates (vector #\a #\b #\c #\A #\B #\C) + :test #'char-equal :from-end t) + (vector #\a #\b #\c)) +(equalp (remove-duplicates (vector #\a #\b #\c #\A #\B #\C) + :test-not (complement #'char-equal) :from-end t) + (vector #\a #\b #\c)) + +(equalp (remove-duplicates + (vector #\a #\1 #\b #\1 #\2 #\c #\0 #\A #\0 #\B #\C #\9) + :key #'alpha-char-p) + (vector #\C #\9)) +(equalp (remove-duplicates + (vector #\a #\1 #\b #\1 #\2 #\c #\0 #\A #\0 #\B #\C #\9) + :key #'alphanumericp) + (vector #\9)) +(equalp (remove-duplicates (vector '(#\A . 0) '(#\b . 1) '(#\C . 2) + '(#\a . 3) '(#\B . 4) '(#\c . 5) + '(#\A . 6) '(#\b . 7) '(#\C . 8) + '(#\a . 9) '(#\B . 10) '(#\c . 11))) + (vector '(#\A . 0) '(#\b . 1) '(#\C . 2) + '(#\a . 3) '(#\B . 4) '(#\c . 5) + '(#\A . 6) '(#\b . 7) '(#\C . 8) + '(#\a . 9) '(#\B . 10) '(#\c . 11))) +(equalp (remove-duplicates (vector '(#\A . 0) '(#\b . 1) '(#\C . 2) + '(#\a . 3) '(#\B . 4) '(#\c . 5) + '(#\A . 6) '(#\b . 7) '(#\C . 8) + '(#\a . 9) '(#\B . 10) '(#\c . 11)) + :key #'car) + (vector '(#\A . 6) '(#\b . 7) '(#\C . 8) + '(#\a . 9) '(#\B . 10) '(#\c . 11))) +(equalp (remove-duplicates (vector '(#\A . 0) '(#\b . 1) '(#\C . 2) + '(#\a . 3) '(#\B . 4) '(#\c . 5) + '(#\A . 6) '(#\b . 7) '(#\C . 8) + '(#\a . 9) '(#\B . 10) '(#\c . 11)) + :key #'car :start 3 :end 9) + (vector '(#\A . 0) '(#\b . 1) '(#\C . 2) + '(#\a . 3) '(#\B . 4) '(#\c . 5) + '(#\A . 6) '(#\b . 7) '(#\C . 8) + '(#\a . 9) '(#\B . 10) '(#\c . 11))) +(equalp (remove-duplicates (vector '(#\A . 0) '(#\b . 1) '(#\C . 2) + '(#\a . 3) '(#\B . 4) '(#\c . 5) + '(#\A . 6) '(#\b . 7) '(#\C . 8) + '(#\a . 9) '(#\B . 10) '(#\c . 11)) + :key #'car :start 3 :end 9 :test #'char-equal) + (vector '(#\A . 0) '(#\b . 1) '(#\C . 2) + '(#\A . 6) '(#\b . 7) '(#\C . 8) + '(#\a . 9) '(#\B . 10) '(#\c . 11))) +(equalp (remove-duplicates (vector '(#\A . 0) '(#\b . 1) '(#\C . 2) + '(#\a . 3) '(#\B . 4) '(#\c . 5) + '(#\A . 6) '(#\b . 7) '(#\C . 8) + '(#\a . 9) '(#\B . 10) '(#\c . 11)) + :key #'car :start 3 :end 9 + :test-not (complement #'char-equal)) + (vector '(#\A . 0) '(#\b . 1) '(#\C . 2) + '(#\A . 6) '(#\b . 7) '(#\C . 8) + '(#\a . 9) '(#\B . 10) '(#\c . 11))) +(equalp (remove-duplicates (vector '(#\A . 0) '(#\b . 1) '(#\C . 2) + '(#\a . 3) '(#\B . 4) '(#\c . 5) + '(#\A . 6) '(#\b . 7) '(#\C . 8) + '(#\a . 9) '(#\B . 10) '(#\c . 11)) + :key #'car :start 3 :end 9 :test #'char-equal + :from-end t) + (vector '(#\A . 0) '(#\b . 1) '(#\C . 2) + '(#\a . 3) '(#\B . 4) '(#\c . 5) + '(#\a . 9) '(#\B . 10) '(#\c . 11))) +(equalp (remove-duplicates (vector '(#\A . 0) '(#\b . 1) '(#\C . 2) + '(#\a . 3) '(#\B . 4) '(#\c . 5) + '(#\A . 6) '(#\b . 7) '(#\C . 8) + '(#\a . 9) '(#\B . 10) '(#\c . 11)) + :key #'car :start 3 :end 9 + :test-not (complement #'char-equal) + :from-end t) + (vector '(#\A . 0) '(#\b . 1) '(#\C . 2) + '(#\a . 3) '(#\B . 4) '(#\c . 5) + '(#\a . 9) '(#\B . 10) '(#\c . 11))) +(equalp (remove-duplicates (vector '(#\A . 0) '(#\b . 1) '(#\C . 2) + '(#\a . 3) '(#\B . 4) '(#\c . 5) + '(#\A . 6) '(#\b . 7) '(#\C . 8) + '(#\a . 9) '(#\B . 10) '(#\c . 11)) + :key #'car :start 3) + (vector '(#\A . 0) '(#\b . 1) '(#\C . 2) + '(#\A . 6) '(#\b . 7) '(#\C . 8) + '(#\a . 9) '(#\B . 10) '(#\c . 11))) +(equalp (remove-duplicates (vector '(#\A . 0) '(#\b . 1) '(#\C . 2) + '(#\a . 3) '(#\B . 4) '(#\c . 5) + '(#\A . 6) '(#\b . 7) '(#\C . 8) + '(#\a . 9) '(#\B . 10) '(#\c . 11)) + :key #'car :start 3 :end nil) + (vector '(#\A . 0) '(#\b . 1) '(#\C . 2) + '(#\A . 6) '(#\b . 7) '(#\C . 8) + '(#\a . 9) '(#\B . 10) '(#\c . 11))) +(equalp (remove-duplicates (vector '(#\A . 0) '(#\b . 1) '(#\C . 2) + '(#\a . 3) '(#\B . 4) '(#\c . 5) + '(#\A . 6) '(#\b . 7) '(#\C . 8) + '(#\a . 9) '(#\B . 10) '(#\c . 11)) + :key #'car :start 3 :from-end t) + (vector '(#\A . 0) '(#\b . 1) '(#\C . 2) + '(#\a . 3) '(#\B . 4) '(#\c . 5) + '(#\A . 6) '(#\b . 7) '(#\C . 8))) +(equalp (remove-duplicates (vector '(#\A . 0) '(#\b . 1) '(#\C . 2) + '(#\a . 3) '(#\B . 4) '(#\c . 5) + '(#\A . 6) '(#\b . 7) '(#\C . 8) + '(#\a . 9) '(#\B . 10) '(#\c . 11)) + :key #'car :end 9) + (vector '(#\a . 3) '(#\B . 4) '(#\c . 5) + '(#\A . 6) '(#\b . 7) '(#\C . 8) + '(#\a . 9) '(#\B . 10) '(#\c . 11))) +(equalp (remove-duplicates (vector '(#\A . 0) '(#\b . 1) '(#\C . 2) + '(#\a . 3) '(#\B . 4) '(#\c . 5) + '(#\A . 6) '(#\b . 7) '(#\C . 8) + '(#\a . 9) '(#\B . 10) '(#\c . 11)) + :key #'car :end 9 :from-end t) + (vector '(#\A . 0) '(#\b . 1) '(#\C . 2) + '(#\a . 3) '(#\B . 4) '(#\c . 5) + '(#\a . 9) '(#\B . 10) '(#\c . 11))) +(equalp (remove-duplicates (vector '(#\A . 0) '(#\b . 1) '(#\C . 2) + '(#\a . 3) '(#\B . 4) '(#\c . 5) + '(#\A . 6) '(#\b . 7) '(#\C . 8) + '(#\a . 9) '(#\B . 10) '(#\c . 11)) + :key #'car :start 0 :end 12 :test #'char-equal) + (vector '(#\a . 9) '(#\B . 10) '(#\c . 11))) +(equalp (remove-duplicates (vector '(#\A . 0) '(#\b . 1) '(#\C . 2) + '(#\a . 3) '(#\B . 4) '(#\c . 5) + '(#\A . 6) '(#\b . 7) '(#\C . 8) + '(#\a . 9) '(#\B . 10) '(#\c . 11)) + :key #'car :start 0 :end 12 + :test-not (complement #'char-equal)) + (vector '(#\a . 9) '(#\B . 10) '(#\c . 11))) +(equalp (remove-duplicates (vector '(#\A . 0) '(#\b . 1) '(#\C . 2) + '(#\a . 3) '(#\B . 4) '(#\c . 5) + '(#\A . 6) '(#\b . 7) '(#\C . 8) + '(#\a . 9) '(#\B . 10) '(#\c . 11)) + :key #'car :start 0 :end 12 :test #'char-equal + :from-end t) + #((#\A . 0) (#\b . 1) (#\C . 2))) +(equalp (remove-duplicates (vector '(#\A . 0) '(#\b . 1) '(#\C . 2) + '(#\a . 3) '(#\B . 4) '(#\c . 5) + '(#\A . 6) '(#\b . 7) '(#\C . 8) + '(#\a . 9) '(#\B . 10) '(#\c . 11)) + :key #'car :start 0 :end 12 + :test-not (complement #'char-equal) :from-end t) + #((#\A . 0) (#\b . 1) (#\C . 2))) + +(string= (remove-duplicates (copy-seq "")) "") +(string= (remove-duplicates (copy-seq "abc")) "abc") +(string= (remove-duplicates (copy-seq "abcabc")) "abc") +(string= (remove-duplicates (copy-seq "cbaabc")) "abc") +(string= (remove-duplicates (copy-seq "cbaabc") :from-end t) "cba") +(string= (remove-duplicates (copy-seq "cbaabcABCCBA")) "abcCBA") +(string= (remove-duplicates (copy-seq "cbaabcABCCBA") :from-end t) "cbaABC") +(string= (remove-duplicates (copy-seq "cbaabcABCCBA") :key #'char-downcase) + "CBA") +(string= (remove-duplicates (copy-seq "cbaabcABCCBA") + :key #'char-downcase :from-end t) + "cba") +(string= (remove-duplicates (copy-seq "cbaabcABCCBA") :start 3) "cbaabcCBA") +(string= (remove-duplicates (copy-seq "cbaabcABCCBA") :start 3 :from-end t) + "cbaabcABC") +(string= (remove-duplicates (copy-seq "cbaabcABCCBA") :start 3 :end 9) + "cbaabcABCCBA") +(string= (remove-duplicates (copy-seq "cbaabcABCCBA") + :start 3 :end 9 :key #'char-upcase) + "cbaABCCBA") +(string= (remove-duplicates (copy-seq "cbaabcABCCBA") + :start 3 :end 9 :key #'char-upcase :from-end t) + "cbaabcCBA") +(string= (remove-duplicates (copy-seq "cbaabcABCCBA") + :start 3 :end 9 :test #'char-equal :from-end t) + "cbaabcCBA") +(string= (remove-duplicates (copy-seq "cbaabcABCCBA") + :start 3 :end 9 :test-not (complement #'char-equal) + :from-end t) + "cbaabcCBA") +(string= (remove-duplicates (copy-seq "cbaabcABCCBA") + :start 3 :end 9 :key #'upper-case-p :test #'eq) + "cbacCCBA") +(string= (remove-duplicates (copy-seq "cbaabcABCCBA") + :start 3 :end 9 :key #'upper-case-p :test #'eq + :from-end t) + "cbaaACBA") +(equal (remove-duplicates (copy-seq #*0011)) #*01) +(equal (remove-duplicates (copy-seq #*0110)) #*10) +(equal (remove-duplicates (copy-seq #*0110) :from-end t) #*01) +(equal (remove-duplicates (copy-seq #*0110) :start 1) #*010) +(equal (remove-duplicates (copy-seq #*0001111011000100010)) #*10) +(equal (remove-duplicates (copy-seq #*0001111011000100010) :from-end t) #*01) +(equal (remove-duplicates (copy-seq #*)) #*) +(equal (remove-duplicates (copy-seq #*01)) #*01) +(equal (remove-duplicates (copy-seq #*10)) #*10) +(equal (remove-duplicates (copy-seq #*0)) #*0) +(equal (remove-duplicates (copy-seq #*1)) #*1) +(equal (remove-duplicates (copy-seq #*1001) :start 1 :end 3) #*101) +(equal (remove-duplicates (copy-seq #*01011010) :start 2 :end 6) #*011010) +(equal (remove-duplicates (copy-seq #*01011010) :start 2 :end 6 :from-end t) + #*010110) +(equal (remove-duplicates (copy-seq #*01011010) + :start 2 :end 6 :from-end t + :key #'(lambda (arg) (char "aA" arg))) + #*010110) +(equal (remove-duplicates (copy-seq #*01011010) + :start 2 :end 6 :from-end t + :key #'(lambda (arg) (char "aA" arg)) + :test #'char-equal) + #*01010) +(equal (remove-duplicates (copy-seq #*01011010) + :start 2 :end 6 :from-end t + :key #'(lambda (arg) (char "aA" arg)) + :test-not (complement #'char-equal)) + #*01010) +(equal (remove-duplicates (copy-seq #*01011010) + :start 2 :end 6 + :key #'(lambda (arg) (char "aA" arg)) + :test #'char-equal) + #*01010) +(equal (remove-duplicates (copy-seq #*01011010) + :start 2 :end 6 + :key #'(lambda (arg) (char "aA" arg)) + :test-not (complement #'char-equal)) + #*01010) diff --git a/Sacla/tests/must-sequence.patch b/Sacla/tests/must-sequence.patch new file mode 100644 index 0000000..0c01d53 --- /dev/null +++ b/Sacla/tests/must-sequence.patch @@ -0,0 +1,26 @@ +*** sacla/lisp/test/must-sequence.lisp 2004-08-03 08:34:55.000000000 +0200 +--- CLISP/clisp-20040712/sacla-tests/must-sequence.lisp 2004-08-06 03:23:37.000000000 +0200 +*************** +*** 9545,9550 **** +--- 9545,9553 ---- + (equal list '(0 4 5 6))) + + ++ #-CLISP ; The tests ignores ANSI CL "remove-duplicates returns a sequence that ++ ; may share with sequence or may be identical to sequence if no elements ++ ; need to be removed." + (let* ((list0 (list 0 1 2)) + (list (remove-duplicates list0))) + (and (not (eq list0 list)) +*************** +*** 9555,9560 **** +--- 9558,9566 ---- + (and (not (eq list0 list)) + (equal list0 '(2 1 0 1 0 1 2)) + (equal list '(0 1 2)))) ++ #-CLISP ; The tests ignores ANSI CL "remove-duplicates returns a sequence that ++ ; may share with sequence or may be identical to sequence if no elements ++ ; need to be removed." + (let* ((vector0 (vector 0 1 2)) + (vector (remove-duplicates vector0))) + (and (not (eq vector0 vector)) diff --git a/Sacla/tests/must-string.lisp b/Sacla/tests/must-string.lisp new file mode 100644 index 0000000..763d747 --- /dev/null +++ b/Sacla/tests/must-string.lisp @@ -0,0 +1,608 @@ +;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp> +;; ALL RIGHTS RESERVED. +;; +;; $Id: must-string.lisp,v 1.7 2004/02/20 07:23:42 yuji Exp $ +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; * Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; * Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(simple-string-p "") +(simple-string-p "abc") +(not (simple-string-p 'not-a-string)) +(let ((str (make-array 3 :element-type 'character :fill-pointer t))) + (if (not (simple-vector-p str)) + (not (simple-string-p str)) + (simple-string-p str))) + +(char= (char "abc" 0) #\a) +(char= (char "abc" 1) #\b) +(char= (char "abc" 2) #\c) +(char= (schar "abc" 0) #\a) +(char= (schar "abc" 1) #\b) +(char= (schar "abc" 2) #\c) +(let ((str (make-array 10 + :element-type 'character + :fill-pointer 3 + :initial-contents "0123456789"))) + (and (string= str "012") + (char= (char str 3) #\3) + (char= (char str 4) #\4) + (char= (char str 5) #\5) + (char= (char str 6) #\6) + (char= (char str 7) #\7) + (char= (char str 8) #\8) + (char= (char str 9) #\9) + (char= (vector-pop str) #\2))) + +(string= (string "") "") +(string= (string "abc") "abc") +(string= (string "a") "a") +(string= (string 'abc) "ABC") +(string= (string 'a) "A") +(string= (string #\a) "a") + + +(string= (string-upcase "abcde") "ABCDE") +(string= (string-upcase "Dr. Livingston, I presume?") + "DR. LIVINGSTON, I PRESUME?") +(string= (string-upcase "Dr. Livingston, I presume?" :start 6 :end 10) + "Dr. LiVINGston, I presume?") +(string= (string-upcase 'Kludgy-HASH-Search) "KLUDGY-HASH-SEARCH") +(string= (string-upcase "abcde" :start 2 :end nil) "abCDE") + +(string= (string-downcase "Dr. Livingston, I presume?") + "dr. livingston, i presume?") +(string= (string-downcase 'Kludgy-HASH-Search) "kludgy-hash-search") +(string= (string-downcase "A FOOL" :start 2 :end nil) "A fool") +(string= (string-capitalize "elm 13c arthur;fig don't") + "Elm 13c Arthur;Fig Don'T") +(string= (string-capitalize " hello ") " Hello ") +(string= (string-capitalize + "occlUDeD cASEmenTs FOreSTAll iNADVertent DEFenestraTION") + "Occluded Casements Forestall Inadvertent Defenestration") +(string= (string-capitalize 'kludgy-hash-search) "Kludgy-Hash-Search") +(string= (string-capitalize "DON'T!") "Don'T!") ;not "Don't!" +(string= (string-capitalize "pipe 13a, foo16c") "Pipe 13a, Foo16c") +(string= (string-capitalize "a fool" :start 2 :end nil) "a Fool") + +(let ((str (copy-seq "0123ABCD890a"))) + (and (string= (nstring-downcase str :start 5 :end 7) "0123AbcD890a") + (string= str "0123AbcD890a"))) + +(let* ((str0 (copy-seq "abcde")) + (str (nstring-upcase str0))) + (and (eq str0 str) + (string= str "ABCDE"))) +(let* ((str0 (copy-seq "Dr. Livingston, I presume?")) + (str (nstring-upcase str0))) + (and (eq str0 str) + (string= str "DR. LIVINGSTON, I PRESUME?"))) +(let* ((str0 (copy-seq "Dr. Livingston, I presume?")) + (str (nstring-upcase str0 :start 6 :end 10))) + (and (eq str0 str) + (string= str "Dr. LiVINGston, I presume?"))) + +(let* ((str0 (copy-seq "abcde")) + (str (nstring-upcase str0 :start 2 :end nil))) + (string= str "abCDE")) + + + +(let* ((str0 (copy-seq "Dr. Livingston, I presume?")) + (str (nstring-downcase str0))) + (and (eq str0 str) + (string= str "dr. livingston, i presume?"))) +(let* ((str0 (copy-seq "ABCDE")) + (str (nstring-downcase str0 :start 2 :end nil))) + (string= str "ABcde")) + +(let* ((str0 (copy-seq "elm 13c arthur;fig don't")) + (str (nstring-capitalize str0))) + (and (eq str0 str) + (string= str "Elm 13c Arthur;Fig Don'T"))) + +(let* ((str0 (copy-seq " hello ")) + (str (nstring-capitalize str0))) + (and (eq str0 str) + (string= str " Hello "))) +(let* ((str0 (copy-seq + "occlUDeD cASEmenTs FOreSTAll iNADVertent DEFenestraTION")) + (str (nstring-capitalize str0))) + (and (eq str0 str) + (string= str + "Occluded Casements Forestall Inadvertent Defenestration"))) +(let* ((str0 (copy-seq "DON'T!")) + (str (nstring-capitalize str0))) + (and (eq str0 str) + (string= str "Don'T!"))) ;not "Don't!" +(let* ((str0 (copy-seq "pipe 13a, foo16c")) + (str (nstring-capitalize str0))) + (and (eq str0 str) + (string= str "Pipe 13a, Foo16c"))) +(let* ((str0 (copy-seq "a fool")) + (str (nstring-capitalize str0 :start 2 :end nil))) + (string= str "a Fool")) + + + +(string= (string-trim "abc" "abcaakaaakabcaaa") "kaaak") +(string= (string-trim '(#\Space #\Tab #\Newline) " garbanzo beans + ") "garbanzo beans") +(string= (string-trim " (*)" " ( *three (silly) words* ) ") + "three (silly) words") +(string= (string-left-trim "abc" "labcabcabc") "labcabcabc") +(string= (string-left-trim " (*)" " ( *three (silly) words* ) ") + "three (silly) words* ) ") +(string= (string-right-trim " (*)" " ( *three (silly) words* ) ") + " ( *three (silly) words") +(string= (string-trim "ABC" "abc") "abc") +(string= (string-trim "AABBCC" "abc") "abc") +(string= (string-trim "" "abc") "abc") +(string= (string-trim "ABC" "") "") +(string= (string-trim "cba" "abc") "") +(string= (string-trim "cba" "abccba") "") +(string= (string-trim "ccbbba" "abccba") "") +(string= (string-trim "cba" "abcxabc") "x") +(string= (string-trim "xyz" "xxyabcxyyz") "abc") +(string= (string-trim "CBA" 'abcxabc) "X") +(string= (string-trim "a" #\a) "") + + +(string= (string-left-trim "ABC" "abc") "abc") +(string= (string-left-trim "" "abc") "abc") +(string= (string-left-trim "ABC" "") "") +(string= (string-left-trim "cba" "abc") "") +(string= (string-left-trim "cba" "abccba") "") +(string= (string-left-trim "cba" "abcxabc") "xabc") +(string= (string-left-trim "xyz" "xxyabcxyz") "abcxyz") +(string= (string-left-trim "CBA" 'abcxabc) "XABC") +(string= (string-left-trim "a" #\a) "") + +(string= (string-right-trim "ABC" "abc") "abc") +(string= (string-right-trim "" "abc") "abc") +(string= (string-right-trim "ABC" "") "") +(string= (string-right-trim "cba" "abc") "") +(string= (string-right-trim "cba" "abccba") "") +(string= (string-right-trim "cba" "abcxabc") "abcx") +(string= (string-right-trim "xyz" "xxyabcxyz") "xxyabc") +(string= (string-right-trim "CBA" 'abcxabc) "ABCX") +(string= (string-right-trim "a" #\a) "") + + + +(string= (string "already a string") "already a string") +(string= (string 'elm) "ELM") +(string= (string #\c) "c") + + +(string= "foo" "foo") +(not (string= "foo" "Foo")) +(not (string= "foo" "bar")) +(string= "together" "frog" :start1 1 :end1 3 :start2 2) +(string-equal "foo" "Foo") +(string= "abcd" "01234abcd9012" :start2 5 :end2 9) +(eql (string< "aaaa" "aaab") 3) +(eql (string>= "aaaaa" "aaaa") 4) +(eql (string-not-greaterp "Abcde" "abcdE") 5) +(eql (string-lessp "012AAAA789" "01aaab6" + :start1 3 :end1 7 + :start2 2 :end2 6) 6) +(not (string-not-equal "AAAA" "aaaA")) + + +(string= "" "") +(string= (make-array 0 :element-type 'character) + (make-array 0 :element-type 'base-char)) +(not (string= "abc" "")) +(not (string= "" "abc")) +(not (string= "A" "a")) +(string= "abc" "xyz" :start1 3 :start2 3) +(string= "abc" "xyz" :start1 1 :end1 1 :start2 0 :end2 0) +(string= "axyza" "xyz" :start1 1 :end1 4) +(string= "axyza" "xyz" :start1 1 :end1 4 :start2 0 :end2 nil) +(string= "abxyz" "xyabz" :end1 2 :start2 2 :end2 4) +(not (string= "love" "hate")) +(string= 'love 'love) +(not (string= 'love "hate")) +(string= #\a #\a) + + +(not (string/= "" "")) +(not (string/= (make-array 0 :element-type 'character) + (make-array 0 :element-type 'base-char))) +(eql (string/= "abc" "") 0) +(eql (string/= "" "abc") 0) +(eql (string/= "A" "a") 0) +(not (string/= "abc" "xyz" :start1 3 :start2 3)) +(not (string/= "abc" "xyz" :start1 1 :end1 1 :start2 0 :end2 0)) +(not (string/= "axyza" "xyz" :start1 1 :end1 4)) +(not (string/= "axyza" "xyz" :start1 1 :end1 4 :start2 0 :end2 nil)) +(not (string/= "abxyz" "xyabz" :end1 2 :start2 2 :end2 4)) +(eql (string/= "love" "hate") 0) +(eql (string/= "love" "loVe") 2) +(not (string/= "life" "death" :start1 3 :start2 1 :end2 2)) +(eql (string/= "abcxyz" "ABCxyZ" :start1 3 :start2 3) 5) +(eql (string/= "abcxyz" "ABCxyZ" :start1 3 :end1 nil :start2 3 :end2 nil) 5) +(eql (string/= "abcxyz" "ABCxyZ" :end1 nil :start2 3 :end2 3) 0) +(eql (string/= "abc" "abcxyz") 3) +(eql (string/= "abcxyz" "abc") 3) +(eql (string/= "abcxyz" "") 0) +(eql (string/= "AbcDef" "cdef" :start1 2) 3) +(eql (string/= "cdef" "AbcDef" :start2 2) 1) +(= (string/= 'love "hate") 0) +(not (string/= 'love 'love)) +(not (string/= #\a #\a)) +(= (string/= #\a #\b) 0) + +(not (string< "" "")) +(not (string< "dog" "dog")) +(not (string< " " " ")) +(not (string< "abc" "")) +(eql (string< "" "abc") 0) +(eql (string< "ab" "abc") 2) +(not (string< "abc" "ab")) +(eql (string< "aaa" "aba") 1) +(not (string< "aba" "aaa")) +(not (string< "my cat food" "your dog food" :start1 6 :start2 8)) +(not (string< "cat food 2 dollars" "dog food 3 dollars" + :start1 3 :end1 9 :start2 3 :end2 9)) +(eql (string< "xyzabc" "abcd" :start1 3) 6) +(eql (string< "abc" "abc" :end1 1) 1) +(eql (string< "xyzabc" "abc" :start1 3 :end1 5) 5) +(eql (string< "xyz" "abcxyzXYZ" :start2 3) 3) +(not (string< "abc" "abcxyz" :end2 3)) +(eql (string< "xyz" "abcxyz" :end1 2 :start2 3) 2) +(not (string< "xyzabc" "abcdef" :start1 3 :end2 3)) +(eql (string< "aaaa" "z") 0) +(eql (string< "pppTTTaTTTqqq" "pTTTxTTT" :start1 3 :start2 1) 6) +(eql (string< "pppTTTaTTTqqq" "pTTTxTTT" + :start1 6 :end1 7 + :start2 4 :end2 5) 6) +(not (string< (make-array 0 :element-type 'character) + (make-array 0 :element-type 'base-char))) +(not (string< 'love 'hate)) +(= (string< 'peace 'war) 0) +(not (string< 'love 'love)) +(not (string< #\a #\a)) +(= (string< #\a #\b) 0) + + +(not (string> "" "")) +(not (string> "dog" "dog")) +(not (string> " " " ")) +(eql (string> "abc" "") 0) +(not (string> "" "abc")) +(not (string> "ab" "abc")) +(eql (string> "abc" "ab") 2) +(eql (string> "aba" "aaa") 1) +(not (string> "aaa" "aba")) +(not (string> "my cat food" "your dog food" :start1 6 :start2 8)) +(not (string> "cat food 2 dollars" "dog food 3 dollars" + :start1 3 :end1 9 :start2 3 :end2 9)) +(eql (string> "xyzabcde" "abcd" :start1 3) 7) +(not (string> "abc" "abc" :end1 1)) +(eql (string> "xyzabc" "a" :start1 3 :end1 5) 4) +(eql (string> "xyzXYZ" "abcxyz" :start2 3) 3) +(eql (string> "abcxyz" "abcxyz" :end2 3) 3) +(not (string> "xyzXYZ" "abcxyz" :end1 2 :start2 3)) +(not (string> "xyzabc" "abcdef" :start1 3 :end2 3)) +(eql (string> "z" "aaaa") 0) +(eql (string> "pTTTxTTTqqq" "pppTTTaTTT" :start1 1 :start2 3) 4) +(eql (string> "pppTTTxTTTqqq" "pTTTaTTT" + :start1 6 :end1 7 + :start2 4 :end2 5) 6) +(not (string> (make-array 0 :element-type 'character) + (make-array 0 :element-type 'base-char))) +(= (string> 'love 'hate) 0) +(not (string> 'peace 'war)) +(not (string> 'love 'love)) +(not (string> #\a #\a)) +(not (string> #\a #\b)) +(= (string> #\z #\a) 0) + + +(eql (string<= "" "") 0) +(eql (string<= "dog" "dog") 3) +(eql (string<= " " " ") 1) +(not (string<= "abc" "")) +(eql (string<= "ab" "abc") 2) +(eql (string<= "aaa" "aba") 1) +(not (string<= "aba" "aaa")) +(eql (string<= "my cat food" "your dog food" :start1 6 :start2 8) 11) +(eql (string<= "cat food 2 dollars" "dog food 3 dollars" + :start1 3 :end1 9 :start2 3 :end2 9) 9) +(eql (string<= "xyzabc" "abcd" :start1 3) 6) +(eql (string<= "abc" "abc" :end1 1) 1) +(eql (string<= "xyzabc" "abc" :start1 3 :end1 5) 5) +(eql (string<= "xyz" "abcxyzXYZ" :start2 3) 3) +(eql (string<= "abc" "abcxyz" :end2 3) 3) +(eql (string<= "xyz" "abcxyz" :end1 2 :start2 3) 2) +(eql (string<= "xyzabc" "abcdef" :start1 3 :end2 3) 6) +(eql (string<= "aaaa" "z") 0) +(eql (string<= "pppTTTaTTTqqq" "pTTTxTTT" :start1 3 :start2 1) 6) +(eql (string<= "pppTTTaTTTqqq" "pTTTxTTT" + :start1 6 :end1 7 + :start2 4 :end2 5) 6) +(eql (string<= (make-array 0 :element-type 'character) + (make-array 0 :element-type 'base-char)) 0) +(not (string<= 'love 'hate)) +(= (string<= 'peace 'war) 0) +(= (string<= 'love 'love) 4) +(= (string<= #\a #\a) 1) +(= (string<= #\a #\b) 0) +(not (string<= #\z #\a)) + + +(eql (string>= "" "") 0) +(eql (string>= "dog" "dog") 3) +(eql (string>= " " " ") 1) +(eql (string>= "abc" "") 0) +(not (string>= "" "abc")) +(not (string>= "ab" "abc")) +(eql (string>= "abc" "ab") 2) +(eql (string>= "aba" "aaa") 1) +(not (string>= "aaa" "aba")) +(eql (string>= "my cat food" "your dog food" :start1 6 :start2 8) 11) +(eql (string>= "cat food 2 dollars" "dog food 3 dollars" + :start1 3 :end1 9 :start2 3 :end2 9) 9) +(eql (string>= "xyzabcde" "abcd" :start1 3) 7) +(not (string>= "abc" "abc" :end1 1)) +(eql (string>= "xyzabc" "a" :start1 3 :end1 5) 4) +(eql (string>= "xyzXYZ" "abcxyz" :start2 3) 3) +(eql (string>= "abcxyz" "abcxyz" :end2 3) 3) +(not (string>= "xyzXYZ" "abcxyz" :end1 2 :start2 3)) +(eql (string>= "xyzabc" "abcdef" :start1 3 :end2 3) 6) +(eql (string>= "z" "aaaa") 0) +(eql (string>= "pTTTxTTTqqq" "pppTTTaTTT" :start1 1 :start2 3) 4) +(eql (string>= "pppTTTxTTTqqq" "pTTTaTTT" + :start1 6 :end1 7 + :start2 4 :end2 5) 6) +(eql (string>= (make-array 0 :element-type 'character) + (make-array 0 :element-type 'base-char)) 0) +(= (string>= 'love 'hate) 0) +(not (string>= 'peace 'war)) +(= (string>= 'love 'love) 4) +(= (string>= #\a #\a) 1) +(not (string>= #\a #\b)) +(= (string>= #\z #\a) 0) + + + + +(string-equal "" "") +(string-equal (make-array 0 :element-type 'character) + (make-array 0 :element-type 'base-char)) +(not (string-equal "abc" "")) +(not (string-equal "" "abc")) +(string-equal "A" "a") +(string-equal "abc" "xyz" :start1 3 :start2 3) +(string-equal "abc" "xyz" :start1 1 :end1 1 :start2 0 :end2 0) +(string-equal "axyza" "xyz" :start1 1 :end1 4) +(string-equal "axyza" "xyz" :start1 1 :end1 4 :start2 0 :end2 nil) +(string-equal "abxyz" "xyabz" :end1 2 :start2 2 :end2 4) +(not (string-equal "love" "hate")) +(string-equal "xyz" "XYZ") +(not (string-equal 'love 'hate)) +(not (string-equal 'peace 'war)) +(string-equal 'love 'love) +(string-equal #\a #\a) +(not (string-equal #\a #\b)) +(not (string-equal #\z #\a)) + + +(not (string-not-equal "" "")) +(not (string-not-equal (make-array 0 :element-type 'character) + (make-array 0 :element-type 'base-char))) +(eql (string-not-equal "abc" "") 0) +(eql (string-not-equal "" "abc") 0) +(not (string-not-equal "A" "a")) +(not (string-not-equal "abc" "xyz" :start1 3 :start2 3)) +(not (string-not-equal "abc" "xyz" :start1 1 :end1 1 :start2 0 :end2 0)) +(not (string-not-equal "axyza" "xyz" :start1 1 :end1 4)) +(not (string-not-equal "axyza" "xyz" :start1 1 :end1 4 :start2 0 :end2 nil)) +(not (string-not-equal "abxyz" "xyabz" :end1 2 :start2 2 :end2 4)) +(eql (string-not-equal "love" "hate") 0) +(not (string-not-equal "love" "loVe")) +(not (string-not-equal "life" "death" :start1 3 :start2 1 :end2 2)) +(not (string-not-equal "abcxyz" "ABCxyZ" :start1 3 :start2 3)) +(not (string-not-equal "abcxyz" "ABCxyZ" :start1 3 :end1 nil :start2 3 :end2 nil)) +(eql (string-not-equal "abcxyz" "ABCxyZ" :end1 nil :start2 3 :end2 3) 0) +(eql (string-not-equal "abc" "abcxyz") 3) +(eql (string-not-equal "abcxyz" "abc") 3) +(eql (string-not-equal "abcxyz" "") 0) +(not (string-not-equal "AbcDef" "cdef" :start1 2)) +(not (string-not-equal "cdef" "AbcDef" :start2 2)) +(not (string-not-equal "ABC" "abc")) +(= (string-not-equal 'love 'hate) 0) +(= (string-not-equal 'peace 'war) 0) +(not (string-not-equal 'love 'love)) +(not (string-not-equal #\a #\a)) +(= (string-not-equal #\a #\b) 0) +(= (string-not-equal #\z #\a) 0) + + +(not (string-lessp "" "")) +(not (string-lessp "dog" "dog")) +(not (string-lessp " " " ")) +(not (string-lessp "abc" "")) +(eql (string-lessp "" "abc") 0) +(eql (string-lessp "ab" "abc") 2) +(not (string-lessp "abc" "ab")) +(eql (string-lessp "aaa" "aba") 1) +(not (string-lessp "aba" "aaa")) +(not (string-lessp "my cat food" "your dog food" :start1 6 :start2 8)) +(not (string-lessp "cat food 2 dollars" "dog food 3 dollars" + :start1 3 :end1 9 :start2 3 :end2 9)) +(eql (string-lessp "xyzabc" "abcd" :start1 3) 6) +(eql (string-lessp "abc" "abc" :end1 1) 1) +(eql (string-lessp "xyzabc" "abc" :start1 3 :end1 5) 5) +(eql (string-lessp "xyz" "abcxyzXYZ" :start2 3) 3) +(not (string-lessp "abc" "abcxyz" :end2 3)) +(eql (string-lessp "xyz" "abcxyz" :end1 2 :start2 3) 2) +(not (string-lessp "xyzabc" "abcdef" :start1 3 :end2 3)) +(eql (string-lessp "aaaa" "z") 0) +(eql (string-lessp "pppTTTaTTTqqq" "pTTTxTTT" :start1 3 :start2 1) 6) +(eql (string-lessp "pppTTTaTTTqqq" "pTTTxTTT" + :start1 6 :end1 7 + :start2 4 :end2 5) 6) +(not (string-lessp (make-array 0 :element-type 'character) + (make-array 0 :element-type 'base-char))) +(and (not (string-lessp "abc" "ABC")) + (not (string-lessp "ABC" "abc"))) +(not (string-lessp 'love 'hate)) +(= (string-lessp 'peace 'war) 0) +(not (string-lessp 'love 'love)) +(not (string-lessp #\a #\a)) +(= (string-lessp #\a #\b) 0) +(not (string-lessp #\z #\a)) + + +(not (string-greaterp "" "")) +(not (string-greaterp "dog" "dog")) +(not (string-greaterp " " " ")) +(eql (string-greaterp "abc" "") 0) +(not (string-greaterp "" "abc")) +(not (string-greaterp "ab" "abc")) +(eql (string-greaterp "abc" "ab") 2) +(eql (string-greaterp "aba" "aaa") 1) +(not (string-greaterp "aaa" "aba")) +(not (string-greaterp "my cat food" "your dog food" :start1 6 :start2 8)) +(not (string-greaterp "cat food 2 dollars" "dog food 3 dollars" + :start1 3 :end1 9 :start2 3 :end2 9)) +(eql (string-greaterp "xyzabcde" "abcd" :start1 3) 7) +(not (string-greaterp "abc" "abc" :end1 1)) +(eql (string-greaterp "xyzabc" "a" :start1 3 :end1 5) 4) +(eql (string-greaterp "xyzXYZ" "abcxyz" :start2 3) 3) +(eql (string-greaterp "abcxyz" "abcxyz" :end2 3) 3) +(not (string-greaterp "xyzXYZ" "abcxyz" :end1 2 :start2 3)) +(not (string-greaterp "xyzabc" "abcdef" :start1 3 :end2 3)) +(eql (string-greaterp "z" "aaaa") 0) +(eql (string-greaterp "pTTTxTTTqqq" "pppTTTaTTT" :start1 1 :start2 3) 4) +(eql (string-greaterp "pppTTTxTTTqqq" "pTTTaTTT" + :start1 6 :end1 7 + :start2 4 :end2 5) 6) +(not (string-greaterp (make-array 0 :element-type 'character) + (make-array 0 :element-type 'base-char))) +(and (not (string-greaterp "abc" "ABC")) + (not (string-greaterp "ABC" "abc"))) +(= (string-greaterp 'love 'hate) 0) +(not (string-greaterp 'peace 'war)) +(not (string-greaterp 'love 'love)) +(not (string-greaterp #\a #\a)) +(not (string-greaterp #\a #\b)) +(= (string-greaterp #\z #\a) 0) + + +(eql (string-not-greaterp "" "") 0) +(eql (string-not-greaterp "dog" "dog") 3) +(eql (string-not-greaterp " " " ") 1) +(not (string-not-greaterp "abc" "")) +(eql (string-not-greaterp "ab" "abc") 2) +(eql (string-not-greaterp "aaa" "aba") 1) +(not (string-not-greaterp "aba" "aaa")) +(eql (string-not-greaterp "my cat food" "your dog food" :start1 6 :start2 8) 11) +(eql (string-not-greaterp "cat food 2 dollars" "dog food 3 dollars" + :start1 3 :end1 9 :start2 3 :end2 9) 9) +(eql (string-not-greaterp "xyzabc" "abcd" :start1 3) 6) +(eql (string-not-greaterp "abc" "abc" :end1 1) 1) +(eql (string-not-greaterp "xyzabc" "abc" :start1 3 :end1 5) 5) +(eql (string-not-greaterp "xyz" "abcxyzXYZ" :start2 3) 3) +(eql (string-not-greaterp "abc" "abcxyz" :end2 3) 3) +(eql (string-not-greaterp "xyz" "abcxyz" :end1 2 :start2 3) 2) +(eql (string-not-greaterp "xyzabc" "abcdef" :start1 3 :end2 3) 6) +(eql (string-not-greaterp "aaaa" "z") 0) +(eql (string-not-greaterp "pppTTTaTTTqqq" "pTTTxTTT" :start1 3 :start2 1) 6) +(eql (string-not-greaterp "pppTTTaTTTqqq" "pTTTxTTT" + :start1 6 :end1 7 + :start2 4 :end2 5) 6) +(eql (string-not-greaterp (make-array 0 :element-type 'character) + (make-array 0 :element-type 'base-char)) 0) +(and (eql (string-not-greaterp "abc" "ABC") 3) + (eql (string-not-greaterp "ABC" "abc") 3)) +(not (string-not-greaterp 'love 'hate)) +(= (string-not-greaterp 'peace 'war) 0) +(= (string-not-greaterp 'love 'love) 4) +(= (string-not-greaterp #\a #\a) 1) +(= (string-not-greaterp #\a #\b) 0) +(not (string-not-greaterp #\z #\a)) + + +(eql (string-not-lessp "" "") 0) +(eql (string-not-lessp "dog" "dog") 3) +(eql (string-not-lessp " " " ") 1) +(eql (string-not-lessp "abc" "") 0) +(not (string-not-lessp "" "abc")) +(not (string-not-lessp "ab" "abc")) +(eql (string-not-lessp "abc" "ab") 2) +(eql (string-not-lessp "aba" "aaa") 1) +(not (string-not-lessp "aaa" "aba")) +(eql (string-not-lessp "my cat food" "your dog food" :start1 6 :start2 8) 11) +(eql (string-not-lessp "cat food 2 dollars" "dog food 3 dollars" + :start1 3 :end1 9 :start2 3 :end2 9) 9) +(eql (string-not-lessp "xyzabcde" "abcd" :start1 3) 7) +(not (string-not-lessp "abc" "abc" :end1 1)) +(eql (string-not-lessp "xyzabc" "a" :start1 3 :end1 5) 4) +(eql (string-not-lessp "xyzXYZ" "abcxyz" :start2 3) 3) +(eql (string-not-lessp "abcxyz" "abcxyz" :end2 3) 3) +(not (string-not-lessp "xyzXYZ" "abcxyz" :end1 2 :start2 3)) +(eql (string-not-lessp "xyzabc" "abcdef" :start1 3 :end2 3) 6) +(eql (string-not-lessp "z" "aaaa") 0) +(eql (string-not-lessp "pTTTxTTTqqq" "pppTTTaTTT" :start1 1 :start2 3) 4) +(eql (string-not-lessp "pppTTTxTTTqqq" "pTTTaTTT" + :start1 6 :end1 7 + :start2 4 :end2 5) 6) +(eql (string-not-lessp (make-array 0 :element-type 'character) + (make-array 0 :element-type 'base-char)) 0) +(and (eql (string-not-lessp "abc" "ABC") 3) + (eql (string-not-lessp "ABC" "abc") 3)) +(= (string-not-lessp 'love 'hate) 0) +(not (string-not-lessp 'peace 'war)) +(= (string-not-lessp 'love 'love) 4) +(= (string-not-lessp #\a #\a) 1) +(not (string-not-lessp #\a #\b)) +(= (string-not-lessp #\z #\a) 0) + + + +(stringp "aaaaaa") +(stringp (make-array 0 :element-type 'character)) +(stringp (make-array 0 :element-type 'base-char)) +(stringp (make-array 0 :element-type 'standard-char)) +(not (stringp #\a)) +(not (stringp 'a)) +(not (stringp '(string))) + +(string= (make-string 3 :initial-element #\a) "aaa") +(let ((str (make-string 3))) + (and (simple-string-p str) + (setf (schar str 0) #\x) + (setf (schar str 1) #\y) + (setf (schar str 2) #\z) + (string= str "xyz"))) +(string= (make-string 1 :initial-element #\Space) " ") +(string= (make-string 0) "") + +(subtypep (upgraded-array-element-type + (array-element-type (make-string 3 :element-type 'standard-char))) + 'character) + diff --git a/Sacla/tests/must-symbol.lisp b/Sacla/tests/must-symbol.lisp new file mode 100644 index 0000000..74d8176 --- /dev/null +++ b/Sacla/tests/must-symbol.lisp @@ -0,0 +1,459 @@ +;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp> +;; ALL RIGHTS RESERVED. +;; +;; $Id: must-symbol.lisp,v 1.7 2004/02/20 07:23:42 yuji Exp $ +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; * Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; * Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(symbolp 'elephant) +(not (symbolp 12)) +(symbolp nil) +(symbolp '()) +(symbolp :test) +(not (symbolp "hello")) + +(not (keywordp 'elephant)) +(not (keywordp 12)) +(keywordp :test) +(keywordp ':test) +(not (keywordp nil)) +(keywordp :nil) +(not (keywordp '(:test))) +(not (keywordp "hello")) +(not (keywordp ":hello")) +(not (keywordp '&optional)) + + +(let ((new (make-symbol "symbol"))) + (string= (symbol-name new) "symbol")) + +(let ((new (make-symbol "symbol"))) + (not (boundp new))) + +(let ((new (make-symbol "symbol"))) + (not (fboundp new))) + +(let ((new (make-symbol "symbol"))) + (null (symbol-plist new))) + +(let ((new (make-symbol "symbol"))) + (null (symbol-package new))) + +(let ((new (make-symbol "symbol"))) + (not (member new (find-all-symbols "symbol")))) + +(every #'identity + (mapcar + #'(lambda (name) + (let ((new (make-symbol name))) + (and (string= (symbol-name new) name) + (not (boundp new)) + (not (fboundp new)) + (null (symbol-plist new)) + (not (member new (find-all-symbols name)))))) + '("" "Symbol" "eat-this" "SYMBOL" ":S:Y:M:B:O:L:"))) + + +(let ((copy (copy-symbol 'cl:car))) + (string= (symbol-name copy) (symbol-name 'cl:car))) + +(let ((copy (copy-symbol 'cl:car))) + (not (boundp copy))) + +(let ((copy (copy-symbol 'cl:car))) + (not (fboundp copy))) + +(let ((copy (copy-symbol 'cl:car))) + (null (symbol-plist copy))) + +(let ((copy (copy-symbol 'cl:car))) + (null (symbol-package copy))) + + +(let ((copy (copy-symbol 'cl:car "copy properties too"))) + (string= (symbol-name copy) (symbol-name 'cl:car))) + +(let ((copy (copy-symbol 'cl:car "copy properties too"))) + (if (boundp 'cl:car) + (boundp copy) + (not (boundp copy)))) + +(let ((copy (copy-symbol 'cl:car "copy properties too"))) + (eq (symbol-function copy) (symbol-function 'cl:car))) + +(let ((copy (copy-symbol 'cl:car "copy properties too"))) + (equal (symbol-plist copy) (symbol-plist 'cl:car))) + +(let ((copy (copy-symbol 'cl:car "copy properties too"))) + (null (symbol-package copy))) + + + +(every #'identity + (mapcar + #'(lambda (symbol) + (let ((copy1 (copy-symbol symbol)) + (copy2 (copy-symbol symbol "copy-properties"))) + (and (string= (symbol-name copy1) (symbol-name symbol)) + (string= (symbol-name copy2) (symbol-name symbol)) + (not (boundp copy1)) + (if (boundp symbol) + (boundp copy2) + (not (boundp copy2))) + (not (fboundp copy1)) + (if (fboundp symbol) + (fboundp copy2) + (not (fboundp copy2))) + (null (symbol-plist copy1)) + (equal (symbol-plist copy2) (symbol-plist symbol)) + (null (symbol-package copy1)) + (null (symbol-package copy2)) + (not (member copy1 (find-all-symbols symbol))) + (not (member copy2 (find-all-symbols symbol)))))) + '(nil cl:cdr cl:*package* cl:list symbol weird-symbol))) + + +(let ((new (gensym))) + (not (boundp new))) + +(let ((new (gensym))) + (not (fboundp new))) + +(let ((new (gensym))) + (null (symbol-plist new))) + +(let ((new (gensym))) + (null (symbol-package new))) + + +(let ((new (gensym "How about this"))) + (not (boundp new))) + +(let ((new (gensym "How about this"))) + (not (fboundp new))) + +(let ((new (gensym "How about this"))) + (null (symbol-plist new))) + +(let ((new (gensym "How about this"))) + (null (symbol-package new))) + + +(let ((new (gensym 100))) + (not (boundp new))) + +(let ((new (gensym 10))) + (not (fboundp new))) + +(let ((new (gensym 9))) + (null (symbol-plist new))) + +(let ((new (gensym 8))) + (null (symbol-package new))) + + +(let* ((counter *gensym-counter*) + (new (gensym))) + (string= (symbol-name new) + (with-output-to-string (stream) + (format stream "G~D" counter)))) + +(let* ((counter *gensym-counter*) + (new (gensym "JJ"))) + (string= (symbol-name new) + (with-output-to-string (stream) + (format stream "JJ~D" counter)))) + +(let* ((counter *gensym-counter*) + (new (gensym ""))) + (string= (symbol-name new) + (with-output-to-string (stream) + (format stream "~D" counter)))) + +(let ((new (gensym 0))) + (string= (symbol-name new) "G0")) + +(let ((new (gensym 1000))) + (string= (symbol-name new) "G1000")) + + + +(let ((symbol (gentemp))) + (char= (aref (symbol-name symbol) 0) #\T)) + +(let ((symbol (gentemp))) + (not (boundp symbol))) + +(let ((symbol (gentemp))) + (not (fboundp symbol))) + +(let ((symbol (gentemp))) + (null (symbol-plist symbol))) + +(let ((symbol (gentemp))) + (multiple-value-bind (symbol-found status) + (find-symbol (symbol-name symbol)) + (and (eq symbol-found symbol) + (if (eq *package* (find-package "KEYWORD")) + (eq status :external) + (eq status :internal))))) + +(let ((symbol-1 (gentemp)) + (symbol-2 (gentemp))) + (not (string= (symbol-name symbol-1) (symbol-name symbol-2)))) + +(let ((symbol (gentemp "prefix"))) + (string= (subseq (symbol-name symbol) 0 6) "prefix")) + +(let ((symbol (gentemp "prefix"))) + (not (boundp symbol))) + +(let ((symbol (gentemp "prefix"))) + (not (fboundp symbol))) + +(let ((symbol (gentemp "prefix"))) + (null (symbol-plist symbol))) + +(let ((symbol (gentemp "prefix"))) + (multiple-value-bind (symbol-found status) + (find-symbol (symbol-name symbol)) + (and (eq symbol-found symbol) + (if (eq *package* (find-package "KEYWORD")) + (eq status :external) + (eq status :internal))))) + + +(let* ((package (defpackage "TEST-PACKAGE-FOR-GENTEMP")) + (symbol (gentemp "prefix" package))) + (string= (subseq (symbol-name symbol) 0 6) "prefix")) + +(let* ((package (defpackage "TEST-PACKAGE-FOR-GENTEMP")) + (symbol (gentemp "prefix" package))) + (not (boundp symbol))) + +(let* ((package (defpackage "TEST-PACKAGE-FOR-GENTEMP")) + (symbol (gentemp "prefix" package))) + (not (fboundp symbol))) + +(let* ((package (defpackage "TEST-PACKAGE-FOR-GENTEMP")) + (symbol (gentemp "prefix" package))) + (null (symbol-plist symbol))) + +(let* ((package (defpackage "TEST-PACKAGE-FOR-GENTEMP")) + (symbol (gentemp "prefix" package))) + (multiple-value-bind (symbol-found status) + (find-symbol (symbol-name symbol) package) + (and (eq symbol-found symbol) + (eq status :internal)))) + + + +(functionp (symbol-function 'cl:car)) +(eq (symbol-function 'cl:car) (fdefinition 'cl:car)) +(progn (setf (symbol-function 'symbol-for-test) #'car) + (eq (symbol-for-test '(a)) 'a)) + +(let ((f #'(lambda (a) a))) + (setf (symbol-function 'symbol-for-test) f) + (eq (symbol-function 'symbol-for-test) f)) + + +(stringp (symbol-name 'symbol)) +(string= (symbol-name (intern "TEST-SYMBOL")) "TEST-SYMBOL") + + +(eq (symbol-package 'cl:car) (find-package "COMMON-LISP")) +(eq (symbol-package ':key) (find-package "KEYWORD")) +(null (symbol-package (make-symbol "temp"))) +(null (symbol-package (gensym))) +(packagep (symbol-package 'a)) +(packagep (symbol-package 'my-symbol)) + + +(listp (symbol-plist 'car)) +(listp (symbol-plist 'cdr)) +(null (symbol-plist (gensym))) +(null (symbol-plist (gentemp))) + +(let ((symbol (gensym))) + (setf (symbol-plist symbol) (list 'a 1 'b 2 'c 3)) + (equal (symbol-plist symbol) '(a 1 b 2 c 3))) + +(let ((symbol (gensym))) + (setf (symbol-plist symbol) (list 'a 1 'b 2 'c 3)) + (setf (symbol-plist symbol) '()) + (null (symbol-plist symbol))) + + +(progn (setf (symbol-value 'a) 1) + (eql (symbol-value 'a) 1)) + +(progn + (setf (symbol-value 'a) 1) + (let ((a 2)) + (eql (symbol-value 'a) 1))) + +(progn + (setf (symbol-value 'a) 1) + (let ((a 2)) + (setq a 3) + (eql (symbol-value 'a) 1))) + +(progn + (setf (symbol-value 'a) 1) + (let ((a 2)) + (declare (special a)) + (eql (symbol-value 'a) 2))) + +(progn + (setf (symbol-value 'a) 1) + (let ((a 2)) + (declare (special a)) + (setq a 3) + (eql (symbol-value 'a) 3))) + +(progn + (setf (symbol-value 'a) 1) + (and (eql (let ((a 2)) + (setf (symbol-value 'a) 3) + a) + 2) + (eql a 3))) + +(progn + (setf (symbol-value 'a) 1) + (let ((a 4)) + (declare (special a)) + (let ((b (symbol-value 'a))) + (setf (symbol-value 'a) 5) + (and (eql a 5) + (eql b 4))))) + +(eq (symbol-value :any-keyword) :any-keyword) +(eq (symbol-value 'nil) nil) +(eq (symbol-value '()) nil) +(eq (symbol-value t) t) + + +(let ((symbol (gensym))) + (setf (symbol-plist symbol) (list 'a 1 'b 2 'c 3)) + (and (eql (get symbol 'a) 1) + (eql (get symbol 'b) 2) + (eql (get symbol 'c) 3) + (eql (get symbol 'd) nil) + (eql (get symbol 'e 9) 9))) + +(let ((symbol (gensym))) + (setf (symbol-plist symbol) (list 'a 1 'b 2 'c 3)) + (and (eql (setf (get symbol 'a) 9) 9) + (eql (get symbol 'a) 9) + (eql (setf (get symbol 'b) 8) 8) + (eql (get symbol 'b) 8) + (eql (setf (get symbol 'c) 7) 7) + (eql (get symbol 'c) 7) + (eql (setf (get symbol 'd) 6) 6) + (eql (get symbol 'd) 6) + (eql (setf (get symbol 'e) 5) 5) + (eql (get symbol 'e) 5))) + +(let ((symbol (gensym)) + tmp) + (and (null (get symbol 'a)) + (setf (get symbol 'a (setq tmp 1)) tmp) + (eql (get symbol 'a) 1))) + +(let ((symbol (gensym))) + (setf (symbol-plist symbol) (list 'a 1 'b 2 'c 3 'a 9)) + (and (eql (setf (get symbol 'a) 5) 5) + (eql (get symbol 'a) 5))) + + +(let ((symbol (gensym))) + (setf (symbol-plist symbol) (list 'a 1 'b 2 'c 3)) + (and (remprop symbol 'a) + (eq (get symbol 'a 'not-found) 'not-found))) + +(let ((symbol (gensym))) + (not (remprop symbol 'a))) + +(let ((symbol (gensym))) + (setf (symbol-plist symbol) (list 'a 1 'b 2 'c 3 'a 9)) + (and (remprop symbol 'a) + (eql (get symbol 'a) 9))) + +(let ((symbol (gensym))) + (setf (symbol-plist symbol) (list 'a 1 'b 2 'c 3 'a 9)) + (and (remprop symbol 'a) + (eql (get symbol 'a) 9) + (remprop symbol 'a) + (eq (get symbol 'a 'not-found) 'not-found))) + + +(not (boundp (gensym))) +(let ((symbol (gensym))) + (set symbol 1) + (boundp symbol)) + +(let ((test-symbol 1)) + (not (boundp 'test-symbol))) + +(let ((test-symbol 1)) + (declare (special test-symbol)) + (boundp 'test-symbol)) + + +(not (boundp (makunbound (gensym)))) + +(let ((test-symbol 0)) + (declare (special test-symbol)) + (and (let ((test-symbol 1)) + (declare (special test-symbol)) + (not (boundp (makunbound 'test-symbol)))) + (boundp 'test-symbol))) + + +(let ((test-symbol 0)) + (declare (special test-symbol)) + (and (let ((test-symbol 1)) + (makunbound 'test-symbol) + (eql test-symbol 1)) + (not (boundp 'test-symbol)))) + + +(let ((test-symbol 0)) + (declare (special test-symbol)) + (and + (eql test-symbol 0) + (setf (symbol-value 'test-symbol) 1) + (eql test-symbol 1) + (eql (set 'test-symbol 10) 10) + (eql test-symbol 10))) + +(let ((test-symbol 0)) + (declare (special test-symbol)) + (and (let ((test-symbol 1)) + (set 'test-symbol 100) + (eql test-symbol 1)) + (eql test-symbol 100))) + diff --git a/Sacla/tests/should-array.lisp b/Sacla/tests/should-array.lisp new file mode 100644 index 0000000..ce72337 --- /dev/null +++ b/Sacla/tests/should-array.lisp @@ -0,0 +1,229 @@ +;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp> +;; ALL RIGHTS RESERVED. +;; +;; $Id: should-array.lisp,v 1.12 2004/08/09 02:49:55 yuji Exp $ +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; * Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; * Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(HANDLER-CASE (PROGN (ADJUST-ARRAY (MAKE-ARRAY '(3 3)) '(1 9) :FILL-POINTER 1)) + (ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +#-CLISP ;Bruno: Why expect an error? A string _is_ an array. +(progn + #-(or cmu clispxxx) + (HANDLER-CASE (PROGN (ADJUSTABLE-ARRAY-P "not-a-symbol")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + #+(or cmu clispxxx) 'skipped) + +(progn + #-cmu + (HANDLER-CASE (PROGN (ADJUSTABLE-ARRAY-P #\a)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + #+cmu 'skipped) + +(progn + #-cmu + (HANDLER-CASE (PROGN (ADJUSTABLE-ARRAY-P '(NIL))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + #+cmu 'skipped) + +(HANDLER-CASE (PROGN (ARRAY-DIMENSIONS 'NOT-AN-ARRAY)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (ARRAY-DIMENSIONS #\a)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (ARRAY-DIMENSIONS '(NIL))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + + +(HANDLER-CASE (PROGN (ARRAY-ELEMENT-TYPE 'NOT-AN-ARRAY)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (ARRAY-ELEMENT-TYPE #\a)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (ARRAY-ELEMENT-TYPE '(NIL))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(progn + #-cmu + (HANDLER-CASE (PROGN (ARRAY-HAS-FILL-POINTER-P 'NOT-AN-ARRAY)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + #+cmu 'skipped) + +(progn + #-cmu + (HANDLER-CASE (PROGN (ARRAY-HAS-FILL-POINTER-P #\a)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + #+cmu 'skipped) + +(progn + #-cmu + (HANDLER-CASE (PROGN (ARRAY-HAS-FILL-POINTER-P '(NIL))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + #+cmu 'skipped) + +(progn + #-cmu + (HANDLER-CASE (PROGN (ARRAY-DISPLACEMENT 'NOT-AN-ARRAY)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + #+cmu 'skipped) + +(progn + #-cmu + (HANDLER-CASE (PROGN (ARRAY-DISPLACEMENT #\a)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + #+cmu 'skipped) + +(progn + #-cmu + (HANDLER-CASE (PROGN (ARRAY-DISPLACEMENT '(NIL))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + #+cmu 'skipped) + +(HANDLER-CASE (PROGN (ARRAY-RANK 'NOT-AN-ARRAY)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (ARRAY-RANK #\a)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (ARRAY-RANK '(NIL))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (ARRAY-TOTAL-SIZE 'NOT-AN-ARRAY)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (ARRAY-TOTAL-SIZE #\a)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (ARRAY-TOTAL-SIZE '(NIL))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (FILL-POINTER 'NOT-AN-ARRAY)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (FILL-POINTER #\a)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (FILL-POINTER '(NIL))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(let ((vector (make-array 10 :fill-pointer nil))) + (or (not (array-has-fill-pointer-p vector)) + (HANDLER-CASE (PROGN (FILL-POINTER VECTOR)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)))) + +(let ((vector (make-array 10 :fill-pointer nil))) + (or (not (array-has-fill-pointer-p vector)) + (HANDLER-CASE (PROGN (SETF (FILL-POINTER VECTOR) 0)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)))) + +(progn + #-(or cmu clisp) + (HANDLER-CASE (PROGN (VECTOR-POP (MAKE-ARRAY 10 :FILL-POINTER NIL))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + #+(or cmu clisp) 'skipped) + +(HANDLER-CASE (PROGN (VECTOR-POP (MAKE-ARRAY 10 :FILL-POINTER 0))) + (ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(let ((vec (make-array 3 :fill-pointer t :initial-contents '(a b c)))) + (and (eq (vector-pop vec) 'c) + (eq (vector-pop vec) 'b) + (eq (vector-pop vec) 'a) + (HANDLER-CASE (PROGN (VECTOR-POP VEC)) + (ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)))) + + +(let ((vector (make-array 10 :fill-pointer nil))) + (or (not (array-has-fill-pointer-p vector)) + (HANDLER-CASE (PROGN (VECTOR-PUSH 'A VECTOR)) + (ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)))) + +(let ((vector (make-array 10 :fill-pointer nil))) + (or (not (array-has-fill-pointer-p vector)) + (HANDLER-CASE (PROGN (VECTOR-PUSH-EXTEND 'A VECTOR)) + (ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)))) + +(let ((vector (make-array 1 :fill-pointer t :adjustable nil))) + (or (adjustable-array-p vector) + (HANDLER-CASE (PROGN (VECTOR-PUSH-EXTEND 'A VECTOR)) + (ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)))) + diff --git a/Sacla/tests/should-array.patch b/Sacla/tests/should-array.patch new file mode 100644 index 0000000..113e1c7 --- /dev/null +++ b/Sacla/tests/should-array.patch @@ -0,0 +1,32 @@ +*** sacla/lisp/test/should-array.lisp 2004-08-03 08:34:55.000000000 +0200 +--- CLISP/clisp-20040712/sacla-tests/should-array.lisp 2004-08-06 03:27:42.000000000 +0200 +*************** +*** 31,43 **** + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + + (progn +! #-(or cmu clisp) + (HANDLER-CASE (PROGN (ADJUSTABLE-ARRAY-P "not-a-symbol")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +! #+(or cmu clisp) 'skipped) + + (progn + #-cmu +--- 31,44 ---- + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + ++ #-CLISP ; Why expect an error? A string _is_ an array. + (progn +! #-(or cmu clispxxx) + (HANDLER-CASE (PROGN (ADJUSTABLE-ARRAY-P "not-a-symbol")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +! #+(or cmu clispxxx) 'skipped) + + (progn + #-cmu diff --git a/Sacla/tests/should-character.lisp b/Sacla/tests/should-character.lisp new file mode 100644 index 0000000..40643ad --- /dev/null +++ b/Sacla/tests/should-character.lisp @@ -0,0 +1,252 @@ +;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp> +;; ALL RIGHTS RESERVED. +;; +;; $Id: should-character.lisp,v 1.10 2004/02/20 07:23:42 yuji Exp $ +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; * Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; * Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(HANDLER-CASE (PROGN (CHAR=)) + (PROGRAM-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (CHAR/=)) + (PROGRAM-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (CHAR<)) + (PROGRAM-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (CHAR>)) + (PROGRAM-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (CHAR<=)) + (PROGRAM-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (CHAR>=)) + (PROGRAM-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (CHAR-EQUAL)) + (PROGRAM-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (CHAR-NOT-EQUAL)) + (PROGRAM-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (CHAR-LESSP)) + (PROGRAM-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (CHAR-GREATERP)) + (PROGRAM-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (CHAR-NOT-GREATERP)) + (PROGRAM-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (CHAR-NOT-LESSP)) + (PROGRAM-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + + +(HANDLER-CASE (PROGN (CHARACTER "abc")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (CHARACTER 'MORE-THAN-ONE)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (CHARACTER '(NIL))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (ALPHA-CHAR-P "abc")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (ALPHA-CHAR-P 'NOT-A-CHAR)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (ALPHA-CHAR-P '(NIL))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (ALPHANUMERICP "abc")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (ALPHANUMERICP 'NOT-A-CHAR)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (ALPHANUMERICP '(NIL))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(progn + #-cmu + (HANDLER-CASE (PROGN (GRAPHIC-CHAR-P "abc")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + #+cmu 'skipped) + +(progn + #-cmu + (HANDLER-CASE (PROGN (GRAPHIC-CHAR-P 'NOT-A-CHAR)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + #+cmu 'skipped) + +(progn + #-cmu + (HANDLER-CASE (PROGN (GRAPHIC-CHAR-P '(NIL))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + #+cmu 'skipped) + +(HANDLER-CASE (PROGN (STANDARD-CHAR-P "abc")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (STANDARD-CHAR-P 'NOT-A-CHAR)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (STANDARD-CHAR-P '(NIL))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (CHAR-UPCASE "abc")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (CHAR-UPCASE 'NOT-A-CHAR)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (CHAR-UPCASE '(NIL))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (CHAR-DOWNCASE "abc")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (CHAR-DOWNCASE 'NOT-A-CHAR)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (CHAR-DOWNCASE '(NIL))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (UPPER-CASE-P "abc")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (UPPER-CASE-P 'NOT-A-CHAR)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (UPPER-CASE-P '(NIL))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (LOWER-CASE-P "abc")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (LOWER-CASE-P 'NOT-A-CHAR)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (LOWER-CASE-P '(NIL))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (BOTH-CASE-P "abc")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (BOTH-CASE-P 'NOT-A-CHAR)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (BOTH-CASE-P '(NIL))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (CHAR-CODE "abc")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (CHAR-CODE 'NOT-A-CHAR)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (CHAR-CODE '(NIL))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (CHAR-NAME "abc")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (CHAR-NAME 'NOT-A-CHAR)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (CHAR-NAME '(NIL))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (NAME-CHAR '(NIL))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) diff --git a/Sacla/tests/should-cons.lisp b/Sacla/tests/should-cons.lisp new file mode 100644 index 0000000..1d58d06 --- /dev/null +++ b/Sacla/tests/should-cons.lisp @@ -0,0 +1,631 @@ +;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp> +;; ALL RIGHTS RESERVED. +;; +;; $Id: should-cons.lisp,v 1.4 2004/02/20 07:23:42 yuji Exp $ +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; * Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; * Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(HANDLER-CASE (PROGN (RPLACA NIL 1)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (RPLACA "NOT A CONS" 1)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (RPLACD NIL 1)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (RPLACD "NOT A CONS" 1)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (CAR "NOT A CONS")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (CDR "NOT A CONS")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (CAAR "NOT A CONS")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (CADR "NOT A CONS")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (CDAR "NOT A CONS")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (CDDR "NOT A CONS")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (CAAAR "NOT A CONS")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (CAADR "NOT A CONS")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (CADAR "NOT A CONS")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (CADDR "NOT A CONS")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (CDAAR "NOT A CONS")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (CDADR "NOT A CONS")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (CDDAR "NOT A CONS")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (CDDDR "NOT A CONS")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (CAAAAR "NOT A CONS")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (CAAADR "NOT A CONS")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (CAADAR "NOT A CONS")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (CAADDR "NOT A CONS")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (CADAAR "NOT A CONS")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (CADADR "NOT A CONS")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (CADDAR "NOT A CONS")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (CADDDR "NOT A CONS")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (CDAAAR "NOT A CONS")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (CDAADR "NOT A CONS")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (CDADAR "NOT A CONS")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (CDADDR "NOT A CONS")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (CDDAAR "NOT A CONS")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (CDDADR "NOT A CONS")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (CDDDAR "NOT A CONS")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (CDDDDR "NOT A CONS")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (LIST-LENGTH '(1 . 2))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (LIST-LENGTH "NEITHER A PROPER LIST NOR A CIRCULAR LIST")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (LIST-LENGTH 'NEITHER-A-PROPER-LIST-NOR-A-CIRCULAR-LIST)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + + +(HANDLER-CASE (PROGN (MAKE-LIST NIL)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (MAKE-LIST -1)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (MAKE-LIST 1.2)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (MAKE-LIST 'A)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (MAKE-LIST "NOT A NON-NEGATIVE INTEGER")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + + +(HANDLER-CASE (PROGN (FIRST "NOT A CONS")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (SECOND "NOT A CONS")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (THIRD "NOT A CONS")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (FOURTH "NOT A CONS")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (FIFTH "NOT A CONS")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (SIXTH "NOT A CONS")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (SEVENTH "NOT A CONS")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (NINTH "NOT A CONS")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (TENTH "NOT A CONS")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (NTHCDR -1 '(1 2 3))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (NTHCDR 1.1 '(1 2 3))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (NTHCDR #\a '(1 2 3))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (NTHCDR 3 '(1 . 2))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (NTH -1 '(1 2))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (NTH "" '(1 2))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (NTH 3 '(1 . 2))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (ENDP 1)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (ENDP #\z)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (ENDP 'NOT-A-LIST)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (ENDP "not-a-list")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (BUTLAST 'NOT-A-LIST)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (BUTLAST 'NOT-A-LIST 'NOT-A-INTEGER)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (BUTLAST '(1 2 3 4 5) -1)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (BUTLAST '(1 2 3 4 5) 'A)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (NBUTLAST 'NOT-A-LIST)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (NBUTLAST 'NOT-A-LIST 'NOT-A-INTEGER)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (NBUTLAST '(1 2 3 4 5) -1)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (NBUTLAST '(1 2 3 4 5) 'A)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + + +(HANDLER-CASE (PROGN (LDIFF 'NOT-A-LIST 'OBJ)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (TAILP 'OBJ 'NOT-A-LIST)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (REST "NOT A CONS")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (MEMBER 'A 'NOT-A-SET)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (MEMBER 'A '(1 . 2))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (MEMBER 'A '(1 2 3 4 . 5))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (MEMBER-IF #'ATOM 'NOT-A-SET)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (MEMBER-IF #'CONSP '(1 . 2))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (MEMBER-IF #'CONSP '(1 2 3 4 . 5))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (MEMBER-IF-NOT (COMPLEMENT #'ATOM) 'NOT-A-SET)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (MEMBER-IF-NOT (COMPLEMENT #'CONSP) '(1 . 2))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (MEMBER-IF-NOT (COMPLEMENT #'CONSP) '(1 2 3 4 . 5))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (MAPCAR #'CAR 'NOT-A-LIST)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (MAPCAR #'LIST '(0 1) 'NOT-A-LIST)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (MAPCAR #'LIST '(0 . 1))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (MAPC #'CAR 'NOT-A-LIST)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (MAPC #'LIST '(0 1) 'NOT-A-LIST)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (MAPC #'LIST '(0 . 1))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (MAPCAN #'CAR 'NOT-A-LIST)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (MAPCAN #'LIST '(0 1) 'NOT-A-LIST)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (MAPCAN #'LIST '(0 . 1))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (MAPLIST #'CAR 'NOT-A-LIST)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (MAPLIST #'LIST '(0 1) 'NOT-A-LIST)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (MAPLIST #'LIST '(0 . 1))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (MAPL #'CAR 'NOT-A-LIST)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (MAPL #'LIST '(0 1) 'NOT-A-LIST)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (MAPL #'LIST '(0 . 1))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (MAPCON #'CAR 'NOT-A-LIST)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (MAPCON #'LIST '(0 1) 'NOT-A-LIST)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (MAPCON #'LIST '(0 . 1))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + + +(HANDLER-CASE (PROGN (ASSOC 'KEY '(A B C))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (ASSOC-IF #'NUMBERP '(A B C))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (ASSOC-IF-NOT #'NUMBERP '(A B C))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (ASSOC 'KEY '0)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (ASSOC-IF #'NUMBERP '0)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (ASSOC-IF-NOT #'NUMBERP '0)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (ASSOC 'KEY 'NOT-AN-ALIST)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (ASSOC-IF 'IDENTITY 'NOT-AN-ALIST)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (ASSOC-IF-NOT 'IDENTITY 'NOT-AN-ALIST)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (PAIRLIS 'NOT-A-LIST 'NOT-A-LIST '((A . B)))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (PAIRLIS '0 '(0 1 2) '((KEY . DATUM)))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (PAIRLIS '(0) '1 '((KEY . DATUM)))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (INTERSECTION '(0) '1)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (INTERSECTION '(0) '1 :TEST #'EQUALP)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (INTERSECTION #\a '(1 2 3) :TEST #'=)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (INTERSECTION 0 1)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (INTERSECTION #\a #\b)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (INTERSECTION 0 1 :TEST #'=)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (INTERSECTION #\a #\b :TEST-NOT (COMPLEMENT #'CHAR=))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (INTERSECTION '(1 2 3 . 4) '(2 3))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (INTERSECTION '(1 2 3 . 4) '(2 3) :TEST #'=)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (INTERSECTION '(1 2 3) '(2 . 3) :TEST #'=)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE + (PROGN (INTERSECTION '((1) (2) (3)) '((2) 3) :TEST #'= :KEY #'CAR)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (NINTERSECTION (LIST 0) '1)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (NINTERSECTION (LIST 0) '1 :TEST #'EQUALP)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (NINTERSECTION #\a '(1 2 3) :TEST #'=)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (NINTERSECTION 0 1)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (NINTERSECTION #\a #\b)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (NINTERSECTION 0 1 :TEST #'=)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (INTERSECTION #\a #\b :TEST-NOT (COMPLEMENT #'CHAR=))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (NINTERSECTION (LIST* 1 2 3 4) '(2 3))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (NINTERSECTION (LIST* 1 2 3 4) '(2 3) :TEST #'=)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (NINTERSECTION (LIST 1 2 3) '(2 . 3) :TEST #'=)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE + (PROGN (NINTERSECTION (LIST '(1) '(2) '(3)) '((2) 3) :TEST #'= :KEY #'CAR)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + + +(HANDLER-CASE (PROGN (ADJOIN 'A 'A)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (ADJOIN 'X '(A . B))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + + +(HANDLER-CASE (PROGN (SET-DIFFERENCE 'NOT-A-LIST 'NOT-A-LIST)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (NSET-DIFFERENCE 'NOT-A-LIST 'NOT-A-LIST)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (SET-EXCLUSIVE-OR 'NOT-A-LIST 'NOT-A-LIST)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (NSET-EXCLUSIVE-OR 'NOT-A-LIST 'NOT-A-LIST)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (UNION 'NOT-A-LIST 'NOT-A-LIST)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + diff --git a/Sacla/tests/should-data-and-control.lisp b/Sacla/tests/should-data-and-control.lisp new file mode 100644 index 0000000..5a3e28a --- /dev/null +++ b/Sacla/tests/should-data-and-control.lisp @@ -0,0 +1,49 @@ +;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp> +;; ALL RIGHTS RESERVED. +;; +;; $Id: should-data-and-control.lisp,v 1.9 2004/02/20 07:23:42 yuji Exp $ +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; * Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; * Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(HANDLER-CASE (PROGN (FUNCALL (GENSYM) 0 1 2)) + (UNDEFINED-FUNCTION NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +;; (HANDLER-CASE (PROGN (FUNCALL 'IF T NIL T)) +;; (UNDEFINED-FUNCTION NIL T) +;; (ERROR NIL NIL) +;; (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (VALUES-LIST 'NOT-A-LIST)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (VALUES-LIST #\a)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (VALUES-LIST '(A . B))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) diff --git a/Sacla/tests/should-eval.lisp b/Sacla/tests/should-eval.lisp new file mode 100644 index 0000000..c441400 --- /dev/null +++ b/Sacla/tests/should-eval.lisp @@ -0,0 +1,40 @@ +;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp> +;; ALL RIGHTS RESERVED. +;; +;; $Id: should-eval.lisp,v 1.7 2004/02/20 07:23:42 yuji Exp $ +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; * Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; * Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(HANDLER-CASE (PROGN (SPECIAL-OPERATOR-P '(IF T NIL T))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (SPECIAL-OPERATOR-P '(NOT A SYMBOL))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + + + diff --git a/Sacla/tests/should-hash-table.lisp b/Sacla/tests/should-hash-table.lisp new file mode 100644 index 0000000..2b5f98d --- /dev/null +++ b/Sacla/tests/should-hash-table.lisp @@ -0,0 +1,48 @@ +;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp> +;; ALL RIGHTS RESERVED. +;; +;; $Id: should-hash-table.lisp,v 1.7 2004/02/20 07:23:42 yuji Exp $ +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; * Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; * Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(HANDLER-CASE (PROGN (HASH-TABLE-REHASH-SIZE 'NOT-A-HASH-TABLE)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (HASH-TABLE-REHASH-THRESHOLD 'NOT-A-HASH-TABLE)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (HASH-TABLE-TEST 'NOT-A-HASH-TABLE)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + + + + + + diff --git a/Sacla/tests/should-package.lisp b/Sacla/tests/should-package.lisp new file mode 100644 index 0000000..fc68915 --- /dev/null +++ b/Sacla/tests/should-package.lisp @@ -0,0 +1,53 @@ +;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp> +;; ALL RIGHTS RESERVED. +;; +;; $Id: should-package.lisp,v 1.8 2004/02/20 07:23:42 yuji Exp $ +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; * Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; * Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(HANDLER-CASE (PROGN (PACKAGE-NAME '(NOT A PACKAGE DESIGNATOR))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (PACKAGE-NICKNAMES '(NOT A PACKAGE DESIGNATOR))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (PACKAGE-SHADOWING-SYMBOLS '(NOT A PACKAGE DESIGNATOR))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (PACKAGE-USE-LIST '(NOT A PACKAGE DESIGNATOR))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (PACKAGE-USED-BY-LIST '(NOT A PACKAGE DESIGNATOR))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (EVAL (MACROEXPAND '(WITH-PACKAGE-ITERATOR (GET 'CL))))) + (PROGRAM-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + diff --git a/Sacla/tests/should-sequence.lisp b/Sacla/tests/should-sequence.lisp new file mode 100644 index 0000000..455a941 --- /dev/null +++ b/Sacla/tests/should-sequence.lisp @@ -0,0 +1,375 @@ +;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp> +;; ALL RIGHTS RESERVED. +;; +;; $Id: should-sequence.lisp,v 1.18 2004/02/20 07:23:42 yuji Exp $ +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; * Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; * Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(HANDLER-CASE (PROGN (LENGTH 'NOT-A-SEQ)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + + + +(HANDLER-CASE (PROGN (COPY-SEQ 'NOT-A-SEQ)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (COPY-SEQ #2A((#\a #\b #\c) (#\x #\y #\z)))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (COPY-SEQ #\a)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (COPY-SEQ '(A . B))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + + +(HANDLER-CASE (PROGN (ELT 'NOT-A-SEQ 0)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (ELT #\a 0)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (ELT '(0 1 . 2) 2)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +;; (HANDLER-CASE (PROGN (ELT '#1=(0 1 . #1#) 3)) +;; (TYPE-ERROR NIL T) +;; (ERROR NIL NIL) +;; (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (SETF (ELT 'NOT-A-SEQ 0) 0)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (SETF (ELT #\a 0) 0)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (SETF (ELT '(0 1 . 2) 2) 0)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +;; (HANDLER-CASE (PROGN (SETF (ELT '#1=(0 1 . #1#) 3) 0)) +;; (TYPE-ERROR NIL T) +;; (ERROR NIL NIL) +;; (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (ELT "012" -1)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (ELT "012" 'INDEX)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (ELT "012" "xyz")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (ELT "012" 100)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (ELT #(A B C D) 100)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (ELT '(0 1 2) 100)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE + (PROGN + (ELT (MAKE-ARRAY 10 :FILL-POINTER 3 + :INITIAL-CONTENTS '(0 1 2 3 4 5 6 7 8 9)) + 3)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + + + +(HANDLER-CASE (PROGN (SETF (ELT (COPY-SEQ "012") -1) #\a)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (SETF (ELT (COPY-SEQ "012") 'INDEX) #\a)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (SETF (ELT (COPY-SEQ "012") "xyz") #\a)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (SETF (ELT (COPY-SEQ "012") 100) #\a)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (SETF (ELT (LIST 0 1 2) 100) 0)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (SETF (ELT (LIST 0 1 2) -1) 0)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + + +(HANDLER-CASE (PROGN (FILL 'NOT-A-SEQ 'A)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (FILL #\a 'A)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (FILL (LIST 0 1 2) 'A :START 'NOT-A-INT)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (FILL (LIST 0 1 2) 'A :START -1)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (FILL (LIST 0 1 2) 'A :END 'NOT-A-INT)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (FILL (LIST 0 1 2) 'A :END -1)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (MAKE-SEQUENCE '(VECTOR * 2) 3)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (MAKE-SEQUENCE '(VECTOR * 4) 3)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (MAKE-SEQUENCE '(ARRAY * 3) 2)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (MAKE-SEQUENCE '(ARRAY * (1 2 3)) 2)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (MAKE-SEQUENCE 'SYMBOL 2)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + + +(HANDLER-CASE (PROGN (SUBSEQ 'NOT-A-SEQ 0)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (SUBSEQ #\a 0)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (SETF (SUBSEQ (LIST 0 1 2 3) 1) 'NOT-A-SEQ)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (SETF (SUBSEQ (VECTOR 0 1 2 3) 1) 'NOT-A-SEQ)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (MAP '(VECTOR T 10) #'+ '(0 1) '(1 0))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (MAP 'LIST #'+ '(0 1) '(1 0) 'NOT-A-SEQ)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(progn + #-cmu + (HANDLER-CASE (PROGN (MAP '(VECTOR * 4) #'CONS "abc" "de")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + #+cmu 'skipped) +(progn + #-(or cmu clisp) + (HANDLER-CASE (PROGN (MAP 'NULL #'CONS "abc" "de")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + #+(or cmu clisp) 'skipped) +(progn + #-cmu + (HANDLER-CASE (PROGN (MAP '(CONS * NULL) #'CONS "abc" "de")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + #+cmu 'skipped) + + +(HANDLER-CASE (PROGN (MAP-INTO 'NOT-A-SEQ #'+ '(0 1 2))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(progn + #-cmu + (HANDLER-CASE (PROGN (MAP-INTO (LIST 0 1 2 3) #'+ 'NOT-A-SEQ)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + #+cmu 'skipped) +(progn + #-cmu + (HANDLER-CASE (PROGN (MAP-INTO (LIST 0 1 2 3) #'+ '(0 1) 'NOT-A-SEQ)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + #+cmu 'skipped) + +(HANDLER-CASE (PROGN (REDUCE #'LIST 'NOT-A-SEQUENCE)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (COUNT 0 'NOT-A-SEQUENCE)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (COUNT 0 #\a)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (COUNT-IF #'NUMBERP 'NOT-A-SEQUENCE)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (COUNT-IF #'NUMBERP #\a)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (COUNT-IF-NOT #'NUMBERP 'NOT-A-SEQUENCE)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (COUNT-IF-NOT #'NUMBERP #\a)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (REVERSE 'NOT-A-SEQUENCE)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (NREVERSE 'NOT-A-SEQUENCE)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + + +(HANDLER-CASE (PROGN (FIND 'ITEM 'NOT-A-SEQUENCE)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (FIND-IF (CONSTANTLY NIL) 'NOT-A-SEQUENCE)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (FIND-IF-NOT (CONSTANTLY T) 'NOT-A-SEQUENCE)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (POSITION 'ITEM 'NOT-A-SEQUENCE)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (POSITION-IF (CONSTANTLY NIL) 'NOT-A-SEQUENCE)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (POSITION-IF-NOT (CONSTANTLY T) 'NOT-A-SEQUENCE)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (CONCATENATE '(VECTOR * 2) "a" "bc")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (MERGE '(VECTOR * 4) '(1 5) '(2 4 6) #'<)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (REMOVE 'A 'NOT-A-SEQUENCE)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (REMOVE-IF (CONSTANTLY T) 'NOT-A-SEQUENCE)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE + (PROGN (REMOVE-IF-NOT (COMPLEMENT (CONSTANTLY T)) 'NOT-A-SEQUENCE)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (DELETE 'A 'NOT-A-SEQUENCE)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (DELETE-IF (CONSTANTLY T) 'NOT-A-SEQUENCE)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE + (PROGN (DELETE-IF-NOT (COMPLEMENT (CONSTANTLY T)) 'NOT-A-SEQUENCE)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (REMOVE-DUPLICATES 'NOT-A-SEQUENCE)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (DELETE-DUPLICATES 'NOT-A-SEQUENCE)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + diff --git a/Sacla/tests/should-string.lisp b/Sacla/tests/should-string.lisp new file mode 100644 index 0000000..53a4c8b --- /dev/null +++ b/Sacla/tests/should-string.lisp @@ -0,0 +1,28 @@ +;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp> +;; ALL RIGHTS RESERVED. +;; +;; $Id: should-string.lisp,v 1.8 2004/02/20 07:23:42 yuji Exp $ +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; * Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; * Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + diff --git a/Sacla/tests/should-symbol.lisp b/Sacla/tests/should-symbol.lisp new file mode 100644 index 0000000..9628622 --- /dev/null +++ b/Sacla/tests/should-symbol.lisp @@ -0,0 +1,227 @@ +;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp> +;; ALL RIGHTS RESERVED. +;; +;; $Id: should-symbol.lisp,v 1.7 2004/02/20 07:23:42 yuji Exp $ +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; * Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; * Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(HANDLER-CASE (PROGN (MAKE-SYMBOL 'NOT-A-STRING)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (MAKE-SYMBOL #\a)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (MAKE-SYMBOL '(NAME))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (COPY-SYMBOL "NOT A SYMBOL")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (COPY-SYMBOL #\a)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (COPY-SYMBOL '(NAME))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + + +(HANDLER-CASE (PROGN (GENSYM 'EAT-THIS)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (GENSYM -1)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (GENSYM #\a)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + + +(HANDLER-CASE (PROGN (GENTEMP 'NOT-A-STRING)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (GENTEMP #\a)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (GENTEMP "TEMP" '(NIL))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + + +(HANDLER-CASE (PROGN (SYMBOL-FUNCTION "not-a-function")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (SYMBOL-FUNCTION #\a)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (SYMBOL-FUNCTION '(NIL))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE + (PROGN (FMAKUNBOUND 'SYMBOL-FOR-TEST) (SYMBOL-FUNCTION 'SYMBOL-FOR-TEST)) + (UNDEFINED-FUNCTION NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (SYMBOL-NAME "not-a-symbol")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (SYMBOL-NAME #\a)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (SYMBOL-NAME '(NIL))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (SYMBOL-PACKAGE "not-a-symbol")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (SYMBOL-PACKAGE #\a)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (SYMBOL-PACKAGE '(NIL))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (SYMBOL-PLIST "not-a-symbol")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (SYMBOL-PLIST #\a)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (SYMBOL-PLIST '(NIL))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (SYMBOL-VALUE "not-a-symbol")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (SYMBOL-VALUE #\a)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (SYMBOL-VALUE '(NIL))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (PROGN (MAKUNBOUND 'A) (SYMBOL-VALUE 'A))) + (UNBOUND-VARIABLE NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + + + +(HANDLER-CASE (PROGN (GET "not-a-symbol" 'A)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (GET #\a 'A)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (GET '(NIL) 'A)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + + + +(HANDLER-CASE (PROGN (REMPROP "not-a-symbol" 'A)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (REMPROP #\a 'A)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (REMPROP '(NIL) 'A)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (BOUNDP "not-a-symbol")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (BOUNDP #\a)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (BOUNDP '(NIL))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (MAKUNBOUND "not-a-symbol")) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (MAKUNBOUND #\a)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (MAKUNBOUND '(NIL))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (SET "not-a-symbol" 1)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (SET #\a 0)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (SET '(NIL) 2)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + diff --git a/Sacla/tests/x-sequence.lisp b/Sacla/tests/x-sequence.lisp new file mode 100644 index 0000000..1c43652 --- /dev/null +++ b/Sacla/tests/x-sequence.lisp @@ -0,0 +1,300 @@ +;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp> +;; ALL RIGHTS RESERVED. +;; +;; $Id: x-sequence.lisp,v 1.11 2004/02/20 07:23:42 yuji Exp $ +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; * Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; * Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(HANDLER-CASE (PROGN (SUBSEQ '(0 1 . 2) 1)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (SUBSEQ '#1=(0 1 . #1#) 3)) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (MAP 'LIST #'+ '(0 1 . 2) '(1 0 -1 -2))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (REDUCE #'LIST '(1 . 2))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (REDUCE #'LIST '#1=(1 2 3 4 5 6 7 8 9 . #1#))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (REDUCE #'LIST '(A . #1=(1 2 3 4 5 6 7 8 9 . #1#)))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (REDUCE #'LIST '(A B . #1=(1 2 3 4 5 6 7 8 9 . #1#)))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (REDUCE #'LIST '(A B C . #1=(1 2 3 4 5 6 7 8 9 . #1#)))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (REDUCE #'LIST '(A B C D . #1=(1 2 3 4 5 6 7 8 9 . #1#)))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE + (PROGN (REDUCE #'LIST '(A B C D E . #1=(1 2 3 4 5 6 7 8 9 . #1#)))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE + (PROGN (REDUCE #'LIST '(A B C D E F . #1=(1 2 3 4 5 6 7 8 9 . #1#)))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE + (PROGN (REDUCE #'LIST '(A B C D E F G . #1=(1 2 3 4 5 6 7 8 9 . #1#)))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE + (PROGN (REDUCE #'LIST '(A B C D E F G H . #1=(1 2 3 4 5 6 7 8 9 . #1#)))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE + (PROGN (REDUCE #'LIST '(A B C D E F G H I . #1=(1 2 3 4 5 6 7 8 9 . #1#)))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE + (PROGN (REDUCE #'LIST '(A B C D E F G H I J . #1=(1 2 3 4 5 6 7 8 9 . #1#)))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE + (PROGN + (REDUCE #'LIST '(A B C D E F G H I J K . #1=(1 2 3 4 5 6 7 8 9 . #1#)))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + + +(HANDLER-CASE (PROGN (LENGTH '(A . B))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (LENGTH '#1=(0 1 . #1#))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (REDUCE #'LIST '(1 . 2))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (REDUCE #'LIST '#1=(1 2 3 4 5 6 7 8 9 . #1#))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (LENGTH '(A . #1=(1 2 3 4 5 6 7 8 9 . #1#)))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (LENGTH '(A B . #1=(1 2 3 4 5 6 7 8 9 . #1#)))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (LENGTH '(A B C . #1=(1 2 3 4 5 6 7 8 9 . #1#)))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (LENGTH '(A B C D . #1=(1 2 3 4 5 6 7 8 9 . #1#)))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (LENGTH '(A B C D E . #1=(1 2 3 4 5 6 7 8 9 . #1#)))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (LENGTH '(A B C D E F . #1=(1 2 3 4 5 6 7 8 9 . #1#)))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (LENGTH '(A B C D E F G . #1=(1 2 3 4 5 6 7 8 9 . #1#)))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE + (PROGN (LENGTH '(A B C D E F G H . #1=(1 2 3 4 5 6 7 8 9 . #1#)))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE + (PROGN (LENGTH '(A B C D E F G H I . #1=(1 2 3 4 5 6 7 8 9 . #1#)))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE + (PROGN (LENGTH '(A B C D E F G H I J . #1=(1 2 3 4 5 6 7 8 9 . #1#)))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE + (PROGN (LENGTH '(A B C D E F G H I J K . #1=(1 2 3 4 5 6 7 8 9 . #1#)))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + + +(HANDLER-CASE (PROGN (REVERSE '(A . B))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (REVERSE '#1=(0 1 . #1#))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (REVERSE '#1=(1 2 3 4 5 6 7 8 9 . #1#))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (REVERSE '(A . #1=(1 2 3 4 5 6 7 8 9 . #1#)))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (REVERSE '(A B . #1=(1 2 3 4 5 6 7 8 9 . #1#)))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (REVERSE '(A B C . #1=(1 2 3 4 5 6 7 8 9 . #1#)))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (REVERSE '(A B C D . #1=(1 2 3 4 5 6 7 8 9 . #1#)))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (REVERSE '(A B C D E . #1=(1 2 3 4 5 6 7 8 9 . #1#)))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (REVERSE '(A B C D E F . #1=(1 2 3 4 5 6 7 8 9 . #1#)))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (REVERSE '(A B C D E F G . #1=(1 2 3 4 5 6 7 8 9 . #1#)))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE + (PROGN (REVERSE '(A B C D E F G H . #1=(1 2 3 4 5 6 7 8 9 . #1#)))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE + (PROGN (REVERSE '(A B C D E F G H I . #1=(1 2 3 4 5 6 7 8 9 . #1#)))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE + (PROGN (REVERSE '(A B C D E F G H I J . #1=(1 2 3 4 5 6 7 8 9 . #1#)))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE + (PROGN (REVERSE '(A B C D E F G H I J K . #1=(1 2 3 4 5 6 7 8 9 . #1#)))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + + +(HANDLER-CASE (PROGN (NREVERSE (CONS 'A 'B))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE + (PROGN + (LET ((A (LIST 0 1))) + (SETF (CDDR A) A) + (NREVERSE A))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE + (PROGN + (LET ((A (LIST 0 1 2 3))) + (SETF (CDR (NTHCDR 3 A)) A) + (NREVERSE A))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE + (PROGN + (LET ((A (LIST 0 1 2 3 4))) + (SETF (CDR (NTHCDR 4 A)) (CDDR A)) + (NREVERSE A))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (FIND 'ITEM '(A B . C))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (FIND-IF (CONSTANTLY NIL) '(A B . C))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (FIND-IF-NOT (CONSTANTLY T) '(A B . C))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (FIND 'ITEM '#1=(A B . #1#))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (FIND-IF (CONSTANTLY NIL) '#1=(A B . #1#))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (FIND-IF-NOT (CONSTANTLY T) '#1=(A B . #1#))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) + +(HANDLER-CASE (PROGN (POSITION 'ITEM '#1=(A B . #1#))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (POSITION-IF (CONSTANTLY NIL) '#1=(A B . #1#))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) +(HANDLER-CASE (PROGN (POSITION-IF-NOT (CONSTANTLY T) '#1=(A B . #1#))) + (TYPE-ERROR NIL T) + (ERROR NIL NIL) + (:NO-ERROR (&REST REST) (DECLARE (IGNORE REST)) NIL)) |